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_Pakd; use Exp_Pakd; 39with Exp_Tss; use Exp_Tss; 40with Exp_Util; use Exp_Util; 41with Fname; use Fname; 42with Freeze; use Freeze; 43with Itypes; use Itypes; 44with Layout; use Layout; 45with Lib; use Lib; 46with Lib.Xref; use Lib.Xref; 47with Namet; use Namet; 48with Nmake; use Nmake; 49with Opt; use Opt; 50with Restrict; use Restrict; 51with Rident; use Rident; 52with Rtsfind; use Rtsfind; 53with Sem; use Sem; 54with Sem_Aux; use Sem_Aux; 55with Sem_Case; use Sem_Case; 56with Sem_Cat; use Sem_Cat; 57with Sem_Ch6; use Sem_Ch6; 58with Sem_Ch7; use Sem_Ch7; 59with Sem_Ch8; use Sem_Ch8; 60with Sem_Ch13; use Sem_Ch13; 61with Sem_Dim; use Sem_Dim; 62with Sem_Disp; use Sem_Disp; 63with Sem_Dist; use Sem_Dist; 64with Sem_Elim; use Sem_Elim; 65with Sem_Eval; use Sem_Eval; 66with Sem_Mech; use Sem_Mech; 67with Sem_Prag; use Sem_Prag; 68with Sem_Res; use Sem_Res; 69with Sem_Smem; use Sem_Smem; 70with Sem_Type; use Sem_Type; 71with Sem_Util; use Sem_Util; 72with Sem_Warn; use Sem_Warn; 73with Stand; use Stand; 74with Sinfo; use Sinfo; 75with Sinput; use Sinput; 76with Snames; use Snames; 77with Targparm; use Targparm; 78with Tbuild; use Tbuild; 79with Ttypes; use Ttypes; 80with Uintp; use Uintp; 81with Urealp; use Urealp; 82 83package body Sem_Ch3 is 84 85 ----------------------- 86 -- Local Subprograms -- 87 ----------------------- 88 89 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id); 90 -- Ada 2005 (AI-251): Add the tag components corresponding to all the 91 -- abstract interface types implemented by a record type or a derived 92 -- record type. 93 94 procedure Analyze_Object_Contract (Obj_Id : Entity_Id); 95 -- Analyze all delayed aspects chained on the contract of object Obj_Id as 96 -- if they appeared at the end of the declarative region. The aspects to be 97 -- considered are: 98 -- Async_Readers 99 -- Async_Writers 100 -- Effective_Reads 101 -- Effective_Writes 102 -- Part_Of 103 104 procedure Build_Derived_Type 105 (N : Node_Id; 106 Parent_Type : Entity_Id; 107 Derived_Type : Entity_Id; 108 Is_Completion : Boolean; 109 Derive_Subps : Boolean := True); 110 -- Create and decorate a Derived_Type given the Parent_Type entity. N is 111 -- the N_Full_Type_Declaration node containing the derived type definition. 112 -- Parent_Type is the entity for the parent type in the derived type 113 -- definition and Derived_Type the actual derived type. Is_Completion must 114 -- be set to False if Derived_Type is the N_Defining_Identifier node in N 115 -- (i.e. Derived_Type = Defining_Identifier (N)). In this case N is not the 116 -- completion of a private type declaration. If Is_Completion is set to 117 -- True, N is the completion of a private type declaration and Derived_Type 118 -- is different from the defining identifier inside N (i.e. Derived_Type /= 119 -- Defining_Identifier (N)). Derive_Subps indicates whether the parent 120 -- subprograms should be derived. The only case where this parameter is 121 -- False is when Build_Derived_Type is recursively called to process an 122 -- implicit derived full type for a type derived from a private type (in 123 -- that case the subprograms must only be derived for the private view of 124 -- the type). 125 -- 126 -- ??? These flags need a bit of re-examination and re-documentation: 127 -- ??? are they both necessary (both seem related to the recursion)? 128 129 procedure Build_Derived_Access_Type 130 (N : Node_Id; 131 Parent_Type : Entity_Id; 132 Derived_Type : Entity_Id); 133 -- Subsidiary procedure to Build_Derived_Type. For a derived access type, 134 -- create an implicit base if the parent type is constrained or if the 135 -- subtype indication has a constraint. 136 137 procedure Build_Derived_Array_Type 138 (N : Node_Id; 139 Parent_Type : Entity_Id; 140 Derived_Type : Entity_Id); 141 -- Subsidiary procedure to Build_Derived_Type. For a derived array type, 142 -- create an implicit base if the parent type is constrained or if the 143 -- subtype indication has a constraint. 144 145 procedure Build_Derived_Concurrent_Type 146 (N : Node_Id; 147 Parent_Type : Entity_Id; 148 Derived_Type : Entity_Id); 149 -- Subsidiary procedure to Build_Derived_Type. For a derived task or 150 -- protected type, inherit entries and protected subprograms, check 151 -- legality of discriminant constraints if any. 152 153 procedure Build_Derived_Enumeration_Type 154 (N : Node_Id; 155 Parent_Type : Entity_Id; 156 Derived_Type : Entity_Id); 157 -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration 158 -- type, we must create a new list of literals. Types derived from 159 -- Character and [Wide_]Wide_Character are special-cased. 160 161 procedure Build_Derived_Numeric_Type 162 (N : Node_Id; 163 Parent_Type : Entity_Id; 164 Derived_Type : Entity_Id); 165 -- Subsidiary procedure to Build_Derived_Type. For numeric types, create 166 -- an anonymous base type, and propagate constraint to subtype if needed. 167 168 procedure Build_Derived_Private_Type 169 (N : Node_Id; 170 Parent_Type : Entity_Id; 171 Derived_Type : Entity_Id; 172 Is_Completion : Boolean; 173 Derive_Subps : Boolean := True); 174 -- Subsidiary procedure to Build_Derived_Type. This procedure is complex 175 -- because the parent may or may not have a completion, and the derivation 176 -- may itself be a completion. 177 178 procedure Build_Derived_Record_Type 179 (N : Node_Id; 180 Parent_Type : Entity_Id; 181 Derived_Type : Entity_Id; 182 Derive_Subps : Boolean := True); 183 -- Subsidiary procedure used for tagged and untagged record types 184 -- by Build_Derived_Type and Analyze_Private_Extension_Declaration. 185 -- All parameters are as in Build_Derived_Type except that N, in 186 -- addition to being an N_Full_Type_Declaration node, can also be an 187 -- N_Private_Extension_Declaration node. See the definition of this routine 188 -- for much more info. Derive_Subps indicates whether subprograms should be 189 -- derived from the parent type. The only case where Derive_Subps is False 190 -- is for an implicit derived full type for a type derived from a private 191 -- type (see Build_Derived_Type). 192 193 procedure Build_Discriminal (Discrim : Entity_Id); 194 -- Create the discriminal corresponding to discriminant Discrim, that is 195 -- the parameter corresponding to Discrim to be used in initialization 196 -- procedures for the type where Discrim is a discriminant. Discriminals 197 -- are not used during semantic analysis, and are not fully defined 198 -- entities until expansion. Thus they are not given a scope until 199 -- initialization procedures are built. 200 201 function Build_Discriminant_Constraints 202 (T : Entity_Id; 203 Def : Node_Id; 204 Derived_Def : Boolean := False) return Elist_Id; 205 -- Validate discriminant constraints and return the list of the constraints 206 -- in order of discriminant declarations, where T is the discriminated 207 -- unconstrained type. Def is the N_Subtype_Indication node where the 208 -- discriminants constraints for T are specified. Derived_Def is True 209 -- when building the discriminant constraints in a derived type definition 210 -- of the form "type D (...) is new T (xxx)". In this case T is the parent 211 -- type and Def is the constraint "(xxx)" on T and this routine sets the 212 -- Corresponding_Discriminant field of the discriminants in the derived 213 -- type D to point to the corresponding discriminants in the parent type T. 214 215 procedure Build_Discriminated_Subtype 216 (T : Entity_Id; 217 Def_Id : Entity_Id; 218 Elist : Elist_Id; 219 Related_Nod : Node_Id; 220 For_Access : Boolean := False); 221 -- Subsidiary procedure to Constrain_Discriminated_Type and to 222 -- Process_Incomplete_Dependents. Given 223 -- 224 -- T (a possibly discriminated base type) 225 -- Def_Id (a very partially built subtype for T), 226 -- 227 -- the call completes Def_Id to be the appropriate E_*_Subtype. 228 -- 229 -- The Elist is the list of discriminant constraints if any (it is set 230 -- to No_Elist if T is not a discriminated type, and to an empty list if 231 -- T has discriminants but there are no discriminant constraints). The 232 -- Related_Nod is the same as Decl_Node in Create_Constrained_Components. 233 -- The For_Access says whether or not this subtype is really constraining 234 -- an access type. That is its sole purpose is the designated type of an 235 -- access type -- in which case a Private_Subtype Is_For_Access_Subtype 236 -- is built to avoid freezing T when the access subtype is frozen. 237 238 function Build_Scalar_Bound 239 (Bound : Node_Id; 240 Par_T : Entity_Id; 241 Der_T : Entity_Id) return Node_Id; 242 -- The bounds of a derived scalar type are conversions of the bounds of 243 -- the parent type. Optimize the representation if the bounds are literals. 244 -- Needs a more complete spec--what are the parameters exactly, and what 245 -- exactly is the returned value, and how is Bound affected??? 246 247 procedure Build_Underlying_Full_View 248 (N : Node_Id; 249 Typ : Entity_Id; 250 Par : Entity_Id); 251 -- If the completion of a private type is itself derived from a private 252 -- type, or if the full view of a private subtype is itself private, the 253 -- back-end has no way to compute the actual size of this type. We build 254 -- an internal subtype declaration of the proper parent type to convey 255 -- this information. This extra mechanism is needed because a full 256 -- view cannot itself have a full view (it would get clobbered during 257 -- view exchanges). 258 259 procedure Check_Access_Discriminant_Requires_Limited 260 (D : Node_Id; 261 Loc : Node_Id); 262 -- Check the restriction that the type to which an access discriminant 263 -- belongs must be a concurrent type or a descendant of a type with 264 -- the reserved word 'limited' in its declaration. 265 266 procedure Check_Anonymous_Access_Components 267 (Typ_Decl : Node_Id; 268 Typ : Entity_Id; 269 Prev : Entity_Id; 270 Comp_List : Node_Id); 271 -- Ada 2005 AI-382: an access component in a record definition can refer to 272 -- the enclosing record, in which case it denotes the type itself, and not 273 -- the current instance of the type. We create an anonymous access type for 274 -- the component, and flag it as an access to a component, so accessibility 275 -- checks are properly performed on it. The declaration of the access type 276 -- is placed ahead of that of the record to prevent order-of-elaboration 277 -- circularity issues in Gigi. We create an incomplete type for the record 278 -- declaration, which is the designated type of the anonymous access. 279 280 procedure Check_Delta_Expression (E : Node_Id); 281 -- Check that the expression represented by E is suitable for use as a 282 -- delta expression, i.e. it is of real type and is static. 283 284 procedure Check_Digits_Expression (E : Node_Id); 285 -- Check that the expression represented by E is suitable for use as a 286 -- digits expression, i.e. it is of integer type, positive and static. 287 288 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id); 289 -- Validate the initialization of an object declaration. T is the required 290 -- type, and Exp is the initialization expression. 291 292 procedure Check_Interfaces (N : Node_Id; Def : Node_Id); 293 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) 294 295 procedure Check_Or_Process_Discriminants 296 (N : Node_Id; 297 T : Entity_Id; 298 Prev : Entity_Id := Empty); 299 -- If N is the full declaration of the completion T of an incomplete or 300 -- private type, check its discriminants (which are already known to be 301 -- conformant with those of the partial view, see Find_Type_Name), 302 -- otherwise process them. Prev is the entity of the partial declaration, 303 -- if any. 304 305 procedure Check_Real_Bound (Bound : Node_Id); 306 -- Check given bound for being of real type and static. If not, post an 307 -- appropriate message, and rewrite the bound with the real literal zero. 308 309 procedure Constant_Redeclaration 310 (Id : Entity_Id; 311 N : Node_Id; 312 T : out Entity_Id); 313 -- Various checks on legality of full declaration of deferred constant. 314 -- Id is the entity for the redeclaration, N is the N_Object_Declaration, 315 -- node. The caller has not yet set any attributes of this entity. 316 317 function Contain_Interface 318 (Iface : Entity_Id; 319 Ifaces : Elist_Id) return Boolean; 320 -- Ada 2005: Determine whether Iface is present in the list Ifaces 321 322 procedure Convert_Scalar_Bounds 323 (N : Node_Id; 324 Parent_Type : Entity_Id; 325 Derived_Type : Entity_Id; 326 Loc : Source_Ptr); 327 -- For derived scalar types, convert the bounds in the type definition to 328 -- the derived type, and complete their analysis. Given a constraint of the 329 -- form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with 330 -- T'Base, the parent_type. The bounds of the derived type (the anonymous 331 -- base) are copies of Lo and Hi. Finally, the bounds of the derived 332 -- subtype are conversions of those bounds to the derived_type, so that 333 -- their typing is consistent. 334 335 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id); 336 -- Copies attributes from array base type T2 to array base type T1. Copies 337 -- only attributes that apply to base types, but not subtypes. 338 339 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id); 340 -- Copies attributes from array subtype T2 to array subtype T1. Copies 341 -- attributes that apply to both subtypes and base types. 342 343 procedure Create_Constrained_Components 344 (Subt : Entity_Id; 345 Decl_Node : Node_Id; 346 Typ : Entity_Id; 347 Constraints : Elist_Id); 348 -- Build the list of entities for a constrained discriminated record 349 -- subtype. If a component depends on a discriminant, replace its subtype 350 -- using the discriminant values in the discriminant constraint. Subt 351 -- is the defining identifier for the subtype whose list of constrained 352 -- entities we will create. Decl_Node is the type declaration node where 353 -- we will attach all the itypes created. Typ is the base discriminated 354 -- type for the subtype Subt. Constraints is the list of discriminant 355 -- constraints for Typ. 356 357 function Constrain_Component_Type 358 (Comp : Entity_Id; 359 Constrained_Typ : Entity_Id; 360 Related_Node : Node_Id; 361 Typ : Entity_Id; 362 Constraints : Elist_Id) return Entity_Id; 363 -- Given a discriminated base type Typ, a list of discriminant constraint 364 -- Constraints for Typ and a component of Typ, with type Compon_Type, 365 -- create and return the type corresponding to Compon_type where all 366 -- discriminant references are replaced with the corresponding constraint. 367 -- If no discriminant references occur in Compon_Typ then return it as is. 368 -- Constrained_Typ is the final constrained subtype to which the 369 -- constrained Compon_Type belongs. Related_Node is the node where we will 370 -- attach all the itypes created. 371 -- 372 -- Above description is confused, what is Compon_Type??? 373 374 procedure Constrain_Access 375 (Def_Id : in out Entity_Id; 376 S : Node_Id; 377 Related_Nod : Node_Id); 378 -- Apply a list of constraints to an access type. If Def_Id is empty, it is 379 -- an anonymous type created for a subtype indication. In that case it is 380 -- created in the procedure and attached to Related_Nod. 381 382 procedure Constrain_Array 383 (Def_Id : in out Entity_Id; 384 SI : Node_Id; 385 Related_Nod : Node_Id; 386 Related_Id : Entity_Id; 387 Suffix : Character); 388 -- Apply a list of index constraints to an unconstrained array type. The 389 -- first parameter is the entity for the resulting subtype. A value of 390 -- Empty for Def_Id indicates that an implicit type must be created, but 391 -- creation is delayed (and must be done by this procedure) because other 392 -- subsidiary implicit types must be created first (which is why Def_Id 393 -- is an in/out parameter). The second parameter is a subtype indication 394 -- node for the constrained array to be created (e.g. something of the 395 -- form string (1 .. 10)). Related_Nod gives the place where this type 396 -- has to be inserted in the tree. The Related_Id and Suffix parameters 397 -- are used to build the associated Implicit type name. 398 399 procedure Constrain_Concurrent 400 (Def_Id : in out Entity_Id; 401 SI : Node_Id; 402 Related_Nod : Node_Id; 403 Related_Id : Entity_Id; 404 Suffix : Character); 405 -- Apply list of discriminant constraints to an unconstrained concurrent 406 -- type. 407 -- 408 -- SI is the N_Subtype_Indication node containing the constraint and 409 -- the unconstrained type to constrain. 410 -- 411 -- Def_Id is the entity for the resulting constrained subtype. A value 412 -- of Empty for Def_Id indicates that an implicit type must be created, 413 -- but creation is delayed (and must be done by this procedure) because 414 -- other subsidiary implicit types must be created first (which is why 415 -- Def_Id is an in/out parameter). 416 -- 417 -- Related_Nod gives the place where this type has to be inserted 418 -- in the tree 419 -- 420 -- The last two arguments are used to create its external name if needed. 421 422 function Constrain_Corresponding_Record 423 (Prot_Subt : Entity_Id; 424 Corr_Rec : Entity_Id; 425 Related_Nod : Node_Id; 426 Related_Id : Entity_Id) return Entity_Id; 427 -- When constraining a protected type or task type with discriminants, 428 -- constrain the corresponding record with the same discriminant values. 429 430 procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id); 431 -- Constrain a decimal fixed point type with a digits constraint and/or a 432 -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity. 433 434 procedure Constrain_Discriminated_Type 435 (Def_Id : Entity_Id; 436 S : Node_Id; 437 Related_Nod : Node_Id; 438 For_Access : Boolean := False); 439 -- Process discriminant constraints of composite type. Verify that values 440 -- have been provided for all discriminants, that the original type is 441 -- unconstrained, and that the types of the supplied expressions match 442 -- the discriminant types. The first three parameters are like in routine 443 -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation 444 -- of For_Access. 445 446 procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id); 447 -- Constrain an enumeration type with a range constraint. This is identical 448 -- to Constrain_Integer, but for the Ekind of the resulting subtype. 449 450 procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id); 451 -- Constrain a floating point type with either a digits constraint 452 -- and/or a range constraint, building a E_Floating_Point_Subtype. 453 454 procedure Constrain_Index 455 (Index : Node_Id; 456 S : Node_Id; 457 Related_Nod : Node_Id; 458 Related_Id : Entity_Id; 459 Suffix : Character; 460 Suffix_Index : Nat); 461 -- Process an index constraint S in a constrained array declaration. The 462 -- constraint can be a subtype name, or a range with or without an explicit 463 -- subtype mark. The index is the corresponding index of the unconstrained 464 -- array. The Related_Id and Suffix parameters are used to build the 465 -- associated Implicit type name. 466 467 procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id); 468 -- Build subtype of a signed or modular integer type 469 470 procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id); 471 -- Constrain an ordinary fixed point type with a range constraint, and 472 -- build an E_Ordinary_Fixed_Point_Subtype entity. 473 474 procedure Copy_And_Swap (Priv, Full : Entity_Id); 475 -- Copy the Priv entity into the entity of its full declaration then swap 476 -- the two entities in such a manner that the former private type is now 477 -- seen as a full type. 478 479 procedure Decimal_Fixed_Point_Type_Declaration 480 (T : Entity_Id; 481 Def : Node_Id); 482 -- Create a new decimal fixed point type, and apply the constraint to 483 -- obtain a subtype of this new type. 484 485 procedure Complete_Private_Subtype 486 (Priv : Entity_Id; 487 Full : Entity_Id; 488 Full_Base : Entity_Id; 489 Related_Nod : Node_Id); 490 -- Complete the implicit full view of a private subtype by setting the 491 -- appropriate semantic fields. If the full view of the parent is a record 492 -- type, build constrained components of subtype. 493 494 procedure Derive_Progenitor_Subprograms 495 (Parent_Type : Entity_Id; 496 Tagged_Type : Entity_Id); 497 -- Ada 2005 (AI-251): To complete type derivation, collect the primitive 498 -- operations of progenitors of Tagged_Type, and replace the subsidiary 499 -- subtypes with Tagged_Type, to build the specs of the inherited interface 500 -- primitives. The derived primitives are aliased to those of the 501 -- interface. This routine takes care also of transferring to the full view 502 -- subprograms associated with the partial view of Tagged_Type that cover 503 -- interface primitives. 504 505 procedure Derived_Standard_Character 506 (N : Node_Id; 507 Parent_Type : Entity_Id; 508 Derived_Type : Entity_Id); 509 -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles 510 -- derivations from types Standard.Character and Standard.Wide_Character. 511 512 procedure Derived_Type_Declaration 513 (T : Entity_Id; 514 N : Node_Id; 515 Is_Completion : Boolean); 516 -- Process a derived type declaration. Build_Derived_Type is invoked 517 -- to process the actual derived type definition. Parameters N and 518 -- Is_Completion have the same meaning as in Build_Derived_Type. 519 -- T is the N_Defining_Identifier for the entity defined in the 520 -- N_Full_Type_Declaration node N, that is T is the derived type. 521 522 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id); 523 -- Insert each literal in symbol table, as an overloadable identifier. Each 524 -- enumeration type is mapped into a sequence of integers, and each literal 525 -- is defined as a constant with integer value. If any of the literals are 526 -- character literals, the type is a character type, which means that 527 -- strings are legal aggregates for arrays of components of the type. 528 529 function Expand_To_Stored_Constraint 530 (Typ : Entity_Id; 531 Constraint : Elist_Id) return Elist_Id; 532 -- Given a constraint (i.e. a list of expressions) on the discriminants of 533 -- Typ, expand it into a constraint on the stored discriminants and return 534 -- the new list of expressions constraining the stored discriminants. 535 536 function Find_Type_Of_Object 537 (Obj_Def : Node_Id; 538 Related_Nod : Node_Id) return Entity_Id; 539 -- Get type entity for object referenced by Obj_Def, attaching the 540 -- implicit types generated to Related_Nod 541 542 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id); 543 -- Create a new float and apply the constraint to obtain subtype of it 544 545 function Has_Range_Constraint (N : Node_Id) return Boolean; 546 -- Given an N_Subtype_Indication node N, return True if a range constraint 547 -- is present, either directly, or as part of a digits or delta constraint. 548 -- In addition, a digits constraint in the decimal case returns True, since 549 -- it establishes a default range if no explicit range is present. 550 551 function Inherit_Components 552 (N : Node_Id; 553 Parent_Base : Entity_Id; 554 Derived_Base : Entity_Id; 555 Is_Tagged : Boolean; 556 Inherit_Discr : Boolean; 557 Discs : Elist_Id) return Elist_Id; 558 -- Called from Build_Derived_Record_Type to inherit the components of 559 -- Parent_Base (a base type) into the Derived_Base (the derived base type). 560 -- For more information on derived types and component inheritance please 561 -- consult the comment above the body of Build_Derived_Record_Type. 562 -- 563 -- N is the original derived type declaration 564 -- 565 -- Is_Tagged is set if we are dealing with tagged types 566 -- 567 -- If Inherit_Discr is set, Derived_Base inherits its discriminants from 568 -- Parent_Base, otherwise no discriminants are inherited. 569 -- 570 -- Discs gives the list of constraints that apply to Parent_Base in the 571 -- derived type declaration. If Discs is set to No_Elist, then we have 572 -- the following situation: 573 -- 574 -- type Parent (D1..Dn : ..) is [tagged] record ...; 575 -- type Derived is new Parent [with ...]; 576 -- 577 -- which gets treated as 578 -- 579 -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...]; 580 -- 581 -- For untagged types the returned value is an association list. The list 582 -- starts from the association (Parent_Base => Derived_Base), and then it 583 -- contains a sequence of the associations of the form 584 -- 585 -- (Old_Component => New_Component), 586 -- 587 -- where Old_Component is the Entity_Id of a component in Parent_Base and 588 -- New_Component is the Entity_Id of the corresponding component in 589 -- Derived_Base. For untagged records, this association list is needed when 590 -- copying the record declaration for the derived base. In the tagged case 591 -- the value returned is irrelevant. 592 593 function Is_Valid_Constraint_Kind 594 (T_Kind : Type_Kind; 595 Constraint_Kind : Node_Kind) return Boolean; 596 -- Returns True if it is legal to apply the given kind of constraint to the 597 -- given kind of type (index constraint to an array type, for example). 598 599 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id); 600 -- Create new modular type. Verify that modulus is in bounds 601 602 procedure New_Concatenation_Op (Typ : Entity_Id); 603 -- Create an abbreviated declaration for an operator in order to 604 -- materialize concatenation on array types. 605 606 procedure Ordinary_Fixed_Point_Type_Declaration 607 (T : Entity_Id; 608 Def : Node_Id); 609 -- Create a new ordinary fixed point type, and apply the constraint to 610 -- obtain subtype of it. 611 612 procedure Prepare_Private_Subtype_Completion 613 (Id : Entity_Id; 614 Related_Nod : Node_Id); 615 -- Id is a subtype of some private type. Creates the full declaration 616 -- associated with Id whenever possible, i.e. when the full declaration 617 -- of the base type is already known. Records each subtype into 618 -- Private_Dependents of the base type. 619 620 procedure Process_Incomplete_Dependents 621 (N : Node_Id; 622 Full_T : Entity_Id; 623 Inc_T : Entity_Id); 624 -- Process all entities that depend on an incomplete type. There include 625 -- subtypes, subprogram types that mention the incomplete type in their 626 -- profiles, and subprogram with access parameters that designate the 627 -- incomplete type. 628 629 -- Inc_T is the defining identifier of an incomplete type declaration, its 630 -- Ekind is E_Incomplete_Type. 631 -- 632 -- N is the corresponding N_Full_Type_Declaration for Inc_T. 633 -- 634 -- Full_T is N's defining identifier. 635 -- 636 -- Subtypes of incomplete types with discriminants are completed when the 637 -- parent type is. This is simpler than private subtypes, because they can 638 -- only appear in the same scope, and there is no need to exchange views. 639 -- Similarly, access_to_subprogram types may have a parameter or a return 640 -- type that is an incomplete type, and that must be replaced with the 641 -- full type. 642 -- 643 -- If the full type is tagged, subprogram with access parameters that 644 -- designated the incomplete may be primitive operations of the full type, 645 -- and have to be processed accordingly. 646 647 procedure Process_Real_Range_Specification (Def : Node_Id); 648 -- Given the type definition for a real type, this procedure processes and 649 -- checks the real range specification of this type definition if one is 650 -- present. If errors are found, error messages are posted, and the 651 -- Real_Range_Specification of Def is reset to Empty. 652 653 procedure Record_Type_Declaration 654 (T : Entity_Id; 655 N : Node_Id; 656 Prev : Entity_Id); 657 -- Process a record type declaration (for both untagged and tagged 658 -- records). Parameters T and N are exactly like in procedure 659 -- Derived_Type_Declaration, except that no flag Is_Completion is needed 660 -- for this routine. If this is the completion of an incomplete type 661 -- declaration, Prev is the entity of the incomplete declaration, used for 662 -- cross-referencing. Otherwise Prev = T. 663 664 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id); 665 -- This routine is used to process the actual record type definition (both 666 -- for untagged and tagged records). Def is a record type definition node. 667 -- This procedure analyzes the components in this record type definition. 668 -- Prev_T is the entity for the enclosing record type. It is provided so 669 -- that its Has_Task flag can be set if any of the component have Has_Task 670 -- set. If the declaration is the completion of an incomplete type 671 -- declaration, Prev_T is the original incomplete type, whose full view is 672 -- the record type. 673 674 procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id); 675 -- Subsidiary to Build_Derived_Record_Type. For untagged records, we 676 -- build a copy of the declaration tree of the parent, and we create 677 -- independently the list of components for the derived type. Semantic 678 -- information uses the component entities, but record representation 679 -- clauses are validated on the declaration tree. This procedure replaces 680 -- discriminants and components in the declaration with those that have 681 -- been created by Inherit_Components. 682 683 procedure Set_Fixed_Range 684 (E : Entity_Id; 685 Loc : Source_Ptr; 686 Lo : Ureal; 687 Hi : Ureal); 688 -- Build a range node with the given bounds and set it as the Scalar_Range 689 -- of the given fixed-point type entity. Loc is the source location used 690 -- for the constructed range. See body for further details. 691 692 procedure Set_Scalar_Range_For_Subtype 693 (Def_Id : Entity_Id; 694 R : Node_Id; 695 Subt : Entity_Id); 696 -- This routine is used to set the scalar range field for a subtype given 697 -- Def_Id, the entity for the subtype, and R, the range expression for the 698 -- scalar range. Subt provides the parent subtype to be used to analyze, 699 -- resolve, and check the given range. 700 701 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id); 702 -- Create a new signed integer entity, and apply the constraint to obtain 703 -- the required first named subtype of this type. 704 705 procedure Set_Stored_Constraint_From_Discriminant_Constraint 706 (E : Entity_Id); 707 -- E is some record type. This routine computes E's Stored_Constraint 708 -- from its Discriminant_Constraint. 709 710 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id); 711 -- Check that an entity in a list of progenitors is an interface, 712 -- emit error otherwise. 713 714 ----------------------- 715 -- Access_Definition -- 716 ----------------------- 717 718 function Access_Definition 719 (Related_Nod : Node_Id; 720 N : Node_Id) return Entity_Id 721 is 722 Anon_Type : Entity_Id; 723 Anon_Scope : Entity_Id; 724 Desig_Type : Entity_Id; 725 Enclosing_Prot_Type : Entity_Id := Empty; 726 727 begin 728 Check_SPARK_Restriction ("access type is not allowed", N); 729 730 if Is_Entry (Current_Scope) 731 and then Is_Task_Type (Etype (Scope (Current_Scope))) 732 then 733 Error_Msg_N ("task entries cannot have access parameters", N); 734 return Empty; 735 end if; 736 737 -- Ada 2005: For an object declaration the corresponding anonymous 738 -- type is declared in the current scope. 739 740 -- If the access definition is the return type of another access to 741 -- function, scope is the current one, because it is the one of the 742 -- current type declaration, except for the pathological case below. 743 744 if Nkind_In (Related_Nod, N_Object_Declaration, 745 N_Access_Function_Definition) 746 then 747 Anon_Scope := Current_Scope; 748 749 -- A pathological case: function returning access functions that 750 -- return access functions, etc. Each anonymous access type created 751 -- is in the enclosing scope of the outermost function. 752 753 declare 754 Par : Node_Id; 755 756 begin 757 Par := Related_Nod; 758 while Nkind_In (Par, N_Access_Function_Definition, 759 N_Access_Definition) 760 loop 761 Par := Parent (Par); 762 end loop; 763 764 if Nkind (Par) = N_Function_Specification then 765 Anon_Scope := Scope (Defining_Entity (Par)); 766 end if; 767 end; 768 769 -- For the anonymous function result case, retrieve the scope of the 770 -- function specification's associated entity rather than using the 771 -- current scope. The current scope will be the function itself if the 772 -- formal part is currently being analyzed, but will be the parent scope 773 -- in the case of a parameterless function, and we always want to use 774 -- the function's parent scope. Finally, if the function is a child 775 -- unit, we must traverse the tree to retrieve the proper entity. 776 777 elsif Nkind (Related_Nod) = N_Function_Specification 778 and then Nkind (Parent (N)) /= N_Parameter_Specification 779 then 780 -- If the current scope is a protected type, the anonymous access 781 -- is associated with one of the protected operations, and must 782 -- be available in the scope that encloses the protected declaration. 783 -- Otherwise the type is in the scope enclosing the subprogram. 784 785 -- If the function has formals, The return type of a subprogram 786 -- declaration is analyzed in the scope of the subprogram (see 787 -- Process_Formals) and thus the protected type, if present, is 788 -- the scope of the current function scope. 789 790 if Ekind (Current_Scope) = E_Protected_Type then 791 Enclosing_Prot_Type := Current_Scope; 792 793 elsif Ekind (Current_Scope) = E_Function 794 and then Ekind (Scope (Current_Scope)) = E_Protected_Type 795 then 796 Enclosing_Prot_Type := Scope (Current_Scope); 797 end if; 798 799 if Present (Enclosing_Prot_Type) then 800 Anon_Scope := Scope (Enclosing_Prot_Type); 801 802 else 803 Anon_Scope := Scope (Defining_Entity (Related_Nod)); 804 end if; 805 806 -- For an access type definition, if the current scope is a child 807 -- unit it is the scope of the type. 808 809 elsif Is_Compilation_Unit (Current_Scope) then 810 Anon_Scope := Current_Scope; 811 812 -- For access formals, access components, and access discriminants, the 813 -- scope is that of the enclosing declaration, 814 815 else 816 Anon_Scope := Scope (Current_Scope); 817 end if; 818 819 Anon_Type := 820 Create_Itype 821 (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); 822 823 if All_Present (N) 824 and then Ada_Version >= Ada_2005 825 then 826 Error_Msg_N ("ALL is not permitted for anonymous access types", N); 827 end if; 828 829 -- Ada 2005 (AI-254): In case of anonymous access to subprograms call 830 -- the corresponding semantic routine 831 832 if Present (Access_To_Subprogram_Definition (N)) then 833 834 -- Compiler runtime units are compiled in Ada 2005 mode when building 835 -- the runtime library but must also be compilable in Ada 95 mode 836 -- (when bootstrapping the compiler). 837 838 Check_Compiler_Unit (N); 839 840 Access_Subprogram_Declaration 841 (T_Name => Anon_Type, 842 T_Def => Access_To_Subprogram_Definition (N)); 843 844 if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then 845 Set_Ekind 846 (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type); 847 else 848 Set_Ekind 849 (Anon_Type, E_Anonymous_Access_Subprogram_Type); 850 end if; 851 852 Set_Can_Use_Internal_Rep 853 (Anon_Type, not Always_Compatible_Rep_On_Target); 854 855 -- If the anonymous access is associated with a protected operation, 856 -- create a reference to it after the enclosing protected definition 857 -- because the itype will be used in the subsequent bodies. 858 859 if Ekind (Current_Scope) = E_Protected_Type then 860 Build_Itype_Reference (Anon_Type, Parent (Current_Scope)); 861 end if; 862 863 return Anon_Type; 864 end if; 865 866 Find_Type (Subtype_Mark (N)); 867 Desig_Type := Entity (Subtype_Mark (N)); 868 869 Set_Directly_Designated_Type (Anon_Type, Desig_Type); 870 Set_Etype (Anon_Type, Anon_Type); 871 872 -- Make sure the anonymous access type has size and alignment fields 873 -- set, as required by gigi. This is necessary in the case of the 874 -- Task_Body_Procedure. 875 876 if not Has_Private_Component (Desig_Type) then 877 Layout_Type (Anon_Type); 878 end if; 879 880 -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs 881 -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if 882 -- the null value is allowed. In Ada 95 the null value is never allowed. 883 884 if Ada_Version >= Ada_2005 then 885 Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N)); 886 else 887 Set_Can_Never_Be_Null (Anon_Type, True); 888 end if; 889 890 -- The anonymous access type is as public as the discriminated type or 891 -- subprogram that defines it. It is imported (for back-end purposes) 892 -- if the designated type is. 893 894 Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type))); 895 896 -- Ada 2005 (AI-231): Propagate the access-constant attribute 897 898 Set_Is_Access_Constant (Anon_Type, Constant_Present (N)); 899 900 -- The context is either a subprogram declaration, object declaration, 901 -- or an access discriminant, in a private or a full type declaration. 902 -- In the case of a subprogram, if the designated type is incomplete, 903 -- the operation will be a primitive operation of the full type, to be 904 -- updated subsequently. If the type is imported through a limited_with 905 -- clause, the subprogram is not a primitive operation of the type 906 -- (which is declared elsewhere in some other scope). 907 908 if Ekind (Desig_Type) = E_Incomplete_Type 909 and then not From_Limited_With (Desig_Type) 910 and then Is_Overloadable (Current_Scope) 911 then 912 Append_Elmt (Current_Scope, Private_Dependents (Desig_Type)); 913 Set_Has_Delayed_Freeze (Current_Scope); 914 end if; 915 916 -- Ada 2005: If the designated type is an interface that may contain 917 -- tasks, create a Master entity for the declaration. This must be done 918 -- before expansion of the full declaration, because the declaration may 919 -- include an expression that is an allocator, whose expansion needs the 920 -- proper Master for the created tasks. 921 922 if Nkind (Related_Nod) = N_Object_Declaration 923 and then Expander_Active 924 then 925 if Is_Interface (Desig_Type) 926 and then Is_Limited_Record (Desig_Type) 927 then 928 Build_Class_Wide_Master (Anon_Type); 929 930 -- Similarly, if the type is an anonymous access that designates 931 -- tasks, create a master entity for it in the current context. 932 933 elsif Has_Task (Desig_Type) 934 and then Comes_From_Source (Related_Nod) 935 then 936 Build_Master_Entity (Defining_Identifier (Related_Nod)); 937 Build_Master_Renaming (Anon_Type); 938 end if; 939 end if; 940 941 -- For a private component of a protected type, it is imperative that 942 -- the back-end elaborate the type immediately after the protected 943 -- declaration, because this type will be used in the declarations 944 -- created for the component within each protected body, so we must 945 -- create an itype reference for it now. 946 947 if Nkind (Parent (Related_Nod)) = N_Protected_Definition then 948 Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod))); 949 950 -- Similarly, if the access definition is the return result of a 951 -- function, create an itype reference for it because it will be used 952 -- within the function body. For a regular function that is not a 953 -- compilation unit, insert reference after the declaration. For a 954 -- protected operation, insert it after the enclosing protected type 955 -- declaration. In either case, do not create a reference for a type 956 -- obtained through a limited_with clause, because this would introduce 957 -- semantic dependencies. 958 959 -- Similarly, do not create a reference if the designated type is a 960 -- generic formal, because no use of it will reach the backend. 961 962 elsif Nkind (Related_Nod) = N_Function_Specification 963 and then not From_Limited_With (Desig_Type) 964 and then not Is_Generic_Type (Desig_Type) 965 then 966 if Present (Enclosing_Prot_Type) then 967 Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type)); 968 969 elsif Is_List_Member (Parent (Related_Nod)) 970 and then Nkind (Parent (N)) /= N_Parameter_Specification 971 then 972 Build_Itype_Reference (Anon_Type, Parent (Related_Nod)); 973 end if; 974 975 -- Finally, create an itype reference for an object declaration of an 976 -- anonymous access type. This is strictly necessary only for deferred 977 -- constants, but in any case will avoid out-of-scope problems in the 978 -- back-end. 979 980 elsif Nkind (Related_Nod) = N_Object_Declaration then 981 Build_Itype_Reference (Anon_Type, Related_Nod); 982 end if; 983 984 return Anon_Type; 985 end Access_Definition; 986 987 ----------------------------------- 988 -- Access_Subprogram_Declaration -- 989 ----------------------------------- 990 991 procedure Access_Subprogram_Declaration 992 (T_Name : Entity_Id; 993 T_Def : Node_Id) 994 is 995 procedure Check_For_Premature_Usage (Def : Node_Id); 996 -- Check that type T_Name is not used, directly or recursively, as a 997 -- parameter or a return type in Def. Def is either a subtype, an 998 -- access_definition, or an access_to_subprogram_definition. 999 1000 ------------------------------- 1001 -- Check_For_Premature_Usage -- 1002 ------------------------------- 1003 1004 procedure Check_For_Premature_Usage (Def : Node_Id) is 1005 Param : Node_Id; 1006 1007 begin 1008 -- Check for a subtype mark 1009 1010 if Nkind (Def) in N_Has_Etype then 1011 if Etype (Def) = T_Name then 1012 Error_Msg_N 1013 ("type& cannot be used before end of its declaration", Def); 1014 end if; 1015 1016 -- If this is not a subtype, then this is an access_definition 1017 1018 elsif Nkind (Def) = N_Access_Definition then 1019 if Present (Access_To_Subprogram_Definition (Def)) then 1020 Check_For_Premature_Usage 1021 (Access_To_Subprogram_Definition (Def)); 1022 else 1023 Check_For_Premature_Usage (Subtype_Mark (Def)); 1024 end if; 1025 1026 -- The only cases left are N_Access_Function_Definition and 1027 -- N_Access_Procedure_Definition. 1028 1029 else 1030 if Present (Parameter_Specifications (Def)) then 1031 Param := First (Parameter_Specifications (Def)); 1032 while Present (Param) loop 1033 Check_For_Premature_Usage (Parameter_Type (Param)); 1034 Param := Next (Param); 1035 end loop; 1036 end if; 1037 1038 if Nkind (Def) = N_Access_Function_Definition then 1039 Check_For_Premature_Usage (Result_Definition (Def)); 1040 end if; 1041 end if; 1042 end Check_For_Premature_Usage; 1043 1044 -- Local variables 1045 1046 Formals : constant List_Id := Parameter_Specifications (T_Def); 1047 Formal : Entity_Id; 1048 D_Ityp : Node_Id; 1049 Desig_Type : constant Entity_Id := 1050 Create_Itype (E_Subprogram_Type, Parent (T_Def)); 1051 1052 -- Start of processing for Access_Subprogram_Declaration 1053 1054 begin 1055 Check_SPARK_Restriction ("access type is not allowed", T_Def); 1056 1057 -- Associate the Itype node with the inner full-type declaration or 1058 -- subprogram spec or entry body. This is required to handle nested 1059 -- anonymous declarations. For example: 1060 1061 -- procedure P 1062 -- (X : access procedure 1063 -- (Y : access procedure 1064 -- (Z : access T))) 1065 1066 D_Ityp := Associated_Node_For_Itype (Desig_Type); 1067 while not (Nkind_In (D_Ityp, N_Full_Type_Declaration, 1068 N_Private_Type_Declaration, 1069 N_Private_Extension_Declaration, 1070 N_Procedure_Specification, 1071 N_Function_Specification, 1072 N_Entry_Body) 1073 1074 or else 1075 Nkind_In (D_Ityp, N_Object_Declaration, 1076 N_Object_Renaming_Declaration, 1077 N_Formal_Object_Declaration, 1078 N_Formal_Type_Declaration, 1079 N_Task_Type_Declaration, 1080 N_Protected_Type_Declaration)) 1081 loop 1082 D_Ityp := Parent (D_Ityp); 1083 pragma Assert (D_Ityp /= Empty); 1084 end loop; 1085 1086 Set_Associated_Node_For_Itype (Desig_Type, D_Ityp); 1087 1088 if Nkind_In (D_Ityp, N_Procedure_Specification, 1089 N_Function_Specification) 1090 then 1091 Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp))); 1092 1093 elsif Nkind_In (D_Ityp, N_Full_Type_Declaration, 1094 N_Object_Declaration, 1095 N_Object_Renaming_Declaration, 1096 N_Formal_Type_Declaration) 1097 then 1098 Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp))); 1099 end if; 1100 1101 if Nkind (T_Def) = N_Access_Function_Definition then 1102 if Nkind (Result_Definition (T_Def)) = N_Access_Definition then 1103 declare 1104 Acc : constant Node_Id := Result_Definition (T_Def); 1105 1106 begin 1107 if Present (Access_To_Subprogram_Definition (Acc)) 1108 and then 1109 Protected_Present (Access_To_Subprogram_Definition (Acc)) 1110 then 1111 Set_Etype 1112 (Desig_Type, 1113 Replace_Anonymous_Access_To_Protected_Subprogram 1114 (T_Def)); 1115 1116 else 1117 Set_Etype 1118 (Desig_Type, 1119 Access_Definition (T_Def, Result_Definition (T_Def))); 1120 end if; 1121 end; 1122 1123 else 1124 Analyze (Result_Definition (T_Def)); 1125 1126 declare 1127 Typ : constant Entity_Id := Entity (Result_Definition (T_Def)); 1128 1129 begin 1130 -- If a null exclusion is imposed on the result type, then 1131 -- create a null-excluding itype (an access subtype) and use 1132 -- it as the function's Etype. 1133 1134 if Is_Access_Type (Typ) 1135 and then Null_Exclusion_In_Return_Present (T_Def) 1136 then 1137 Set_Etype (Desig_Type, 1138 Create_Null_Excluding_Itype 1139 (T => Typ, 1140 Related_Nod => T_Def, 1141 Scope_Id => Current_Scope)); 1142 1143 else 1144 if From_Limited_With (Typ) then 1145 1146 -- AI05-151: Incomplete types are allowed in all basic 1147 -- declarations, including access to subprograms. 1148 1149 if Ada_Version >= Ada_2012 then 1150 null; 1151 1152 else 1153 Error_Msg_NE 1154 ("illegal use of incomplete type&", 1155 Result_Definition (T_Def), Typ); 1156 end if; 1157 1158 elsif Ekind (Current_Scope) = E_Package 1159 and then In_Private_Part (Current_Scope) 1160 then 1161 if Ekind (Typ) = E_Incomplete_Type then 1162 Append_Elmt (Desig_Type, Private_Dependents (Typ)); 1163 1164 elsif Is_Class_Wide_Type (Typ) 1165 and then Ekind (Etype (Typ)) = E_Incomplete_Type 1166 then 1167 Append_Elmt 1168 (Desig_Type, Private_Dependents (Etype (Typ))); 1169 end if; 1170 end if; 1171 1172 Set_Etype (Desig_Type, Typ); 1173 end if; 1174 end; 1175 end if; 1176 1177 if not (Is_Type (Etype (Desig_Type))) then 1178 Error_Msg_N 1179 ("expect type in function specification", 1180 Result_Definition (T_Def)); 1181 end if; 1182 1183 else 1184 Set_Etype (Desig_Type, Standard_Void_Type); 1185 end if; 1186 1187 if Present (Formals) then 1188 Push_Scope (Desig_Type); 1189 1190 -- A bit of a kludge here. These kludges will be removed when Itypes 1191 -- have proper parent pointers to their declarations??? 1192 1193 -- Kludge 1) Link defining_identifier of formals. Required by 1194 -- First_Formal to provide its functionality. 1195 1196 declare 1197 F : Node_Id; 1198 1199 begin 1200 F := First (Formals); 1201 1202 -- In ASIS mode, the access_to_subprogram may be analyzed twice, 1203 -- when it is part of an unconstrained type and subtype expansion 1204 -- is disabled. To avoid back-end problems with shared profiles, 1205 -- use previous subprogram type as the designated type, and then 1206 -- remove scope added above. 1207 1208 if ASIS_Mode 1209 and then Present (Scope (Defining_Identifier (F))) 1210 then 1211 Set_Etype (T_Name, T_Name); 1212 Init_Size_Align (T_Name); 1213 Set_Directly_Designated_Type (T_Name, 1214 Scope (Defining_Identifier (F))); 1215 End_Scope; 1216 return; 1217 end if; 1218 1219 while Present (F) loop 1220 if No (Parent (Defining_Identifier (F))) then 1221 Set_Parent (Defining_Identifier (F), F); 1222 end if; 1223 1224 Next (F); 1225 end loop; 1226 end; 1227 1228 Process_Formals (Formals, Parent (T_Def)); 1229 1230 -- Kludge 2) End_Scope requires that the parent pointer be set to 1231 -- something reasonable, but Itypes don't have parent pointers. So 1232 -- we set it and then unset it ??? 1233 1234 Set_Parent (Desig_Type, T_Name); 1235 End_Scope; 1236 Set_Parent (Desig_Type, Empty); 1237 end if; 1238 1239 -- Check for premature usage of the type being defined 1240 1241 Check_For_Premature_Usage (T_Def); 1242 1243 -- The return type and/or any parameter type may be incomplete. Mark the 1244 -- subprogram_type as depending on the incomplete type, so that it can 1245 -- be updated when the full type declaration is seen. This only applies 1246 -- to incomplete types declared in some enclosing scope, not to limited 1247 -- views from other packages. 1248 1249 -- Prior to Ada 2012, access to functions can only have in_parameters. 1250 1251 if Present (Formals) then 1252 Formal := First_Formal (Desig_Type); 1253 while Present (Formal) loop 1254 if Ekind (Formal) /= E_In_Parameter 1255 and then Nkind (T_Def) = N_Access_Function_Definition 1256 and then Ada_Version < Ada_2012 1257 then 1258 Error_Msg_N ("functions can only have IN parameters", Formal); 1259 end if; 1260 1261 if Ekind (Etype (Formal)) = E_Incomplete_Type 1262 and then In_Open_Scopes (Scope (Etype (Formal))) 1263 then 1264 Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal))); 1265 Set_Has_Delayed_Freeze (Desig_Type); 1266 end if; 1267 1268 Next_Formal (Formal); 1269 end loop; 1270 end if; 1271 1272 -- Check whether an indirect call without actuals may be possible. This 1273 -- is used when resolving calls whose result is then indexed. 1274 1275 May_Need_Actuals (Desig_Type); 1276 1277 -- If the return type is incomplete, this is legal as long as the type 1278 -- is declared in the current scope and will be completed in it (rather 1279 -- than being part of limited view). 1280 1281 if Ekind (Etype (Desig_Type)) = E_Incomplete_Type 1282 and then not Has_Delayed_Freeze (Desig_Type) 1283 and then In_Open_Scopes (Scope (Etype (Desig_Type))) 1284 then 1285 Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type))); 1286 Set_Has_Delayed_Freeze (Desig_Type); 1287 end if; 1288 1289 Check_Delayed_Subprogram (Desig_Type); 1290 1291 if Protected_Present (T_Def) then 1292 Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type); 1293 Set_Convention (Desig_Type, Convention_Protected); 1294 else 1295 Set_Ekind (T_Name, E_Access_Subprogram_Type); 1296 end if; 1297 1298 Set_Can_Use_Internal_Rep (T_Name, not Always_Compatible_Rep_On_Target); 1299 1300 Set_Etype (T_Name, T_Name); 1301 Init_Size_Align (T_Name); 1302 Set_Directly_Designated_Type (T_Name, Desig_Type); 1303 1304 Generate_Reference_To_Formals (T_Name); 1305 1306 -- Ada 2005 (AI-231): Propagate the null-excluding attribute 1307 1308 Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def)); 1309 1310 Check_Restriction (No_Access_Subprograms, T_Def); 1311 end Access_Subprogram_Declaration; 1312 1313 ---------------------------- 1314 -- Access_Type_Declaration -- 1315 ---------------------------- 1316 1317 procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is 1318 P : constant Node_Id := Parent (Def); 1319 S : constant Node_Id := Subtype_Indication (Def); 1320 1321 Full_Desig : Entity_Id; 1322 1323 begin 1324 Check_SPARK_Restriction ("access type is not allowed", Def); 1325 1326 -- Check for permissible use of incomplete type 1327 1328 if Nkind (S) /= N_Subtype_Indication then 1329 Analyze (S); 1330 1331 if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then 1332 Set_Directly_Designated_Type (T, Entity (S)); 1333 else 1334 Set_Directly_Designated_Type (T, 1335 Process_Subtype (S, P, T, 'P')); 1336 end if; 1337 1338 else 1339 Set_Directly_Designated_Type (T, 1340 Process_Subtype (S, P, T, 'P')); 1341 end if; 1342 1343 if All_Present (Def) or Constant_Present (Def) then 1344 Set_Ekind (T, E_General_Access_Type); 1345 else 1346 Set_Ekind (T, E_Access_Type); 1347 end if; 1348 1349 Full_Desig := Designated_Type (T); 1350 1351 if Base_Type (Full_Desig) = T then 1352 Error_Msg_N ("access type cannot designate itself", S); 1353 1354 -- In Ada 2005, the type may have a limited view through some unit in 1355 -- its own context, allowing the following circularity that cannot be 1356 -- detected earlier 1357 1358 elsif Is_Class_Wide_Type (Full_Desig) 1359 and then Etype (Full_Desig) = T 1360 then 1361 Error_Msg_N 1362 ("access type cannot designate its own classwide type", S); 1363 1364 -- Clean up indication of tagged status to prevent cascaded errors 1365 1366 Set_Is_Tagged_Type (T, False); 1367 end if; 1368 1369 Set_Etype (T, T); 1370 1371 -- If the type has appeared already in a with_type clause, it is frozen 1372 -- and the pointer size is already set. Else, initialize. 1373 1374 if not From_Limited_With (T) then 1375 Init_Size_Align (T); 1376 end if; 1377 1378 -- Note that Has_Task is always false, since the access type itself 1379 -- is not a task type. See Einfo for more description on this point. 1380 -- Exactly the same consideration applies to Has_Controlled_Component. 1381 1382 Set_Has_Task (T, False); 1383 Set_Has_Controlled_Component (T, False); 1384 1385 -- Initialize field Finalization_Master explicitly to Empty, to avoid 1386 -- problems where an incomplete view of this entity has been previously 1387 -- established by a limited with and an overlaid version of this field 1388 -- (Stored_Constraint) was initialized for the incomplete view. 1389 1390 -- This reset is performed in most cases except where the access type 1391 -- has been created for the purposes of allocating or deallocating a 1392 -- build-in-place object. Such access types have explicitly set pools 1393 -- and finalization masters. 1394 1395 if No (Associated_Storage_Pool (T)) then 1396 Set_Finalization_Master (T, Empty); 1397 end if; 1398 1399 -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant 1400 -- attributes 1401 1402 Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def)); 1403 Set_Is_Access_Constant (T, Constant_Present (Def)); 1404 end Access_Type_Declaration; 1405 1406 ---------------------------------- 1407 -- Add_Interface_Tag_Components -- 1408 ---------------------------------- 1409 1410 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is 1411 Loc : constant Source_Ptr := Sloc (N); 1412 L : List_Id; 1413 Last_Tag : Node_Id; 1414 1415 procedure Add_Tag (Iface : Entity_Id); 1416 -- Add tag for one of the progenitor interfaces 1417 1418 ------------- 1419 -- Add_Tag -- 1420 ------------- 1421 1422 procedure Add_Tag (Iface : Entity_Id) is 1423 Decl : Node_Id; 1424 Def : Node_Id; 1425 Tag : Entity_Id; 1426 Offset : Entity_Id; 1427 1428 begin 1429 pragma Assert (Is_Tagged_Type (Iface) and then Is_Interface (Iface)); 1430 1431 -- This is a reasonable place to propagate predicates 1432 1433 if Has_Predicates (Iface) then 1434 Set_Has_Predicates (Typ); 1435 end if; 1436 1437 Def := 1438 Make_Component_Definition (Loc, 1439 Aliased_Present => True, 1440 Subtype_Indication => 1441 New_Occurrence_Of (RTE (RE_Interface_Tag), Loc)); 1442 1443 Tag := Make_Temporary (Loc, 'V'); 1444 1445 Decl := 1446 Make_Component_Declaration (Loc, 1447 Defining_Identifier => Tag, 1448 Component_Definition => Def); 1449 1450 Analyze_Component_Declaration (Decl); 1451 1452 Set_Analyzed (Decl); 1453 Set_Ekind (Tag, E_Component); 1454 Set_Is_Tag (Tag); 1455 Set_Is_Aliased (Tag); 1456 Set_Related_Type (Tag, Iface); 1457 Init_Component_Location (Tag); 1458 1459 pragma Assert (Is_Frozen (Iface)); 1460 1461 Set_DT_Entry_Count (Tag, 1462 DT_Entry_Count (First_Entity (Iface))); 1463 1464 if No (Last_Tag) then 1465 Prepend (Decl, L); 1466 else 1467 Insert_After (Last_Tag, Decl); 1468 end if; 1469 1470 Last_Tag := Decl; 1471 1472 -- If the ancestor has discriminants we need to give special support 1473 -- to store the offset_to_top value of the secondary dispatch tables. 1474 -- For this purpose we add a supplementary component just after the 1475 -- field that contains the tag associated with each secondary DT. 1476 1477 if Typ /= Etype (Typ) and then Has_Discriminants (Etype (Typ)) then 1478 Def := 1479 Make_Component_Definition (Loc, 1480 Subtype_Indication => 1481 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); 1482 1483 Offset := Make_Temporary (Loc, 'V'); 1484 1485 Decl := 1486 Make_Component_Declaration (Loc, 1487 Defining_Identifier => Offset, 1488 Component_Definition => Def); 1489 1490 Analyze_Component_Declaration (Decl); 1491 1492 Set_Analyzed (Decl); 1493 Set_Ekind (Offset, E_Component); 1494 Set_Is_Aliased (Offset); 1495 Set_Related_Type (Offset, Iface); 1496 Init_Component_Location (Offset); 1497 Insert_After (Last_Tag, Decl); 1498 Last_Tag := Decl; 1499 end if; 1500 end Add_Tag; 1501 1502 -- Local variables 1503 1504 Elmt : Elmt_Id; 1505 Ext : Node_Id; 1506 Comp : Node_Id; 1507 1508 -- Start of processing for Add_Interface_Tag_Components 1509 1510 begin 1511 if not RTE_Available (RE_Interface_Tag) then 1512 Error_Msg 1513 ("(Ada 2005) interface types not supported by this run-time!", 1514 Sloc (N)); 1515 return; 1516 end if; 1517 1518 if Ekind (Typ) /= E_Record_Type 1519 or else (Is_Concurrent_Record_Type (Typ) 1520 and then Is_Empty_List (Abstract_Interface_List (Typ))) 1521 or else (not Is_Concurrent_Record_Type (Typ) 1522 and then No (Interfaces (Typ)) 1523 and then Is_Empty_Elmt_List (Interfaces (Typ))) 1524 then 1525 return; 1526 end if; 1527 1528 -- Find the current last tag 1529 1530 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 1531 Ext := Record_Extension_Part (Type_Definition (N)); 1532 else 1533 pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition); 1534 Ext := Type_Definition (N); 1535 end if; 1536 1537 Last_Tag := Empty; 1538 1539 if not (Present (Component_List (Ext))) then 1540 Set_Null_Present (Ext, False); 1541 L := New_List; 1542 Set_Component_List (Ext, 1543 Make_Component_List (Loc, 1544 Component_Items => L, 1545 Null_Present => False)); 1546 else 1547 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 1548 L := Component_Items 1549 (Component_List 1550 (Record_Extension_Part 1551 (Type_Definition (N)))); 1552 else 1553 L := Component_Items 1554 (Component_List 1555 (Type_Definition (N))); 1556 end if; 1557 1558 -- Find the last tag component 1559 1560 Comp := First (L); 1561 while Present (Comp) loop 1562 if Nkind (Comp) = N_Component_Declaration 1563 and then Is_Tag (Defining_Identifier (Comp)) 1564 then 1565 Last_Tag := Comp; 1566 end if; 1567 1568 Next (Comp); 1569 end loop; 1570 end if; 1571 1572 -- At this point L references the list of components and Last_Tag 1573 -- references the current last tag (if any). Now we add the tag 1574 -- corresponding with all the interfaces that are not implemented 1575 -- by the parent. 1576 1577 if Present (Interfaces (Typ)) then 1578 Elmt := First_Elmt (Interfaces (Typ)); 1579 while Present (Elmt) loop 1580 Add_Tag (Node (Elmt)); 1581 Next_Elmt (Elmt); 1582 end loop; 1583 end if; 1584 end Add_Interface_Tag_Components; 1585 1586 ------------------------------------- 1587 -- Add_Internal_Interface_Entities -- 1588 ------------------------------------- 1589 1590 procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is 1591 Elmt : Elmt_Id; 1592 Iface : Entity_Id; 1593 Iface_Elmt : Elmt_Id; 1594 Iface_Prim : Entity_Id; 1595 Ifaces_List : Elist_Id; 1596 New_Subp : Entity_Id := Empty; 1597 Prim : Entity_Id; 1598 Restore_Scope : Boolean := False; 1599 1600 begin 1601 pragma Assert (Ada_Version >= Ada_2005 1602 and then Is_Record_Type (Tagged_Type) 1603 and then Is_Tagged_Type (Tagged_Type) 1604 and then Has_Interfaces (Tagged_Type) 1605 and then not Is_Interface (Tagged_Type)); 1606 1607 -- Ensure that the internal entities are added to the scope of the type 1608 1609 if Scope (Tagged_Type) /= Current_Scope then 1610 Push_Scope (Scope (Tagged_Type)); 1611 Restore_Scope := True; 1612 end if; 1613 1614 Collect_Interfaces (Tagged_Type, Ifaces_List); 1615 1616 Iface_Elmt := First_Elmt (Ifaces_List); 1617 while Present (Iface_Elmt) loop 1618 Iface := Node (Iface_Elmt); 1619 1620 -- Originally we excluded here from this processing interfaces that 1621 -- are parents of Tagged_Type because their primitives are located 1622 -- in the primary dispatch table (and hence no auxiliary internal 1623 -- entities are required to handle secondary dispatch tables in such 1624 -- case). However, these auxiliary entities are also required to 1625 -- handle derivations of interfaces in formals of generics (see 1626 -- Derive_Subprograms). 1627 1628 Elmt := First_Elmt (Primitive_Operations (Iface)); 1629 while Present (Elmt) loop 1630 Iface_Prim := Node (Elmt); 1631 1632 if not Is_Predefined_Dispatching_Operation (Iface_Prim) then 1633 Prim := 1634 Find_Primitive_Covering_Interface 1635 (Tagged_Type => Tagged_Type, 1636 Iface_Prim => Iface_Prim); 1637 1638 if No (Prim) and then Serious_Errors_Detected > 0 then 1639 goto Continue; 1640 end if; 1641 1642 pragma Assert (Present (Prim)); 1643 1644 -- Ada 2012 (AI05-0197): If the name of the covering primitive 1645 -- differs from the name of the interface primitive then it is 1646 -- a private primitive inherited from a parent type. In such 1647 -- case, given that Tagged_Type covers the interface, the 1648 -- inherited private primitive becomes visible. For such 1649 -- purpose we add a new entity that renames the inherited 1650 -- private primitive. 1651 1652 if Chars (Prim) /= Chars (Iface_Prim) then 1653 pragma Assert (Has_Suffix (Prim, 'P')); 1654 Derive_Subprogram 1655 (New_Subp => New_Subp, 1656 Parent_Subp => Iface_Prim, 1657 Derived_Type => Tagged_Type, 1658 Parent_Type => Iface); 1659 Set_Alias (New_Subp, Prim); 1660 Set_Is_Abstract_Subprogram 1661 (New_Subp, Is_Abstract_Subprogram (Prim)); 1662 end if; 1663 1664 Derive_Subprogram 1665 (New_Subp => New_Subp, 1666 Parent_Subp => Iface_Prim, 1667 Derived_Type => Tagged_Type, 1668 Parent_Type => Iface); 1669 1670 -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp 1671 -- associated with interface types. These entities are 1672 -- only registered in the list of primitives of its 1673 -- corresponding tagged type because they are only used 1674 -- to fill the contents of the secondary dispatch tables. 1675 -- Therefore they are removed from the homonym chains. 1676 1677 Set_Is_Hidden (New_Subp); 1678 Set_Is_Internal (New_Subp); 1679 Set_Alias (New_Subp, Prim); 1680 Set_Is_Abstract_Subprogram 1681 (New_Subp, Is_Abstract_Subprogram (Prim)); 1682 Set_Interface_Alias (New_Subp, Iface_Prim); 1683 1684 -- If the returned type is an interface then propagate it to 1685 -- the returned type. Needed by the thunk to generate the code 1686 -- which displaces "this" to reference the corresponding 1687 -- secondary dispatch table in the returned object. 1688 1689 if Is_Interface (Etype (Iface_Prim)) then 1690 Set_Etype (New_Subp, Etype (Iface_Prim)); 1691 end if; 1692 1693 -- Internal entities associated with interface types are 1694 -- only registered in the list of primitives of the tagged 1695 -- type. They are only used to fill the contents of the 1696 -- secondary dispatch tables. Therefore they are not needed 1697 -- in the homonym chains. 1698 1699 Remove_Homonym (New_Subp); 1700 1701 -- Hidden entities associated with interfaces must have set 1702 -- the Has_Delay_Freeze attribute to ensure that, in case of 1703 -- locally defined tagged types (or compiling with static 1704 -- dispatch tables generation disabled) the corresponding 1705 -- entry of the secondary dispatch table is filled when 1706 -- such an entity is frozen. 1707 1708 Set_Has_Delayed_Freeze (New_Subp); 1709 end if; 1710 1711 <<Continue>> 1712 Next_Elmt (Elmt); 1713 end loop; 1714 1715 Next_Elmt (Iface_Elmt); 1716 end loop; 1717 1718 if Restore_Scope then 1719 Pop_Scope; 1720 end if; 1721 end Add_Internal_Interface_Entities; 1722 1723 ----------------------------------- 1724 -- Analyze_Component_Declaration -- 1725 ----------------------------------- 1726 1727 procedure Analyze_Component_Declaration (N : Node_Id) is 1728 Id : constant Entity_Id := Defining_Identifier (N); 1729 E : constant Node_Id := Expression (N); 1730 Typ : constant Node_Id := 1731 Subtype_Indication (Component_Definition (N)); 1732 T : Entity_Id; 1733 P : Entity_Id; 1734 1735 function Contains_POC (Constr : Node_Id) return Boolean; 1736 -- Determines whether a constraint uses the discriminant of a record 1737 -- type thus becoming a per-object constraint (POC). 1738 1739 function Is_Known_Limited (Typ : Entity_Id) return Boolean; 1740 -- Typ is the type of the current component, check whether this type is 1741 -- a limited type. Used to validate declaration against that of 1742 -- enclosing record. 1743 1744 ------------------ 1745 -- Contains_POC -- 1746 ------------------ 1747 1748 function Contains_POC (Constr : Node_Id) return Boolean is 1749 begin 1750 -- Prevent cascaded errors 1751 1752 if Error_Posted (Constr) then 1753 return False; 1754 end if; 1755 1756 case Nkind (Constr) is 1757 when N_Attribute_Reference => 1758 return 1759 Attribute_Name (Constr) = Name_Access 1760 and then Prefix (Constr) = Scope (Entity (Prefix (Constr))); 1761 1762 when N_Discriminant_Association => 1763 return Denotes_Discriminant (Expression (Constr)); 1764 1765 when N_Identifier => 1766 return Denotes_Discriminant (Constr); 1767 1768 when N_Index_Or_Discriminant_Constraint => 1769 declare 1770 IDC : Node_Id; 1771 1772 begin 1773 IDC := First (Constraints (Constr)); 1774 while Present (IDC) loop 1775 1776 -- One per-object constraint is sufficient 1777 1778 if Contains_POC (IDC) then 1779 return True; 1780 end if; 1781 1782 Next (IDC); 1783 end loop; 1784 1785 return False; 1786 end; 1787 1788 when N_Range => 1789 return Denotes_Discriminant (Low_Bound (Constr)) 1790 or else 1791 Denotes_Discriminant (High_Bound (Constr)); 1792 1793 when N_Range_Constraint => 1794 return Denotes_Discriminant (Range_Expression (Constr)); 1795 1796 when others => 1797 return False; 1798 1799 end case; 1800 end Contains_POC; 1801 1802 ---------------------- 1803 -- Is_Known_Limited -- 1804 ---------------------- 1805 1806 function Is_Known_Limited (Typ : Entity_Id) return Boolean is 1807 P : constant Entity_Id := Etype (Typ); 1808 R : constant Entity_Id := Root_Type (Typ); 1809 1810 begin 1811 if Is_Limited_Record (Typ) then 1812 return True; 1813 1814 -- If the root type is limited (and not a limited interface) 1815 -- so is the current type 1816 1817 elsif Is_Limited_Record (R) 1818 and then (not Is_Interface (R) or else not Is_Limited_Interface (R)) 1819 then 1820 return True; 1821 1822 -- Else the type may have a limited interface progenitor, but a 1823 -- limited record parent. 1824 1825 elsif R /= P and then Is_Limited_Record (P) then 1826 return True; 1827 1828 else 1829 return False; 1830 end if; 1831 end Is_Known_Limited; 1832 1833 -- Start of processing for Analyze_Component_Declaration 1834 1835 begin 1836 Generate_Definition (Id); 1837 Enter_Name (Id); 1838 1839 if Present (Typ) then 1840 T := Find_Type_Of_Object 1841 (Subtype_Indication (Component_Definition (N)), N); 1842 1843 if not Nkind_In (Typ, N_Identifier, N_Expanded_Name) then 1844 Check_SPARK_Restriction ("subtype mark required", Typ); 1845 end if; 1846 1847 -- Ada 2005 (AI-230): Access Definition case 1848 1849 else 1850 pragma Assert (Present 1851 (Access_Definition (Component_Definition (N)))); 1852 1853 T := Access_Definition 1854 (Related_Nod => N, 1855 N => Access_Definition (Component_Definition (N))); 1856 Set_Is_Local_Anonymous_Access (T); 1857 1858 -- Ada 2005 (AI-254) 1859 1860 if Present (Access_To_Subprogram_Definition 1861 (Access_Definition (Component_Definition (N)))) 1862 and then Protected_Present (Access_To_Subprogram_Definition 1863 (Access_Definition 1864 (Component_Definition (N)))) 1865 then 1866 T := Replace_Anonymous_Access_To_Protected_Subprogram (N); 1867 end if; 1868 end if; 1869 1870 -- If the subtype is a constrained subtype of the enclosing record, 1871 -- (which must have a partial view) the back-end does not properly 1872 -- handle the recursion. Rewrite the component declaration with an 1873 -- explicit subtype indication, which is acceptable to Gigi. We can copy 1874 -- the tree directly because side effects have already been removed from 1875 -- discriminant constraints. 1876 1877 if Ekind (T) = E_Access_Subtype 1878 and then Is_Entity_Name (Subtype_Indication (Component_Definition (N))) 1879 and then Comes_From_Source (T) 1880 and then Nkind (Parent (T)) = N_Subtype_Declaration 1881 and then Etype (Directly_Designated_Type (T)) = Current_Scope 1882 then 1883 Rewrite 1884 (Subtype_Indication (Component_Definition (N)), 1885 New_Copy_Tree (Subtype_Indication (Parent (T)))); 1886 T := Find_Type_Of_Object 1887 (Subtype_Indication (Component_Definition (N)), N); 1888 end if; 1889 1890 -- If the component declaration includes a default expression, then we 1891 -- check that the component is not of a limited type (RM 3.7(5)), 1892 -- and do the special preanalysis of the expression (see section on 1893 -- "Handling of Default and Per-Object Expressions" in the spec of 1894 -- package Sem). 1895 1896 if Present (E) then 1897 Check_SPARK_Restriction ("default expression is not allowed", E); 1898 Preanalyze_Spec_Expression (E, T); 1899 Check_Initialization (T, E); 1900 1901 if Ada_Version >= Ada_2005 1902 and then Ekind (T) = E_Anonymous_Access_Type 1903 and then Etype (E) /= Any_Type 1904 then 1905 -- Check RM 3.9.2(9): "if the expected type for an expression is 1906 -- an anonymous access-to-specific tagged type, then the object 1907 -- designated by the expression shall not be dynamically tagged 1908 -- unless it is a controlling operand in a call on a dispatching 1909 -- operation" 1910 1911 if Is_Tagged_Type (Directly_Designated_Type (T)) 1912 and then 1913 Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type 1914 and then 1915 Ekind (Directly_Designated_Type (Etype (E))) = 1916 E_Class_Wide_Type 1917 then 1918 Error_Msg_N 1919 ("access to specific tagged type required (RM 3.9.2(9))", E); 1920 end if; 1921 1922 -- (Ada 2005: AI-230): Accessibility check for anonymous 1923 -- components 1924 1925 if Type_Access_Level (Etype (E)) > 1926 Deepest_Type_Access_Level (T) 1927 then 1928 Error_Msg_N 1929 ("expression has deeper access level than component " & 1930 "(RM 3.10.2 (12.2))", E); 1931 end if; 1932 1933 -- The initialization expression is a reference to an access 1934 -- discriminant. The type of the discriminant is always deeper 1935 -- than any access type. 1936 1937 if Ekind (Etype (E)) = E_Anonymous_Access_Type 1938 and then Is_Entity_Name (E) 1939 and then Ekind (Entity (E)) = E_In_Parameter 1940 and then Present (Discriminal_Link (Entity (E))) 1941 then 1942 Error_Msg_N 1943 ("discriminant has deeper accessibility level than target", 1944 E); 1945 end if; 1946 end if; 1947 end if; 1948 1949 -- The parent type may be a private view with unknown discriminants, 1950 -- and thus unconstrained. Regular components must be constrained. 1951 1952 if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then 1953 if Is_Class_Wide_Type (T) then 1954 Error_Msg_N 1955 ("class-wide subtype with unknown discriminants" & 1956 " in component declaration", 1957 Subtype_Indication (Component_Definition (N))); 1958 else 1959 Error_Msg_N 1960 ("unconstrained subtype in component declaration", 1961 Subtype_Indication (Component_Definition (N))); 1962 end if; 1963 1964 -- Components cannot be abstract, except for the special case of 1965 -- the _Parent field (case of extending an abstract tagged type) 1966 1967 elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then 1968 Error_Msg_N ("type of a component cannot be abstract", N); 1969 end if; 1970 1971 Set_Etype (Id, T); 1972 Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N))); 1973 1974 -- The component declaration may have a per-object constraint, set 1975 -- the appropriate flag in the defining identifier of the subtype. 1976 1977 if Present (Subtype_Indication (Component_Definition (N))) then 1978 declare 1979 Sindic : constant Node_Id := 1980 Subtype_Indication (Component_Definition (N)); 1981 begin 1982 if Nkind (Sindic) = N_Subtype_Indication 1983 and then Present (Constraint (Sindic)) 1984 and then Contains_POC (Constraint (Sindic)) 1985 then 1986 Set_Has_Per_Object_Constraint (Id); 1987 end if; 1988 end; 1989 end if; 1990 1991 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry 1992 -- out some static checks. 1993 1994 if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then 1995 Null_Exclusion_Static_Checks (N); 1996 end if; 1997 1998 -- If this component is private (or depends on a private type), flag the 1999 -- record type to indicate that some operations are not available. 2000 2001 P := Private_Component (T); 2002 2003 if Present (P) then 2004 2005 -- Check for circular definitions 2006 2007 if P = Any_Type then 2008 Set_Etype (Id, Any_Type); 2009 2010 -- There is a gap in the visibility of operations only if the 2011 -- component type is not defined in the scope of the record type. 2012 2013 elsif Scope (P) = Scope (Current_Scope) then 2014 null; 2015 2016 elsif Is_Limited_Type (P) then 2017 Set_Is_Limited_Composite (Current_Scope); 2018 2019 else 2020 Set_Is_Private_Composite (Current_Scope); 2021 end if; 2022 end if; 2023 2024 if P /= Any_Type 2025 and then Is_Limited_Type (T) 2026 and then Chars (Id) /= Name_uParent 2027 and then Is_Tagged_Type (Current_Scope) 2028 then 2029 if Is_Derived_Type (Current_Scope) 2030 and then not Is_Known_Limited (Current_Scope) 2031 then 2032 Error_Msg_N 2033 ("extension of nonlimited type cannot have limited components", 2034 N); 2035 2036 if Is_Interface (Root_Type (Current_Scope)) then 2037 Error_Msg_N 2038 ("\limitedness is not inherited from limited interface", N); 2039 Error_Msg_N ("\add LIMITED to type indication", N); 2040 end if; 2041 2042 Explain_Limited_Type (T, N); 2043 Set_Etype (Id, Any_Type); 2044 Set_Is_Limited_Composite (Current_Scope, False); 2045 2046 elsif not Is_Derived_Type (Current_Scope) 2047 and then not Is_Limited_Record (Current_Scope) 2048 and then not Is_Concurrent_Type (Current_Scope) 2049 then 2050 Error_Msg_N 2051 ("nonlimited tagged type cannot have limited components", N); 2052 Explain_Limited_Type (T, N); 2053 Set_Etype (Id, Any_Type); 2054 Set_Is_Limited_Composite (Current_Scope, False); 2055 end if; 2056 end if; 2057 2058 Set_Original_Record_Component (Id, Id); 2059 2060 if Has_Aspects (N) then 2061 Analyze_Aspect_Specifications (N, Id); 2062 end if; 2063 2064 Analyze_Dimension (N); 2065 end Analyze_Component_Declaration; 2066 2067 -------------------------- 2068 -- Analyze_Declarations -- 2069 -------------------------- 2070 2071 procedure Analyze_Declarations (L : List_Id) is 2072 Decl : Node_Id; 2073 2074 procedure Adjust_Decl; 2075 -- Adjust Decl not to include implicit label declarations, since these 2076 -- have strange Sloc values that result in elaboration check problems. 2077 -- (They have the sloc of the label as found in the source, and that 2078 -- is ahead of the current declarative part). 2079 2080 procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id); 2081 -- Determine whether Body_Decl denotes the body of a late controlled 2082 -- primitive (either Initialize, Adjust or Finalize). If this is the 2083 -- case, add a proper spec if the body lacks one. The spec is inserted 2084 -- before Body_Decl and immedately analyzed. 2085 2086 procedure Remove_Visible_Refinements (Spec_Id : Entity_Id); 2087 -- Spec_Id is the entity of a package that may define abstract states. 2088 -- If the states have visible refinement, remove the visibility of each 2089 -- constituent at the end of the package body declarations. 2090 2091 ----------------- 2092 -- Adjust_Decl -- 2093 ----------------- 2094 2095 procedure Adjust_Decl is 2096 begin 2097 while Present (Prev (Decl)) 2098 and then Nkind (Decl) = N_Implicit_Label_Declaration 2099 loop 2100 Prev (Decl); 2101 end loop; 2102 end Adjust_Decl; 2103 2104 -------------------------------------- 2105 -- Handle_Late_Controlled_Primitive -- 2106 -------------------------------------- 2107 2108 procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id) is 2109 Body_Spec : constant Node_Id := Specification (Body_Decl); 2110 Body_Id : constant Entity_Id := Defining_Entity (Body_Spec); 2111 Loc : constant Source_Ptr := Sloc (Body_Id); 2112 Params : constant List_Id := 2113 Parameter_Specifications (Body_Spec); 2114 Spec : Node_Id; 2115 Spec_Id : Entity_Id; 2116 2117 Dummy : Entity_Id; 2118 pragma Unreferenced (Dummy); 2119 -- A dummy variable used to capture the unused result of subprogram 2120 -- spec analysis. 2121 2122 begin 2123 -- Consider only procedure bodies whose name matches one of the three 2124 -- controlled primitives. 2125 2126 if Nkind (Body_Spec) /= N_Procedure_Specification 2127 or else not Nam_In (Chars (Body_Id), Name_Adjust, 2128 Name_Finalize, 2129 Name_Initialize) 2130 then 2131 return; 2132 2133 -- A controlled primitive must have exactly one formal 2134 2135 elsif List_Length (Params) /= 1 then 2136 return; 2137 end if; 2138 2139 Dummy := Analyze_Subprogram_Specification (Body_Spec); 2140 2141 -- The type of the formal must be derived from [Limited_]Controlled 2142 2143 if not Is_Controlled (Etype (Defining_Entity (First (Params)))) then 2144 return; 2145 end if; 2146 2147 Spec_Id := Find_Corresponding_Spec (Body_Decl, Post_Error => False); 2148 2149 -- The body has a matching spec, therefore it cannot be a late 2150 -- primitive. 2151 2152 if Present (Spec_Id) then 2153 return; 2154 end if; 2155 2156 -- At this point the body is known to be a late controlled primitive. 2157 -- Generate a matching spec and insert it before the body. Note the 2158 -- use of Copy_Separate_Tree - we want an entirely separate semantic 2159 -- tree in this case. 2160 2161 Spec := Copy_Separate_Tree (Body_Spec); 2162 2163 -- Ensure that the subprogram declaration does not inherit the null 2164 -- indicator from the body as we now have a proper spec/body pair. 2165 2166 Set_Null_Present (Spec, False); 2167 2168 Insert_Before_And_Analyze (Body_Decl, 2169 Make_Subprogram_Declaration (Loc, 2170 Specification => Spec)); 2171 end Handle_Late_Controlled_Primitive; 2172 2173 -------------------------------- 2174 -- Remove_Visible_Refinements -- 2175 -------------------------------- 2176 2177 procedure Remove_Visible_Refinements (Spec_Id : Entity_Id) is 2178 State_Elmt : Elmt_Id; 2179 begin 2180 if Present (Abstract_States (Spec_Id)) then 2181 State_Elmt := First_Elmt (Abstract_States (Spec_Id)); 2182 while Present (State_Elmt) loop 2183 Set_Has_Visible_Refinement (Node (State_Elmt), False); 2184 Next_Elmt (State_Elmt); 2185 end loop; 2186 end if; 2187 end Remove_Visible_Refinements; 2188 2189 -- Local variables 2190 2191 Context : Node_Id; 2192 Freeze_From : Entity_Id := Empty; 2193 Next_Decl : Node_Id; 2194 Spec_Id : Entity_Id; 2195 2196 Body_Seen : Boolean := False; 2197 -- Flag set when the first body [stub] is encountered 2198 2199 In_Package_Body : Boolean := False; 2200 -- Flag set when the current declaration list belongs to a package body 2201 2202 -- Start of processing for Analyze_Declarations 2203 2204 begin 2205 if Restriction_Check_Required (SPARK_05) then 2206 Check_Later_Vs_Basic_Declarations (L, During_Parsing => False); 2207 end if; 2208 2209 Decl := First (L); 2210 while Present (Decl) loop 2211 2212 -- Package spec cannot contain a package declaration in SPARK 2213 2214 if Nkind (Decl) = N_Package_Declaration 2215 and then Nkind (Parent (L)) = N_Package_Specification 2216 then 2217 Check_SPARK_Restriction 2218 ("package specification cannot contain a package declaration", 2219 Decl); 2220 end if; 2221 2222 -- Complete analysis of declaration 2223 2224 Analyze (Decl); 2225 Next_Decl := Next (Decl); 2226 2227 if No (Freeze_From) then 2228 Freeze_From := First_Entity (Current_Scope); 2229 end if; 2230 2231 -- At the end of a declarative part, freeze remaining entities 2232 -- declared in it. The end of the visible declarations of package 2233 -- specification is not the end of a declarative part if private 2234 -- declarations are present. The end of a package declaration is a 2235 -- freezing point only if it a library package. A task definition or 2236 -- protected type definition is not a freeze point either. Finally, 2237 -- we do not freeze entities in generic scopes, because there is no 2238 -- code generated for them and freeze nodes will be generated for 2239 -- the instance. 2240 2241 -- The end of a package instantiation is not a freeze point, but 2242 -- for now we make it one, because the generic body is inserted 2243 -- (currently) immediately after. Generic instantiations will not 2244 -- be a freeze point once delayed freezing of bodies is implemented. 2245 -- (This is needed in any case for early instantiations ???). 2246 2247 if No (Next_Decl) then 2248 if Nkind_In (Parent (L), N_Component_List, 2249 N_Task_Definition, 2250 N_Protected_Definition) 2251 then 2252 null; 2253 2254 elsif Nkind (Parent (L)) /= N_Package_Specification then 2255 if Nkind (Parent (L)) = N_Package_Body then 2256 Freeze_From := First_Entity (Current_Scope); 2257 end if; 2258 2259 -- There may have been several freezing points previously, 2260 -- for example object declarations or subprogram bodies, but 2261 -- at the end of a declarative part we check freezing from 2262 -- the beginning, even though entities may already be frozen, 2263 -- in order to perform visibility checks on delayed aspects. 2264 2265 Adjust_Decl; 2266 Freeze_All (First_Entity (Current_Scope), Decl); 2267 Freeze_From := Last_Entity (Current_Scope); 2268 2269 elsif Scope (Current_Scope) /= Standard_Standard 2270 and then not Is_Child_Unit (Current_Scope) 2271 and then No (Generic_Parent (Parent (L))) 2272 then 2273 null; 2274 2275 elsif L /= Visible_Declarations (Parent (L)) 2276 or else No (Private_Declarations (Parent (L))) 2277 or else Is_Empty_List (Private_Declarations (Parent (L))) 2278 then 2279 Adjust_Decl; 2280 Freeze_All (First_Entity (Current_Scope), Decl); 2281 Freeze_From := Last_Entity (Current_Scope); 2282 end if; 2283 2284 -- If next node is a body then freeze all types before the body. 2285 -- An exception occurs for some expander-generated bodies. If these 2286 -- are generated at places where in general language rules would not 2287 -- allow a freeze point, then we assume that the expander has 2288 -- explicitly checked that all required types are properly frozen, 2289 -- and we do not cause general freezing here. This special circuit 2290 -- is used when the encountered body is marked as having already 2291 -- been analyzed. 2292 2293 -- In all other cases (bodies that come from source, and expander 2294 -- generated bodies that have not been analyzed yet), freeze all 2295 -- types now. Note that in the latter case, the expander must take 2296 -- care to attach the bodies at a proper place in the tree so as to 2297 -- not cause unwanted freezing at that point. 2298 2299 elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) then 2300 2301 -- When a controlled type is frozen, the expander generates stream 2302 -- and controlled type support routines. If the freeze is caused 2303 -- by the stand alone body of Initialize, Adjust and Finalize, the 2304 -- expander will end up using the wrong version of these routines 2305 -- as the body has not been processed yet. To remedy this, detect 2306 -- a late controlled primitive and create a proper spec for it. 2307 -- This ensures that the primitive will override its inherited 2308 -- counterpart before the freeze takes place. 2309 2310 -- If the declaration we just processed is a body, do not attempt 2311 -- to examine Next_Decl as the late primitive idiom can only apply 2312 -- to the first encountered body. 2313 2314 -- The spec of the late primitive is not generated in ASIS mode to 2315 -- ensure a consistent list of primitives that indicates the true 2316 -- semantic structure of the program (which is not relevant when 2317 -- generating executable code. 2318 2319 -- ??? a cleaner approach may be possible and/or this solution 2320 -- could be extended to general-purpose late primitives, TBD. 2321 2322 if not ASIS_Mode 2323 and then not Body_Seen 2324 and then not Is_Body (Decl) 2325 then 2326 Body_Seen := True; 2327 2328 if Nkind (Next_Decl) = N_Subprogram_Body then 2329 Handle_Late_Controlled_Primitive (Next_Decl); 2330 end if; 2331 end if; 2332 2333 Adjust_Decl; 2334 Freeze_All (Freeze_From, Decl); 2335 Freeze_From := Last_Entity (Current_Scope); 2336 end if; 2337 2338 Decl := Next_Decl; 2339 end loop; 2340 2341 -- Analyze the contracts of packages and their bodies 2342 2343 if Present (L) then 2344 Context := Parent (L); 2345 2346 if Nkind (Context) = N_Package_Specification then 2347 2348 -- When a package has private declarations, its contract must be 2349 -- analyzed at the end of the said declarations. This way both the 2350 -- analysis and freeze actions are properly synchronized in case 2351 -- of private type use within the contract. 2352 2353 if L = Private_Declarations (Context) then 2354 Analyze_Package_Contract (Defining_Entity (Context)); 2355 2356 -- Otherwise the contract is analyzed at the end of the visible 2357 -- declarations. 2358 2359 elsif L = Visible_Declarations (Context) 2360 and then No (Private_Declarations (Context)) 2361 then 2362 Analyze_Package_Contract (Defining_Entity (Context)); 2363 end if; 2364 2365 elsif Nkind (Context) = N_Package_Body then 2366 In_Package_Body := True; 2367 Spec_Id := Corresponding_Spec (Context); 2368 2369 Analyze_Package_Body_Contract (Defining_Entity (Context)); 2370 end if; 2371 end if; 2372 2373 -- Analyze the contracts of subprogram declarations, subprogram bodies 2374 -- and variables now due to the delayed visibility requirements of their 2375 -- aspects. 2376 2377 Decl := First (L); 2378 while Present (Decl) loop 2379 if Nkind (Decl) = N_Object_Declaration then 2380 Analyze_Object_Contract (Defining_Entity (Decl)); 2381 2382 elsif Nkind (Decl) = N_Subprogram_Body then 2383 Analyze_Subprogram_Body_Contract (Defining_Entity (Decl)); 2384 2385 elsif Nkind_In (Decl, N_Subprogram_Declaration, 2386 N_Abstract_Subprogram_Declaration) 2387 then 2388 Analyze_Subprogram_Contract (Defining_Entity (Decl)); 2389 end if; 2390 2391 Next (Decl); 2392 end loop; 2393 2394 -- State refinements are visible upto the end the of the package body 2395 -- declarations. Hide the refinements from visibility to restore the 2396 -- original state conditions. 2397 2398 if In_Package_Body then 2399 Remove_Visible_Refinements (Spec_Id); 2400 end if; 2401 end Analyze_Declarations; 2402 2403 ----------------------------------- 2404 -- Analyze_Full_Type_Declaration -- 2405 ----------------------------------- 2406 2407 procedure Analyze_Full_Type_Declaration (N : Node_Id) is 2408 Def : constant Node_Id := Type_Definition (N); 2409 Def_Id : constant Entity_Id := Defining_Identifier (N); 2410 T : Entity_Id; 2411 Prev : Entity_Id; 2412 2413 Is_Remote : constant Boolean := 2414 (Is_Remote_Types (Current_Scope) 2415 or else Is_Remote_Call_Interface (Current_Scope)) 2416 and then not (In_Private_Part (Current_Scope) 2417 or else In_Package_Body (Current_Scope)); 2418 2419 procedure Check_Ops_From_Incomplete_Type; 2420 -- If there is a tagged incomplete partial view of the type, traverse 2421 -- the primitives of the incomplete view and change the type of any 2422 -- controlling formals and result to indicate the full view. The 2423 -- primitives will be added to the full type's primitive operations 2424 -- list later in Sem_Disp.Check_Operation_From_Incomplete_Type (which 2425 -- is called from Process_Incomplete_Dependents). 2426 2427 ------------------------------------ 2428 -- Check_Ops_From_Incomplete_Type -- 2429 ------------------------------------ 2430 2431 procedure Check_Ops_From_Incomplete_Type is 2432 Elmt : Elmt_Id; 2433 Formal : Entity_Id; 2434 Op : Entity_Id; 2435 2436 begin 2437 if Prev /= T 2438 and then Ekind (Prev) = E_Incomplete_Type 2439 and then Is_Tagged_Type (Prev) 2440 and then Is_Tagged_Type (T) 2441 then 2442 Elmt := First_Elmt (Primitive_Operations (Prev)); 2443 while Present (Elmt) loop 2444 Op := Node (Elmt); 2445 2446 Formal := First_Formal (Op); 2447 while Present (Formal) loop 2448 if Etype (Formal) = Prev then 2449 Set_Etype (Formal, T); 2450 end if; 2451 2452 Next_Formal (Formal); 2453 end loop; 2454 2455 if Etype (Op) = Prev then 2456 Set_Etype (Op, T); 2457 end if; 2458 2459 Next_Elmt (Elmt); 2460 end loop; 2461 end if; 2462 end Check_Ops_From_Incomplete_Type; 2463 2464 -- Start of processing for Analyze_Full_Type_Declaration 2465 2466 begin 2467 Prev := Find_Type_Name (N); 2468 2469 -- The full view, if present, now points to the current type 2470 2471 -- Ada 2005 (AI-50217): If the type was previously decorated when 2472 -- imported through a LIMITED WITH clause, it appears as incomplete 2473 -- but has no full view. 2474 2475 if Ekind (Prev) = E_Incomplete_Type 2476 and then Present (Full_View (Prev)) 2477 then 2478 T := Full_View (Prev); 2479 else 2480 T := Prev; 2481 end if; 2482 2483 Set_Is_Pure (T, Is_Pure (Current_Scope)); 2484 2485 -- We set the flag Is_First_Subtype here. It is needed to set the 2486 -- corresponding flag for the Implicit class-wide-type created 2487 -- during tagged types processing. 2488 2489 Set_Is_First_Subtype (T, True); 2490 2491 -- Only composite types other than array types are allowed to have 2492 -- discriminants. 2493 2494 case Nkind (Def) is 2495 2496 -- For derived types, the rule will be checked once we've figured 2497 -- out the parent type. 2498 2499 when N_Derived_Type_Definition => 2500 null; 2501 2502 -- For record types, discriminants are allowed, unless we are in 2503 -- SPARK. 2504 2505 when N_Record_Definition => 2506 if Present (Discriminant_Specifications (N)) then 2507 Check_SPARK_Restriction 2508 ("discriminant type is not allowed", 2509 Defining_Identifier 2510 (First (Discriminant_Specifications (N)))); 2511 end if; 2512 2513 when others => 2514 if Present (Discriminant_Specifications (N)) then 2515 Error_Msg_N 2516 ("elementary or array type cannot have discriminants", 2517 Defining_Identifier 2518 (First (Discriminant_Specifications (N)))); 2519 end if; 2520 end case; 2521 2522 -- Elaborate the type definition according to kind, and generate 2523 -- subsidiary (implicit) subtypes where needed. We skip this if it was 2524 -- already done (this happens during the reanalysis that follows a call 2525 -- to the high level optimizer). 2526 2527 if not Analyzed (T) then 2528 Set_Analyzed (T); 2529 2530 case Nkind (Def) is 2531 2532 when N_Access_To_Subprogram_Definition => 2533 Access_Subprogram_Declaration (T, Def); 2534 2535 -- If this is a remote access to subprogram, we must create the 2536 -- equivalent fat pointer type, and related subprograms. 2537 2538 if Is_Remote then 2539 Process_Remote_AST_Declaration (N); 2540 end if; 2541 2542 -- Validate categorization rule against access type declaration 2543 -- usually a violation in Pure unit, Shared_Passive unit. 2544 2545 Validate_Access_Type_Declaration (T, N); 2546 2547 when N_Access_To_Object_Definition => 2548 Access_Type_Declaration (T, Def); 2549 2550 -- Validate categorization rule against access type declaration 2551 -- usually a violation in Pure unit, Shared_Passive unit. 2552 2553 Validate_Access_Type_Declaration (T, N); 2554 2555 -- If we are in a Remote_Call_Interface package and define a 2556 -- RACW, then calling stubs and specific stream attributes 2557 -- must be added. 2558 2559 if Is_Remote 2560 and then Is_Remote_Access_To_Class_Wide_Type (Def_Id) 2561 then 2562 Add_RACW_Features (Def_Id); 2563 end if; 2564 2565 -- Set no strict aliasing flag if config pragma seen 2566 2567 if Opt.No_Strict_Aliasing then 2568 Set_No_Strict_Aliasing (Base_Type (Def_Id)); 2569 end if; 2570 2571 when N_Array_Type_Definition => 2572 Array_Type_Declaration (T, Def); 2573 2574 when N_Derived_Type_Definition => 2575 Derived_Type_Declaration (T, N, T /= Def_Id); 2576 2577 when N_Enumeration_Type_Definition => 2578 Enumeration_Type_Declaration (T, Def); 2579 2580 when N_Floating_Point_Definition => 2581 Floating_Point_Type_Declaration (T, Def); 2582 2583 when N_Decimal_Fixed_Point_Definition => 2584 Decimal_Fixed_Point_Type_Declaration (T, Def); 2585 2586 when N_Ordinary_Fixed_Point_Definition => 2587 Ordinary_Fixed_Point_Type_Declaration (T, Def); 2588 2589 when N_Signed_Integer_Type_Definition => 2590 Signed_Integer_Type_Declaration (T, Def); 2591 2592 when N_Modular_Type_Definition => 2593 Modular_Type_Declaration (T, Def); 2594 2595 when N_Record_Definition => 2596 Record_Type_Declaration (T, N, Prev); 2597 2598 -- If declaration has a parse error, nothing to elaborate. 2599 2600 when N_Error => 2601 null; 2602 2603 when others => 2604 raise Program_Error; 2605 2606 end case; 2607 end if; 2608 2609 if Etype (T) = Any_Type then 2610 return; 2611 end if; 2612 2613 -- Controlled type is not allowed in SPARK 2614 2615 if Is_Visibly_Controlled (T) then 2616 Check_SPARK_Restriction ("controlled type is not allowed", N); 2617 end if; 2618 2619 -- Some common processing for all types 2620 2621 Set_Depends_On_Private (T, Has_Private_Component (T)); 2622 Check_Ops_From_Incomplete_Type; 2623 2624 -- Both the declared entity, and its anonymous base type if one 2625 -- was created, need freeze nodes allocated. 2626 2627 declare 2628 B : constant Entity_Id := Base_Type (T); 2629 2630 begin 2631 -- In the case where the base type differs from the first subtype, we 2632 -- pre-allocate a freeze node, and set the proper link to the first 2633 -- subtype. Freeze_Entity will use this preallocated freeze node when 2634 -- it freezes the entity. 2635 2636 -- This does not apply if the base type is a generic type, whose 2637 -- declaration is independent of the current derived definition. 2638 2639 if B /= T and then not Is_Generic_Type (B) then 2640 Ensure_Freeze_Node (B); 2641 Set_First_Subtype_Link (Freeze_Node (B), T); 2642 end if; 2643 2644 -- A type that is imported through a limited_with clause cannot 2645 -- generate any code, and thus need not be frozen. However, an access 2646 -- type with an imported designated type needs a finalization list, 2647 -- which may be referenced in some other package that has non-limited 2648 -- visibility on the designated type. Thus we must create the 2649 -- finalization list at the point the access type is frozen, to 2650 -- prevent unsatisfied references at link time. 2651 2652 if not From_Limited_With (T) or else Is_Access_Type (T) then 2653 Set_Has_Delayed_Freeze (T); 2654 end if; 2655 end; 2656 2657 -- Case where T is the full declaration of some private type which has 2658 -- been swapped in Defining_Identifier (N). 2659 2660 if T /= Def_Id and then Is_Private_Type (Def_Id) then 2661 Process_Full_View (N, T, Def_Id); 2662 2663 -- Record the reference. The form of this is a little strange, since 2664 -- the full declaration has been swapped in. So the first parameter 2665 -- here represents the entity to which a reference is made which is 2666 -- the "real" entity, i.e. the one swapped in, and the second 2667 -- parameter provides the reference location. 2668 2669 -- Also, we want to kill Has_Pragma_Unreferenced temporarily here 2670 -- since we don't want a complaint about the full type being an 2671 -- unwanted reference to the private type 2672 2673 declare 2674 B : constant Boolean := Has_Pragma_Unreferenced (T); 2675 begin 2676 Set_Has_Pragma_Unreferenced (T, False); 2677 Generate_Reference (T, T, 'c'); 2678 Set_Has_Pragma_Unreferenced (T, B); 2679 end; 2680 2681 Set_Completion_Referenced (Def_Id); 2682 2683 -- For completion of incomplete type, process incomplete dependents 2684 -- and always mark the full type as referenced (it is the incomplete 2685 -- type that we get for any real reference). 2686 2687 elsif Ekind (Prev) = E_Incomplete_Type then 2688 Process_Incomplete_Dependents (N, T, Prev); 2689 Generate_Reference (Prev, Def_Id, 'c'); 2690 Set_Completion_Referenced (Def_Id); 2691 2692 -- If not private type or incomplete type completion, this is a real 2693 -- definition of a new entity, so record it. 2694 2695 else 2696 Generate_Definition (Def_Id); 2697 end if; 2698 2699 if Chars (Scope (Def_Id)) = Name_System 2700 and then Chars (Def_Id) = Name_Address 2701 and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N))) 2702 then 2703 Set_Is_Descendent_Of_Address (Def_Id); 2704 Set_Is_Descendent_Of_Address (Base_Type (Def_Id)); 2705 Set_Is_Descendent_Of_Address (Prev); 2706 end if; 2707 2708 Set_Optimize_Alignment_Flags (Def_Id); 2709 Check_Eliminated (Def_Id); 2710 2711 -- If the declaration is a completion and aspects are present, apply 2712 -- them to the entity for the type which is currently the partial 2713 -- view, but which is the one that will be frozen. 2714 2715 if Has_Aspects (N) then 2716 if Prev /= Def_Id then 2717 Analyze_Aspect_Specifications (N, Prev); 2718 else 2719 Analyze_Aspect_Specifications (N, Def_Id); 2720 end if; 2721 end if; 2722 end Analyze_Full_Type_Declaration; 2723 2724 ---------------------------------- 2725 -- Analyze_Incomplete_Type_Decl -- 2726 ---------------------------------- 2727 2728 procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is 2729 F : constant Boolean := Is_Pure (Current_Scope); 2730 T : Entity_Id; 2731 2732 begin 2733 Check_SPARK_Restriction ("incomplete type is not allowed", N); 2734 2735 Generate_Definition (Defining_Identifier (N)); 2736 2737 -- Process an incomplete declaration. The identifier must not have been 2738 -- declared already in the scope. However, an incomplete declaration may 2739 -- appear in the private part of a package, for a private type that has 2740 -- already been declared. 2741 2742 -- In this case, the discriminants (if any) must match 2743 2744 T := Find_Type_Name (N); 2745 2746 Set_Ekind (T, E_Incomplete_Type); 2747 Init_Size_Align (T); 2748 Set_Is_First_Subtype (T, True); 2749 Set_Etype (T, T); 2750 2751 -- Ada 2005 (AI-326): Minimum decoration to give support to tagged 2752 -- incomplete types. 2753 2754 if Tagged_Present (N) then 2755 Set_Is_Tagged_Type (T); 2756 Make_Class_Wide_Type (T); 2757 Set_Direct_Primitive_Operations (T, New_Elmt_List); 2758 end if; 2759 2760 Push_Scope (T); 2761 2762 Set_Stored_Constraint (T, No_Elist); 2763 2764 if Present (Discriminant_Specifications (N)) then 2765 Process_Discriminants (N); 2766 end if; 2767 2768 End_Scope; 2769 2770 -- If the type has discriminants, non-trivial subtypes may be 2771 -- declared before the full view of the type. The full views of those 2772 -- subtypes will be built after the full view of the type. 2773 2774 Set_Private_Dependents (T, New_Elmt_List); 2775 Set_Is_Pure (T, F); 2776 end Analyze_Incomplete_Type_Decl; 2777 2778 ----------------------------------- 2779 -- Analyze_Interface_Declaration -- 2780 ----------------------------------- 2781 2782 procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is 2783 CW : constant Entity_Id := Class_Wide_Type (T); 2784 2785 begin 2786 Set_Is_Tagged_Type (T); 2787 2788 Set_Is_Limited_Record (T, Limited_Present (Def) 2789 or else Task_Present (Def) 2790 or else Protected_Present (Def) 2791 or else Synchronized_Present (Def)); 2792 2793 -- Type is abstract if full declaration carries keyword, or if previous 2794 -- partial view did. 2795 2796 Set_Is_Abstract_Type (T); 2797 Set_Is_Interface (T); 2798 2799 -- Type is a limited interface if it includes the keyword limited, task, 2800 -- protected, or synchronized. 2801 2802 Set_Is_Limited_Interface 2803 (T, Limited_Present (Def) 2804 or else Protected_Present (Def) 2805 or else Synchronized_Present (Def) 2806 or else Task_Present (Def)); 2807 2808 Set_Interfaces (T, New_Elmt_List); 2809 Set_Direct_Primitive_Operations (T, New_Elmt_List); 2810 2811 -- Complete the decoration of the class-wide entity if it was already 2812 -- built (i.e. during the creation of the limited view) 2813 2814 if Present (CW) then 2815 Set_Is_Interface (CW); 2816 Set_Is_Limited_Interface (CW, Is_Limited_Interface (T)); 2817 end if; 2818 2819 -- Check runtime support for synchronized interfaces 2820 2821 if VM_Target = No_VM 2822 and then (Is_Task_Interface (T) 2823 or else Is_Protected_Interface (T) 2824 or else Is_Synchronized_Interface (T)) 2825 and then not RTE_Available (RE_Select_Specific_Data) 2826 then 2827 Error_Msg_CRT ("synchronized interfaces", T); 2828 end if; 2829 end Analyze_Interface_Declaration; 2830 2831 ----------------------------- 2832 -- Analyze_Itype_Reference -- 2833 ----------------------------- 2834 2835 -- Nothing to do. This node is placed in the tree only for the benefit of 2836 -- back end processing, and has no effect on the semantic processing. 2837 2838 procedure Analyze_Itype_Reference (N : Node_Id) is 2839 begin 2840 pragma Assert (Is_Itype (Itype (N))); 2841 null; 2842 end Analyze_Itype_Reference; 2843 2844 -------------------------------- 2845 -- Analyze_Number_Declaration -- 2846 -------------------------------- 2847 2848 procedure Analyze_Number_Declaration (N : Node_Id) is 2849 Id : constant Entity_Id := Defining_Identifier (N); 2850 E : constant Node_Id := Expression (N); 2851 T : Entity_Id; 2852 Index : Interp_Index; 2853 It : Interp; 2854 2855 begin 2856 Generate_Definition (Id); 2857 Enter_Name (Id); 2858 2859 -- This is an optimization of a common case of an integer literal 2860 2861 if Nkind (E) = N_Integer_Literal then 2862 Set_Is_Static_Expression (E, True); 2863 Set_Etype (E, Universal_Integer); 2864 2865 Set_Etype (Id, Universal_Integer); 2866 Set_Ekind (Id, E_Named_Integer); 2867 Set_Is_Frozen (Id, True); 2868 return; 2869 end if; 2870 2871 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 2872 2873 -- Process expression, replacing error by integer zero, to avoid 2874 -- cascaded errors or aborts further along in the processing 2875 2876 -- Replace Error by integer zero, which seems least likely to cause 2877 -- cascaded errors. 2878 2879 if E = Error then 2880 Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0)); 2881 Set_Error_Posted (E); 2882 end if; 2883 2884 Analyze (E); 2885 2886 -- Verify that the expression is static and numeric. If 2887 -- the expression is overloaded, we apply the preference 2888 -- rule that favors root numeric types. 2889 2890 if not Is_Overloaded (E) then 2891 T := Etype (E); 2892 2893 else 2894 T := Any_Type; 2895 2896 Get_First_Interp (E, Index, It); 2897 while Present (It.Typ) loop 2898 if (Is_Integer_Type (It.Typ) or else Is_Real_Type (It.Typ)) 2899 and then (Scope (Base_Type (It.Typ))) = Standard_Standard 2900 then 2901 if T = Any_Type then 2902 T := It.Typ; 2903 2904 elsif It.Typ = Universal_Real 2905 or else It.Typ = Universal_Integer 2906 then 2907 -- Choose universal interpretation over any other 2908 2909 T := It.Typ; 2910 exit; 2911 end if; 2912 end if; 2913 2914 Get_Next_Interp (Index, It); 2915 end loop; 2916 end if; 2917 2918 if Is_Integer_Type (T) then 2919 Resolve (E, T); 2920 Set_Etype (Id, Universal_Integer); 2921 Set_Ekind (Id, E_Named_Integer); 2922 2923 elsif Is_Real_Type (T) then 2924 2925 -- Because the real value is converted to universal_real, this is a 2926 -- legal context for a universal fixed expression. 2927 2928 if T = Universal_Fixed then 2929 declare 2930 Loc : constant Source_Ptr := Sloc (N); 2931 Conv : constant Node_Id := Make_Type_Conversion (Loc, 2932 Subtype_Mark => 2933 New_Occurrence_Of (Universal_Real, Loc), 2934 Expression => Relocate_Node (E)); 2935 2936 begin 2937 Rewrite (E, Conv); 2938 Analyze (E); 2939 end; 2940 2941 elsif T = Any_Fixed then 2942 Error_Msg_N ("illegal context for mixed mode operation", E); 2943 2944 -- Expression is of the form : universal_fixed * integer. Try to 2945 -- resolve as universal_real. 2946 2947 T := Universal_Real; 2948 Set_Etype (E, T); 2949 end if; 2950 2951 Resolve (E, T); 2952 Set_Etype (Id, Universal_Real); 2953 Set_Ekind (Id, E_Named_Real); 2954 2955 else 2956 Wrong_Type (E, Any_Numeric); 2957 Resolve (E, T); 2958 2959 Set_Etype (Id, T); 2960 Set_Ekind (Id, E_Constant); 2961 Set_Never_Set_In_Source (Id, True); 2962 Set_Is_True_Constant (Id, True); 2963 return; 2964 end if; 2965 2966 if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then 2967 Set_Etype (E, Etype (Id)); 2968 end if; 2969 2970 if not Is_OK_Static_Expression (E) then 2971 Flag_Non_Static_Expr 2972 ("non-static expression used in number declaration!", E); 2973 Rewrite (E, Make_Integer_Literal (Sloc (N), 1)); 2974 Set_Etype (E, Any_Type); 2975 end if; 2976 end Analyze_Number_Declaration; 2977 2978 ----------------------------- 2979 -- Analyze_Object_Contract -- 2980 ----------------------------- 2981 2982 procedure Analyze_Object_Contract (Obj_Id : Entity_Id) is 2983 AR_Val : Boolean := False; 2984 AW_Val : Boolean := False; 2985 ER_Val : Boolean := False; 2986 EW_Val : Boolean := False; 2987 Prag : Node_Id; 2988 Seen : Boolean := False; 2989 2990 begin 2991 if Ekind (Obj_Id) = E_Constant then 2992 2993 -- A constant cannot be volatile. This check is only relevant when 2994 -- SPARK_Mode is on as it is not standard Ada legality rule. Do not 2995 -- flag internally-generated constants that map generic formals to 2996 -- actuals in instantiations (SPARK RM 7.1.3(6)). 2997 2998 if SPARK_Mode = On 2999 and then Is_SPARK_Volatile_Object (Obj_Id) 3000 and then No (Corresponding_Generic_Association (Parent (Obj_Id))) 3001 then 3002 Error_Msg_N ("constant cannot be volatile", Obj_Id); 3003 end if; 3004 3005 else pragma Assert (Ekind (Obj_Id) = E_Variable); 3006 3007 -- The following checks are only relevant when SPARK_Mode is on as 3008 -- they are not standard Ada legality rules. 3009 3010 if SPARK_Mode = On then 3011 3012 -- A non-volatile object cannot have volatile components 3013 -- (SPARK RM 7.1.3(7)). 3014 3015 if not Is_SPARK_Volatile_Object (Obj_Id) 3016 and then Has_Volatile_Component (Etype (Obj_Id)) 3017 then 3018 Error_Msg_N 3019 ("non-volatile variable & cannot have volatile components", 3020 Obj_Id); 3021 3022 -- The declaration of a volatile object must appear at the library 3023 -- level. 3024 3025 elsif Is_SPARK_Volatile_Object (Obj_Id) 3026 and then not Is_Library_Level_Entity (Obj_Id) 3027 then 3028 Error_Msg_N 3029 ("volatile variable & must be declared at library level " 3030 & "(SPARK RM 7.1.3(5))", Obj_Id); 3031 end if; 3032 end if; 3033 3034 -- Analyze all external properties 3035 3036 Prag := Get_Pragma (Obj_Id, Pragma_Async_Readers); 3037 3038 if Present (Prag) then 3039 Analyze_External_Property_In_Decl_Part (Prag, AR_Val); 3040 Seen := True; 3041 end if; 3042 3043 Prag := Get_Pragma (Obj_Id, Pragma_Async_Writers); 3044 3045 if Present (Prag) then 3046 Analyze_External_Property_In_Decl_Part (Prag, AW_Val); 3047 Seen := True; 3048 end if; 3049 3050 Prag := Get_Pragma (Obj_Id, Pragma_Effective_Reads); 3051 3052 if Present (Prag) then 3053 Analyze_External_Property_In_Decl_Part (Prag, ER_Val); 3054 Seen := True; 3055 end if; 3056 3057 Prag := Get_Pragma (Obj_Id, Pragma_Effective_Writes); 3058 3059 if Present (Prag) then 3060 Analyze_External_Property_In_Decl_Part (Prag, EW_Val); 3061 Seen := True; 3062 end if; 3063 3064 -- Verify the mutual interaction of the various external properties 3065 3066 if Seen then 3067 Check_External_Properties (Obj_Id, AR_Val, AW_Val, ER_Val, EW_Val); 3068 end if; 3069 3070 -- Check whether the lack of indicator Part_Of agrees with the 3071 -- placement of the variable with respect to the state space. 3072 3073 Prag := Get_Pragma (Obj_Id, Pragma_Part_Of); 3074 3075 if No (Prag) then 3076 Check_Missing_Part_Of (Obj_Id); 3077 end if; 3078 end if; 3079 end Analyze_Object_Contract; 3080 3081 -------------------------------- 3082 -- Analyze_Object_Declaration -- 3083 -------------------------------- 3084 3085 procedure Analyze_Object_Declaration (N : Node_Id) is 3086 Loc : constant Source_Ptr := Sloc (N); 3087 Id : constant Entity_Id := Defining_Identifier (N); 3088 T : Entity_Id; 3089 Act_T : Entity_Id; 3090 3091 E : Node_Id := Expression (N); 3092 -- E is set to Expression (N) throughout this routine. When 3093 -- Expression (N) is modified, E is changed accordingly. 3094 3095 Prev_Entity : Entity_Id := Empty; 3096 3097 function Count_Tasks (T : Entity_Id) return Uint; 3098 -- This function is called when a non-generic library level object of a 3099 -- task type is declared. Its function is to count the static number of 3100 -- tasks declared within the type (it is only called if Has_Tasks is set 3101 -- for T). As a side effect, if an array of tasks with non-static bounds 3102 -- or a variant record type is encountered, Check_Restrictions is called 3103 -- indicating the count is unknown. 3104 3105 ----------------- 3106 -- Count_Tasks -- 3107 ----------------- 3108 3109 function Count_Tasks (T : Entity_Id) return Uint is 3110 C : Entity_Id; 3111 X : Node_Id; 3112 V : Uint; 3113 3114 begin 3115 if Is_Task_Type (T) then 3116 return Uint_1; 3117 3118 elsif Is_Record_Type (T) then 3119 if Has_Discriminants (T) then 3120 Check_Restriction (Max_Tasks, N); 3121 return Uint_0; 3122 3123 else 3124 V := Uint_0; 3125 C := First_Component (T); 3126 while Present (C) loop 3127 V := V + Count_Tasks (Etype (C)); 3128 Next_Component (C); 3129 end loop; 3130 3131 return V; 3132 end if; 3133 3134 elsif Is_Array_Type (T) then 3135 X := First_Index (T); 3136 V := Count_Tasks (Component_Type (T)); 3137 while Present (X) loop 3138 C := Etype (X); 3139 3140 if not Is_Static_Subtype (C) then 3141 Check_Restriction (Max_Tasks, N); 3142 return Uint_0; 3143 else 3144 V := V * (UI_Max (Uint_0, 3145 Expr_Value (Type_High_Bound (C)) - 3146 Expr_Value (Type_Low_Bound (C)) + Uint_1)); 3147 end if; 3148 3149 Next_Index (X); 3150 end loop; 3151 3152 return V; 3153 3154 else 3155 return Uint_0; 3156 end if; 3157 end Count_Tasks; 3158 3159 -- Start of processing for Analyze_Object_Declaration 3160 3161 begin 3162 -- There are three kinds of implicit types generated by an 3163 -- object declaration: 3164 3165 -- 1. Those generated by the original Object Definition 3166 3167 -- 2. Those generated by the Expression 3168 3169 -- 3. Those used to constrain the Object Definition with the 3170 -- expression constraints when the definition is unconstrained. 3171 3172 -- They must be generated in this order to avoid order of elaboration 3173 -- issues. Thus the first step (after entering the name) is to analyze 3174 -- the object definition. 3175 3176 if Constant_Present (N) then 3177 Prev_Entity := Current_Entity_In_Scope (Id); 3178 3179 if Present (Prev_Entity) 3180 and then 3181 3182 -- If the homograph is an implicit subprogram, it is overridden 3183 -- by the current declaration. 3184 3185 ((Is_Overloadable (Prev_Entity) 3186 and then Is_Inherited_Operation (Prev_Entity)) 3187 3188 -- The current object is a discriminal generated for an entry 3189 -- family index. Even though the index is a constant, in this 3190 -- particular context there is no true constant redeclaration. 3191 -- Enter_Name will handle the visibility. 3192 3193 or else 3194 (Is_Discriminal (Id) 3195 and then Ekind (Discriminal_Link (Id)) = 3196 E_Entry_Index_Parameter) 3197 3198 -- The current object is the renaming for a generic declared 3199 -- within the instance. 3200 3201 or else 3202 (Ekind (Prev_Entity) = E_Package 3203 and then Nkind (Parent (Prev_Entity)) = 3204 N_Package_Renaming_Declaration 3205 and then not Comes_From_Source (Prev_Entity) 3206 and then Is_Generic_Instance (Renamed_Entity (Prev_Entity)))) 3207 then 3208 Prev_Entity := Empty; 3209 end if; 3210 end if; 3211 3212 if Present (Prev_Entity) then 3213 Constant_Redeclaration (Id, N, T); 3214 3215 Generate_Reference (Prev_Entity, Id, 'c'); 3216 Set_Completion_Referenced (Id); 3217 3218 if Error_Posted (N) then 3219 3220 -- Type mismatch or illegal redeclaration, Do not analyze 3221 -- expression to avoid cascaded errors. 3222 3223 T := Find_Type_Of_Object (Object_Definition (N), N); 3224 Set_Etype (Id, T); 3225 Set_Ekind (Id, E_Variable); 3226 goto Leave; 3227 end if; 3228 3229 -- In the normal case, enter identifier at the start to catch premature 3230 -- usage in the initialization expression. 3231 3232 else 3233 Generate_Definition (Id); 3234 Enter_Name (Id); 3235 3236 Mark_Coextensions (N, Object_Definition (N)); 3237 3238 T := Find_Type_Of_Object (Object_Definition (N), N); 3239 3240 if Nkind (Object_Definition (N)) = N_Access_Definition 3241 and then Present 3242 (Access_To_Subprogram_Definition (Object_Definition (N))) 3243 and then Protected_Present 3244 (Access_To_Subprogram_Definition (Object_Definition (N))) 3245 then 3246 T := Replace_Anonymous_Access_To_Protected_Subprogram (N); 3247 end if; 3248 3249 if Error_Posted (Id) then 3250 Set_Etype (Id, T); 3251 Set_Ekind (Id, E_Variable); 3252 goto Leave; 3253 end if; 3254 end if; 3255 3256 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry 3257 -- out some static checks 3258 3259 if Ada_Version >= Ada_2005 3260 and then Can_Never_Be_Null (T) 3261 then 3262 -- In case of aggregates we must also take care of the correct 3263 -- initialization of nested aggregates bug this is done at the 3264 -- point of the analysis of the aggregate (see sem_aggr.adb) 3265 3266 if Present (Expression (N)) 3267 and then Nkind (Expression (N)) = N_Aggregate 3268 then 3269 null; 3270 3271 else 3272 declare 3273 Save_Typ : constant Entity_Id := Etype (Id); 3274 begin 3275 Set_Etype (Id, T); -- Temp. decoration for static checks 3276 Null_Exclusion_Static_Checks (N); 3277 Set_Etype (Id, Save_Typ); 3278 end; 3279 end if; 3280 end if; 3281 3282 -- Object is marked pure if it is in a pure scope 3283 3284 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3285 3286 -- If deferred constant, make sure context is appropriate. We detect 3287 -- a deferred constant as a constant declaration with no expression. 3288 -- A deferred constant can appear in a package body if its completion 3289 -- is by means of an interface pragma. 3290 3291 if Constant_Present (N) and then No (E) then 3292 3293 -- A deferred constant may appear in the declarative part of the 3294 -- following constructs: 3295 3296 -- blocks 3297 -- entry bodies 3298 -- extended return statements 3299 -- package specs 3300 -- package bodies 3301 -- subprogram bodies 3302 -- task bodies 3303 3304 -- When declared inside a package spec, a deferred constant must be 3305 -- completed by a full constant declaration or pragma Import. In all 3306 -- other cases, the only proper completion is pragma Import. Extended 3307 -- return statements are flagged as invalid contexts because they do 3308 -- not have a declarative part and so cannot accommodate the pragma. 3309 3310 if Ekind (Current_Scope) = E_Return_Statement then 3311 Error_Msg_N 3312 ("invalid context for deferred constant declaration (RM 7.4)", 3313 N); 3314 Error_Msg_N 3315 ("\declaration requires an initialization expression", 3316 N); 3317 Set_Constant_Present (N, False); 3318 3319 -- In Ada 83, deferred constant must be of private type 3320 3321 elsif not Is_Private_Type (T) then 3322 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 3323 Error_Msg_N 3324 ("(Ada 83) deferred constant must be private type", N); 3325 end if; 3326 end if; 3327 3328 -- If not a deferred constant, then object declaration freezes its type 3329 3330 else 3331 Check_Fully_Declared (T, N); 3332 Freeze_Before (N, T); 3333 end if; 3334 3335 -- If the object was created by a constrained array definition, then 3336 -- set the link in both the anonymous base type and anonymous subtype 3337 -- that are built to represent the array type to point to the object. 3338 3339 if Nkind (Object_Definition (Declaration_Node (Id))) = 3340 N_Constrained_Array_Definition 3341 then 3342 Set_Related_Array_Object (T, Id); 3343 Set_Related_Array_Object (Base_Type (T), Id); 3344 end if; 3345 3346 -- Special checks for protected objects not at library level 3347 3348 if Is_Protected_Type (T) 3349 and then not Is_Library_Level_Entity (Id) 3350 then 3351 Check_Restriction (No_Local_Protected_Objects, Id); 3352 3353 -- Protected objects with interrupt handlers must be at library level 3354 3355 -- Ada 2005: This test is not needed (and the corresponding clause 3356 -- in the RM is removed) because accessibility checks are sufficient 3357 -- to make handlers not at the library level illegal. 3358 3359 -- AI05-0303: The AI is in fact a binding interpretation, and thus 3360 -- applies to the '95 version of the language as well. 3361 3362 if Has_Interrupt_Handler (T) and then Ada_Version < Ada_95 then 3363 Error_Msg_N 3364 ("interrupt object can only be declared at library level", Id); 3365 end if; 3366 end if; 3367 3368 -- The actual subtype of the object is the nominal subtype, unless 3369 -- the nominal one is unconstrained and obtained from the expression. 3370 3371 Act_T := T; 3372 3373 -- These checks should be performed before the initialization expression 3374 -- is considered, so that the Object_Definition node is still the same 3375 -- as in source code. 3376 3377 -- In SPARK, the nominal subtype shall be given by a subtype mark and 3378 -- shall not be unconstrained. (The only exception to this is the 3379 -- admission of declarations of constants of type String.) 3380 3381 if not 3382 Nkind_In (Object_Definition (N), N_Identifier, N_Expanded_Name) 3383 then 3384 Check_SPARK_Restriction 3385 ("subtype mark required", Object_Definition (N)); 3386 3387 elsif Is_Array_Type (T) 3388 and then not Is_Constrained (T) 3389 and then T /= Standard_String 3390 then 3391 Check_SPARK_Restriction 3392 ("subtype mark of constrained type expected", 3393 Object_Definition (N)); 3394 end if; 3395 3396 -- There are no aliased objects in SPARK 3397 3398 if Aliased_Present (N) then 3399 Check_SPARK_Restriction ("aliased object is not allowed", N); 3400 end if; 3401 3402 -- Process initialization expression if present and not in error 3403 3404 if Present (E) and then E /= Error then 3405 3406 -- Generate an error in case of CPP class-wide object initialization. 3407 -- Required because otherwise the expansion of the class-wide 3408 -- assignment would try to use 'size to initialize the object 3409 -- (primitive that is not available in CPP tagged types). 3410 3411 if Is_Class_Wide_Type (Act_T) 3412 and then 3413 (Is_CPP_Class (Root_Type (Etype (Act_T))) 3414 or else 3415 (Present (Full_View (Root_Type (Etype (Act_T)))) 3416 and then 3417 Is_CPP_Class (Full_View (Root_Type (Etype (Act_T)))))) 3418 then 3419 Error_Msg_N 3420 ("predefined assignment not available for 'C'P'P tagged types", 3421 E); 3422 end if; 3423 3424 Mark_Coextensions (N, E); 3425 Analyze (E); 3426 3427 -- In case of errors detected in the analysis of the expression, 3428 -- decorate it with the expected type to avoid cascaded errors 3429 3430 if No (Etype (E)) then 3431 Set_Etype (E, T); 3432 end if; 3433 3434 -- If an initialization expression is present, then we set the 3435 -- Is_True_Constant flag. It will be reset if this is a variable 3436 -- and it is indeed modified. 3437 3438 Set_Is_True_Constant (Id, True); 3439 3440 -- If we are analyzing a constant declaration, set its completion 3441 -- flag after analyzing and resolving the expression. 3442 3443 if Constant_Present (N) then 3444 Set_Has_Completion (Id); 3445 end if; 3446 3447 -- Set type and resolve (type may be overridden later on). Note: 3448 -- Ekind (Id) must still be E_Void at this point so that incorrect 3449 -- early usage within E is properly diagnosed. 3450 3451 Set_Etype (Id, T); 3452 Resolve (E, T); 3453 3454 -- No further action needed if E is a call to an inlined function 3455 -- which returns an unconstrained type and it has been expanded into 3456 -- a procedure call. In that case N has been replaced by an object 3457 -- declaration without initializing expression and it has been 3458 -- analyzed (see Expand_Inlined_Call). 3459 3460 if Debug_Flag_Dot_K 3461 and then Expander_Active 3462 and then Nkind (E) = N_Function_Call 3463 and then Nkind (Name (E)) in N_Has_Entity 3464 and then Is_Inlined (Entity (Name (E))) 3465 and then not Is_Constrained (Etype (E)) 3466 and then Analyzed (N) 3467 and then No (Expression (N)) 3468 then 3469 return; 3470 end if; 3471 3472 -- If E is null and has been replaced by an N_Raise_Constraint_Error 3473 -- node (which was marked already-analyzed), we need to set the type 3474 -- to something other than Any_Access in order to keep gigi happy. 3475 3476 if Etype (E) = Any_Access then 3477 Set_Etype (E, T); 3478 end if; 3479 3480 -- If the object is an access to variable, the initialization 3481 -- expression cannot be an access to constant. 3482 3483 if Is_Access_Type (T) 3484 and then not Is_Access_Constant (T) 3485 and then Is_Access_Type (Etype (E)) 3486 and then Is_Access_Constant (Etype (E)) 3487 then 3488 Error_Msg_N 3489 ("access to variable cannot be initialized " 3490 & "with an access-to-constant expression", E); 3491 end if; 3492 3493 if not Assignment_OK (N) then 3494 Check_Initialization (T, E); 3495 end if; 3496 3497 Check_Unset_Reference (E); 3498 3499 -- If this is a variable, then set current value. If this is a 3500 -- declared constant of a scalar type with a static expression, 3501 -- indicate that it is always valid. 3502 3503 if not Constant_Present (N) then 3504 if Compile_Time_Known_Value (E) then 3505 Set_Current_Value (Id, E); 3506 end if; 3507 3508 elsif Is_Scalar_Type (T) 3509 and then Is_OK_Static_Expression (E) 3510 then 3511 Set_Is_Known_Valid (Id); 3512 end if; 3513 3514 -- Deal with setting of null flags 3515 3516 if Is_Access_Type (T) then 3517 if Known_Non_Null (E) then 3518 Set_Is_Known_Non_Null (Id, True); 3519 elsif Known_Null (E) 3520 and then not Can_Never_Be_Null (Id) 3521 then 3522 Set_Is_Known_Null (Id, True); 3523 end if; 3524 end if; 3525 3526 -- Check incorrect use of dynamically tagged expressions 3527 3528 if Is_Tagged_Type (T) then 3529 Check_Dynamically_Tagged_Expression 3530 (Expr => E, 3531 Typ => T, 3532 Related_Nod => N); 3533 end if; 3534 3535 Apply_Scalar_Range_Check (E, T); 3536 Apply_Static_Length_Check (E, T); 3537 3538 if Nkind (Original_Node (N)) = N_Object_Declaration 3539 and then Comes_From_Source (Original_Node (N)) 3540 3541 -- Only call test if needed 3542 3543 and then Restriction_Check_Required (SPARK_05) 3544 and then not Is_SPARK_Initialization_Expr (Original_Node (E)) 3545 then 3546 Check_SPARK_Restriction 3547 ("initialization expression is not appropriate", E); 3548 end if; 3549 end if; 3550 3551 -- If the No_Streams restriction is set, check that the type of the 3552 -- object is not, and does not contain, any subtype derived from 3553 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to 3554 -- Has_Stream just for efficiency reasons. There is no point in 3555 -- spending time on a Has_Stream check if the restriction is not set. 3556 3557 if Restriction_Check_Required (No_Streams) then 3558 if Has_Stream (T) then 3559 Check_Restriction (No_Streams, N); 3560 end if; 3561 end if; 3562 3563 -- Deal with predicate check before we start to do major rewriting. It 3564 -- is OK to initialize and then check the initialized value, since the 3565 -- object goes out of scope if we get a predicate failure. Note that we 3566 -- do this in the analyzer and not the expander because the analyzer 3567 -- does some substantial rewriting in some cases. 3568 3569 -- We need a predicate check if the type has predicates, and if either 3570 -- there is an initializing expression, or for default initialization 3571 -- when we have at least one case of an explicit default initial value 3572 -- and then this is not an internal declaration whose initialization 3573 -- comes later (as for an aggregate expansion). 3574 3575 if not Suppress_Assignment_Checks (N) 3576 and then Present (Predicate_Function (T)) 3577 and then not No_Initialization (N) 3578 and then 3579 (Present (E) 3580 or else 3581 Is_Partially_Initialized_Type (T, Include_Implicit => False)) 3582 then 3583 -- If the type has a static predicate and the expression is known at 3584 -- compile time, see if the expression satisfies the predicate. 3585 3586 if Present (E) then 3587 Check_Expression_Against_Static_Predicate (E, T); 3588 end if; 3589 3590 Insert_After (N, 3591 Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc))); 3592 end if; 3593 3594 -- Case of unconstrained type 3595 3596 if Is_Indefinite_Subtype (T) then 3597 3598 -- In SPARK, a declaration of unconstrained type is allowed 3599 -- only for constants of type string. 3600 3601 if Is_String_Type (T) and then not Constant_Present (N) then 3602 Check_SPARK_Restriction 3603 ("declaration of object of unconstrained type not allowed", N); 3604 end if; 3605 3606 -- Nothing to do in deferred constant case 3607 3608 if Constant_Present (N) and then No (E) then 3609 null; 3610 3611 -- Case of no initialization present 3612 3613 elsif No (E) then 3614 if No_Initialization (N) then 3615 null; 3616 3617 elsif Is_Class_Wide_Type (T) then 3618 Error_Msg_N 3619 ("initialization required in class-wide declaration ", N); 3620 3621 else 3622 Error_Msg_N 3623 ("unconstrained subtype not allowed (need initialization)", 3624 Object_Definition (N)); 3625 3626 if Is_Record_Type (T) and then Has_Discriminants (T) then 3627 Error_Msg_N 3628 ("\provide initial value or explicit discriminant values", 3629 Object_Definition (N)); 3630 3631 Error_Msg_NE 3632 ("\or give default discriminant values for type&", 3633 Object_Definition (N), T); 3634 3635 elsif Is_Array_Type (T) then 3636 Error_Msg_N 3637 ("\provide initial value or explicit array bounds", 3638 Object_Definition (N)); 3639 end if; 3640 end if; 3641 3642 -- Case of initialization present but in error. Set initial 3643 -- expression as absent (but do not make above complaints) 3644 3645 elsif E = Error then 3646 Set_Expression (N, Empty); 3647 E := Empty; 3648 3649 -- Case of initialization present 3650 3651 else 3652 -- Check restrictions in Ada 83 3653 3654 if not Constant_Present (N) then 3655 3656 -- Unconstrained variables not allowed in Ada 83 mode 3657 3658 if Ada_Version = Ada_83 3659 and then Comes_From_Source (Object_Definition (N)) 3660 then 3661 Error_Msg_N 3662 ("(Ada 83) unconstrained variable not allowed", 3663 Object_Definition (N)); 3664 end if; 3665 end if; 3666 3667 -- Now we constrain the variable from the initializing expression 3668 3669 -- If the expression is an aggregate, it has been expanded into 3670 -- individual assignments. Retrieve the actual type from the 3671 -- expanded construct. 3672 3673 if Is_Array_Type (T) 3674 and then No_Initialization (N) 3675 and then Nkind (Original_Node (E)) = N_Aggregate 3676 then 3677 Act_T := Etype (E); 3678 3679 -- In case of class-wide interface object declarations we delay 3680 -- the generation of the equivalent record type declarations until 3681 -- its expansion because there are cases in they are not required. 3682 3683 elsif Is_Interface (T) then 3684 null; 3685 3686 else 3687 Expand_Subtype_From_Expr (N, T, Object_Definition (N), E); 3688 Act_T := Find_Type_Of_Object (Object_Definition (N), N); 3689 end if; 3690 3691 Set_Is_Constr_Subt_For_U_Nominal (Act_T); 3692 3693 if Aliased_Present (N) then 3694 Set_Is_Constr_Subt_For_UN_Aliased (Act_T); 3695 end if; 3696 3697 Freeze_Before (N, Act_T); 3698 Freeze_Before (N, T); 3699 end if; 3700 3701 elsif Is_Array_Type (T) 3702 and then No_Initialization (N) 3703 and then Nkind (Original_Node (E)) = N_Aggregate 3704 then 3705 if not Is_Entity_Name (Object_Definition (N)) then 3706 Act_T := Etype (E); 3707 Check_Compile_Time_Size (Act_T); 3708 3709 if Aliased_Present (N) then 3710 Set_Is_Constr_Subt_For_UN_Aliased (Act_T); 3711 end if; 3712 end if; 3713 3714 -- When the given object definition and the aggregate are specified 3715 -- independently, and their lengths might differ do a length check. 3716 -- This cannot happen if the aggregate is of the form (others =>...) 3717 3718 if not Is_Constrained (T) then 3719 null; 3720 3721 elsif Nkind (E) = N_Raise_Constraint_Error then 3722 3723 -- Aggregate is statically illegal. Place back in declaration 3724 3725 Set_Expression (N, E); 3726 Set_No_Initialization (N, False); 3727 3728 elsif T = Etype (E) then 3729 null; 3730 3731 elsif Nkind (E) = N_Aggregate 3732 and then Present (Component_Associations (E)) 3733 and then Present (Choices (First (Component_Associations (E)))) 3734 and then Nkind (First 3735 (Choices (First (Component_Associations (E))))) = N_Others_Choice 3736 then 3737 null; 3738 3739 else 3740 Apply_Length_Check (E, T); 3741 end if; 3742 3743 -- If the type is limited unconstrained with defaulted discriminants and 3744 -- there is no expression, then the object is constrained by the 3745 -- defaults, so it is worthwhile building the corresponding subtype. 3746 3747 elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T)) 3748 and then not Is_Constrained (T) 3749 and then Has_Discriminants (T) 3750 then 3751 if No (E) then 3752 Act_T := Build_Default_Subtype (T, N); 3753 else 3754 -- Ada 2005: A limited object may be initialized by means of an 3755 -- aggregate. If the type has default discriminants it has an 3756 -- unconstrained nominal type, Its actual subtype will be obtained 3757 -- from the aggregate, and not from the default discriminants. 3758 3759 Act_T := Etype (E); 3760 end if; 3761 3762 Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc)); 3763 3764 elsif Nkind (E) = N_Function_Call 3765 and then Constant_Present (N) 3766 and then Has_Unconstrained_Elements (Etype (E)) 3767 then 3768 -- The back-end has problems with constants of a discriminated type 3769 -- with defaults, if the initial value is a function call. We 3770 -- generate an intermediate temporary that will receive a reference 3771 -- to the result of the call. The initialization expression then 3772 -- becomes a dereference of that temporary. 3773 3774 Remove_Side_Effects (E); 3775 3776 -- If this is a constant declaration of an unconstrained type and 3777 -- the initialization is an aggregate, we can use the subtype of the 3778 -- aggregate for the declared entity because it is immutable. 3779 3780 elsif not Is_Constrained (T) 3781 and then Has_Discriminants (T) 3782 and then Constant_Present (N) 3783 and then not Has_Unchecked_Union (T) 3784 and then Nkind (E) = N_Aggregate 3785 then 3786 Act_T := Etype (E); 3787 end if; 3788 3789 -- Check No_Wide_Characters restriction 3790 3791 Check_Wide_Character_Restriction (T, Object_Definition (N)); 3792 3793 -- Indicate this is not set in source. Certainly true for constants, and 3794 -- true for variables so far (will be reset for a variable if and when 3795 -- we encounter a modification in the source). 3796 3797 Set_Never_Set_In_Source (Id, True); 3798 3799 -- Now establish the proper kind and type of the object 3800 3801 if Constant_Present (N) then 3802 Set_Ekind (Id, E_Constant); 3803 Set_Is_True_Constant (Id); 3804 3805 else 3806 Set_Ekind (Id, E_Variable); 3807 3808 -- A variable is set as shared passive if it appears in a shared 3809 -- passive package, and is at the outer level. This is not done for 3810 -- entities generated during expansion, because those are always 3811 -- manipulated locally. 3812 3813 if Is_Shared_Passive (Current_Scope) 3814 and then Is_Library_Level_Entity (Id) 3815 and then Comes_From_Source (Id) 3816 then 3817 Set_Is_Shared_Passive (Id); 3818 Check_Shared_Var (Id, T, N); 3819 end if; 3820 3821 -- Set Has_Initial_Value if initializing expression present. Note 3822 -- that if there is no initializing expression, we leave the state 3823 -- of this flag unchanged (usually it will be False, but notably in 3824 -- the case of exception choice variables, it will already be true). 3825 3826 if Present (E) then 3827 Set_Has_Initial_Value (Id, True); 3828 end if; 3829 3830 Set_Contract (Id, Make_Contract (Sloc (Id))); 3831 end if; 3832 3833 -- Initialize alignment and size and capture alignment setting 3834 3835 Init_Alignment (Id); 3836 Init_Esize (Id); 3837 Set_Optimize_Alignment_Flags (Id); 3838 3839 -- Deal with aliased case 3840 3841 if Aliased_Present (N) then 3842 Set_Is_Aliased (Id); 3843 3844 -- If the object is aliased and the type is unconstrained with 3845 -- defaulted discriminants and there is no expression, then the 3846 -- object is constrained by the defaults, so it is worthwhile 3847 -- building the corresponding subtype. 3848 3849 -- Ada 2005 (AI-363): If the aliased object is discriminated and 3850 -- unconstrained, then only establish an actual subtype if the 3851 -- nominal subtype is indefinite. In definite cases the object is 3852 -- unconstrained in Ada 2005. 3853 3854 if No (E) 3855 and then Is_Record_Type (T) 3856 and then not Is_Constrained (T) 3857 and then Has_Discriminants (T) 3858 and then (Ada_Version < Ada_2005 or else Is_Indefinite_Subtype (T)) 3859 then 3860 Set_Actual_Subtype (Id, Build_Default_Subtype (T, N)); 3861 end if; 3862 end if; 3863 3864 -- Now we can set the type of the object 3865 3866 Set_Etype (Id, Act_T); 3867 3868 -- Object is marked to be treated as volatile if type is volatile and 3869 -- we clear the Current_Value setting that may have been set above. 3870 3871 if Treat_As_Volatile (Etype (Id)) then 3872 Set_Treat_As_Volatile (Id); 3873 Set_Current_Value (Id, Empty); 3874 end if; 3875 3876 -- Deal with controlled types 3877 3878 if Has_Controlled_Component (Etype (Id)) 3879 or else Is_Controlled (Etype (Id)) 3880 then 3881 if not Is_Library_Level_Entity (Id) then 3882 Check_Restriction (No_Nested_Finalization, N); 3883 else 3884 Validate_Controlled_Object (Id); 3885 end if; 3886 end if; 3887 3888 if Has_Task (Etype (Id)) then 3889 Check_Restriction (No_Tasking, N); 3890 3891 -- Deal with counting max tasks 3892 3893 -- Nothing to do if inside a generic 3894 3895 if Inside_A_Generic then 3896 null; 3897 3898 -- If library level entity, then count tasks 3899 3900 elsif Is_Library_Level_Entity (Id) then 3901 Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id))); 3902 3903 -- If not library level entity, then indicate we don't know max 3904 -- tasks and also check task hierarchy restriction and blocking 3905 -- operation (since starting a task is definitely blocking). 3906 3907 else 3908 Check_Restriction (Max_Tasks, N); 3909 Check_Restriction (No_Task_Hierarchy, N); 3910 Check_Potentially_Blocking_Operation (N); 3911 end if; 3912 3913 -- A rather specialized test. If we see two tasks being declared 3914 -- of the same type in the same object declaration, and the task 3915 -- has an entry with an address clause, we know that program error 3916 -- will be raised at run time since we can't have two tasks with 3917 -- entries at the same address. 3918 3919 if Is_Task_Type (Etype (Id)) and then More_Ids (N) then 3920 declare 3921 E : Entity_Id; 3922 3923 begin 3924 E := First_Entity (Etype (Id)); 3925 while Present (E) loop 3926 if Ekind (E) = E_Entry 3927 and then Present (Get_Attribute_Definition_Clause 3928 (E, Attribute_Address)) 3929 then 3930 Error_Msg_Warn := SPARK_Mode /= On; 3931 Error_Msg_N 3932 ("more than one task with same entry address<<", N); 3933 Error_Msg_N ("\Program_Error [<<", N); 3934 Insert_Action (N, 3935 Make_Raise_Program_Error (Loc, 3936 Reason => PE_Duplicated_Entry_Address)); 3937 exit; 3938 end if; 3939 3940 Next_Entity (E); 3941 end loop; 3942 end; 3943 end if; 3944 end if; 3945 3946 -- Some simple constant-propagation: if the expression is a constant 3947 -- string initialized with a literal, share the literal. This avoids 3948 -- a run-time copy. 3949 3950 if Present (E) 3951 and then Is_Entity_Name (E) 3952 and then Ekind (Entity (E)) = E_Constant 3953 and then Base_Type (Etype (E)) = Standard_String 3954 then 3955 declare 3956 Val : constant Node_Id := Constant_Value (Entity (E)); 3957 begin 3958 if Present (Val) 3959 and then Nkind (Val) = N_String_Literal 3960 then 3961 Rewrite (E, New_Copy (Val)); 3962 end if; 3963 end; 3964 end if; 3965 3966 -- Another optimization: if the nominal subtype is unconstrained and 3967 -- the expression is a function call that returns an unconstrained 3968 -- type, rewrite the declaration as a renaming of the result of the 3969 -- call. The exceptions below are cases where the copy is expected, 3970 -- either by the back end (Aliased case) or by the semantics, as for 3971 -- initializing controlled types or copying tags for classwide types. 3972 3973 if Present (E) 3974 and then Nkind (E) = N_Explicit_Dereference 3975 and then Nkind (Original_Node (E)) = N_Function_Call 3976 and then not Is_Library_Level_Entity (Id) 3977 and then not Is_Constrained (Underlying_Type (T)) 3978 and then not Is_Aliased (Id) 3979 and then not Is_Class_Wide_Type (T) 3980 and then not Is_Controlled (T) 3981 and then not Has_Controlled_Component (Base_Type (T)) 3982 and then Expander_Active 3983 then 3984 Rewrite (N, 3985 Make_Object_Renaming_Declaration (Loc, 3986 Defining_Identifier => Id, 3987 Access_Definition => Empty, 3988 Subtype_Mark => New_Occurrence_Of 3989 (Base_Type (Etype (Id)), Loc), 3990 Name => E)); 3991 3992 Set_Renamed_Object (Id, E); 3993 3994 -- Force generation of debugging information for the constant and for 3995 -- the renamed function call. 3996 3997 Set_Debug_Info_Needed (Id); 3998 Set_Debug_Info_Needed (Entity (Prefix (E))); 3999 end if; 4000 4001 if Present (Prev_Entity) 4002 and then Is_Frozen (Prev_Entity) 4003 and then not Error_Posted (Id) 4004 then 4005 Error_Msg_N ("full constant declaration appears too late", N); 4006 end if; 4007 4008 Check_Eliminated (Id); 4009 4010 -- Deal with setting In_Private_Part flag if in private part 4011 4012 if Ekind (Scope (Id)) = E_Package 4013 and then In_Private_Part (Scope (Id)) 4014 then 4015 Set_In_Private_Part (Id); 4016 end if; 4017 4018 -- Check for violation of No_Local_Timing_Events 4019 4020 if Restriction_Check_Required (No_Local_Timing_Events) 4021 and then not Is_Library_Level_Entity (Id) 4022 and then Is_RTE (Etype (Id), RE_Timing_Event) 4023 then 4024 Check_Restriction (No_Local_Timing_Events, N); 4025 end if; 4026 4027 <<Leave>> 4028 -- Initialize the refined state of a variable here because this is a 4029 -- common destination for legal and illegal object declarations. 4030 4031 if Ekind (Id) = E_Variable then 4032 Set_Encapsulating_State (Id, Empty); 4033 end if; 4034 4035 if Has_Aspects (N) then 4036 Analyze_Aspect_Specifications (N, Id); 4037 end if; 4038 4039 Analyze_Dimension (N); 4040 4041 -- Verify whether the object declaration introduces an illegal hidden 4042 -- state within a package subject to a null abstract state. 4043 4044 if Ekind (Id) = E_Variable then 4045 Check_No_Hidden_State (Id); 4046 end if; 4047 end Analyze_Object_Declaration; 4048 4049 --------------------------- 4050 -- Analyze_Others_Choice -- 4051 --------------------------- 4052 4053 -- Nothing to do for the others choice node itself, the semantic analysis 4054 -- of the others choice will occur as part of the processing of the parent 4055 4056 procedure Analyze_Others_Choice (N : Node_Id) is 4057 pragma Warnings (Off, N); 4058 begin 4059 null; 4060 end Analyze_Others_Choice; 4061 4062 ------------------------------------------- 4063 -- Analyze_Private_Extension_Declaration -- 4064 ------------------------------------------- 4065 4066 procedure Analyze_Private_Extension_Declaration (N : Node_Id) is 4067 T : constant Entity_Id := Defining_Identifier (N); 4068 Indic : constant Node_Id := Subtype_Indication (N); 4069 Parent_Type : Entity_Id; 4070 Parent_Base : Entity_Id; 4071 4072 begin 4073 -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces 4074 4075 if Is_Non_Empty_List (Interface_List (N)) then 4076 declare 4077 Intf : Node_Id; 4078 T : Entity_Id; 4079 4080 begin 4081 Intf := First (Interface_List (N)); 4082 while Present (Intf) loop 4083 T := Find_Type_Of_Subtype_Indic (Intf); 4084 4085 Diagnose_Interface (Intf, T); 4086 Next (Intf); 4087 end loop; 4088 end; 4089 end if; 4090 4091 Generate_Definition (T); 4092 4093 -- For other than Ada 2012, just enter the name in the current scope 4094 4095 if Ada_Version < Ada_2012 then 4096 Enter_Name (T); 4097 4098 -- Ada 2012 (AI05-0162): Enter the name in the current scope handling 4099 -- case of private type that completes an incomplete type. 4100 4101 else 4102 declare 4103 Prev : Entity_Id; 4104 4105 begin 4106 Prev := Find_Type_Name (N); 4107 4108 pragma Assert (Prev = T 4109 or else (Ekind (Prev) = E_Incomplete_Type 4110 and then Present (Full_View (Prev)) 4111 and then Full_View (Prev) = T)); 4112 end; 4113 end if; 4114 4115 Parent_Type := Find_Type_Of_Subtype_Indic (Indic); 4116 Parent_Base := Base_Type (Parent_Type); 4117 4118 if Parent_Type = Any_Type 4119 or else Etype (Parent_Type) = Any_Type 4120 then 4121 Set_Ekind (T, Ekind (Parent_Type)); 4122 Set_Etype (T, Any_Type); 4123 goto Leave; 4124 4125 elsif not Is_Tagged_Type (Parent_Type) then 4126 Error_Msg_N 4127 ("parent of type extension must be a tagged type ", Indic); 4128 goto Leave; 4129 4130 elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then 4131 Error_Msg_N ("premature derivation of incomplete type", Indic); 4132 goto Leave; 4133 4134 elsif Is_Concurrent_Type (Parent_Type) then 4135 Error_Msg_N 4136 ("parent type of a private extension cannot be " 4137 & "a synchronized tagged type (RM 3.9.1 (3/1))", N); 4138 4139 Set_Etype (T, Any_Type); 4140 Set_Ekind (T, E_Limited_Private_Type); 4141 Set_Private_Dependents (T, New_Elmt_List); 4142 Set_Error_Posted (T); 4143 goto Leave; 4144 end if; 4145 4146 -- Perhaps the parent type should be changed to the class-wide type's 4147 -- specific type in this case to prevent cascading errors ??? 4148 4149 if Is_Class_Wide_Type (Parent_Type) then 4150 Error_Msg_N 4151 ("parent of type extension must not be a class-wide type", Indic); 4152 goto Leave; 4153 end if; 4154 4155 if (not Is_Package_Or_Generic_Package (Current_Scope) 4156 and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration) 4157 or else In_Private_Part (Current_Scope) 4158 4159 then 4160 Error_Msg_N ("invalid context for private extension", N); 4161 end if; 4162 4163 -- Set common attributes 4164 4165 Set_Is_Pure (T, Is_Pure (Current_Scope)); 4166 Set_Scope (T, Current_Scope); 4167 Set_Ekind (T, E_Record_Type_With_Private); 4168 Init_Size_Align (T); 4169 4170 Set_Etype (T, Parent_Base); 4171 Set_Has_Task (T, Has_Task (Parent_Base)); 4172 4173 Set_Convention (T, Convention (Parent_Type)); 4174 Set_First_Rep_Item (T, First_Rep_Item (Parent_Type)); 4175 Set_Is_First_Subtype (T); 4176 Make_Class_Wide_Type (T); 4177 4178 if Unknown_Discriminants_Present (N) then 4179 Set_Discriminant_Constraint (T, No_Elist); 4180 end if; 4181 4182 Build_Derived_Record_Type (N, Parent_Type, T); 4183 4184 -- Propagate inherited invariant information. The new type has 4185 -- invariants, if the parent type has inheritable invariants, 4186 -- and these invariants can in turn be inherited. 4187 4188 if Has_Inheritable_Invariants (Parent_Type) then 4189 Set_Has_Inheritable_Invariants (T); 4190 Set_Has_Invariants (T); 4191 end if; 4192 4193 -- Ada 2005 (AI-443): Synchronized private extension or a rewritten 4194 -- synchronized formal derived type. 4195 4196 if Ada_Version >= Ada_2005 4197 and then Synchronized_Present (N) 4198 then 4199 Set_Is_Limited_Record (T); 4200 4201 -- Formal derived type case 4202 4203 if Is_Generic_Type (T) then 4204 4205 -- The parent must be a tagged limited type or a synchronized 4206 -- interface. 4207 4208 if (not Is_Tagged_Type (Parent_Type) 4209 or else not Is_Limited_Type (Parent_Type)) 4210 and then 4211 (not Is_Interface (Parent_Type) 4212 or else not Is_Synchronized_Interface (Parent_Type)) 4213 then 4214 Error_Msg_NE ("parent type of & must be tagged limited " & 4215 "or synchronized", N, T); 4216 end if; 4217 4218 -- The progenitors (if any) must be limited or synchronized 4219 -- interfaces. 4220 4221 if Present (Interfaces (T)) then 4222 declare 4223 Iface : Entity_Id; 4224 Iface_Elmt : Elmt_Id; 4225 4226 begin 4227 Iface_Elmt := First_Elmt (Interfaces (T)); 4228 while Present (Iface_Elmt) loop 4229 Iface := Node (Iface_Elmt); 4230 4231 if not Is_Limited_Interface (Iface) 4232 and then not Is_Synchronized_Interface (Iface) 4233 then 4234 Error_Msg_NE ("progenitor & must be limited " & 4235 "or synchronized", N, Iface); 4236 end if; 4237 4238 Next_Elmt (Iface_Elmt); 4239 end loop; 4240 end; 4241 end if; 4242 4243 -- Regular derived extension, the parent must be a limited or 4244 -- synchronized interface. 4245 4246 else 4247 if not Is_Interface (Parent_Type) 4248 or else (not Is_Limited_Interface (Parent_Type) 4249 and then 4250 not Is_Synchronized_Interface (Parent_Type)) 4251 then 4252 Error_Msg_NE 4253 ("parent type of & must be limited interface", N, T); 4254 end if; 4255 end if; 4256 4257 -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private 4258 -- extension with a synchronized parent must be explicitly declared 4259 -- synchronized, because the full view will be a synchronized type. 4260 -- This must be checked before the check for limited types below, 4261 -- to ensure that types declared limited are not allowed to extend 4262 -- synchronized interfaces. 4263 4264 elsif Is_Interface (Parent_Type) 4265 and then Is_Synchronized_Interface (Parent_Type) 4266 and then not Synchronized_Present (N) 4267 then 4268 Error_Msg_NE 4269 ("private extension of& must be explicitly synchronized", 4270 N, Parent_Type); 4271 4272 elsif Limited_Present (N) then 4273 Set_Is_Limited_Record (T); 4274 4275 if not Is_Limited_Type (Parent_Type) 4276 and then 4277 (not Is_Interface (Parent_Type) 4278 or else not Is_Limited_Interface (Parent_Type)) 4279 then 4280 Error_Msg_NE ("parent type& of limited extension must be limited", 4281 N, Parent_Type); 4282 end if; 4283 end if; 4284 4285 <<Leave>> 4286 if Has_Aspects (N) then 4287 Analyze_Aspect_Specifications (N, T); 4288 end if; 4289 end Analyze_Private_Extension_Declaration; 4290 4291 --------------------------------- 4292 -- Analyze_Subtype_Declaration -- 4293 --------------------------------- 4294 4295 procedure Analyze_Subtype_Declaration 4296 (N : Node_Id; 4297 Skip : Boolean := False) 4298 is 4299 Id : constant Entity_Id := Defining_Identifier (N); 4300 T : Entity_Id; 4301 R_Checks : Check_Result; 4302 4303 begin 4304 Generate_Definition (Id); 4305 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 4306 Init_Size_Align (Id); 4307 4308 -- The following guard condition on Enter_Name is to handle cases where 4309 -- the defining identifier has already been entered into the scope but 4310 -- the declaration as a whole needs to be analyzed. 4311 4312 -- This case in particular happens for derived enumeration types. The 4313 -- derived enumeration type is processed as an inserted enumeration type 4314 -- declaration followed by a rewritten subtype declaration. The defining 4315 -- identifier, however, is entered into the name scope very early in the 4316 -- processing of the original type declaration and therefore needs to be 4317 -- avoided here, when the created subtype declaration is analyzed. (See 4318 -- Build_Derived_Types) 4319 4320 -- This also happens when the full view of a private type is derived 4321 -- type with constraints. In this case the entity has been introduced 4322 -- in the private declaration. 4323 4324 -- Finally this happens in some complex cases when validity checks are 4325 -- enabled, where the same subtype declaration may be analyzed twice. 4326 -- This can happen if the subtype is created by the pre-analysis of 4327 -- an attribute tht gives the range of a loop statement, and the loop 4328 -- itself appears within an if_statement that will be rewritten during 4329 -- expansion. 4330 4331 if Skip 4332 or else (Present (Etype (Id)) 4333 and then (Is_Private_Type (Etype (Id)) 4334 or else Is_Task_Type (Etype (Id)) 4335 or else Is_Rewrite_Substitution (N))) 4336 then 4337 null; 4338 4339 elsif Current_Entity (Id) = Id then 4340 null; 4341 4342 else 4343 Enter_Name (Id); 4344 end if; 4345 4346 T := Process_Subtype (Subtype_Indication (N), N, Id, 'P'); 4347 4348 -- Class-wide equivalent types of records with unknown discriminants 4349 -- involve the generation of an itype which serves as the private view 4350 -- of a constrained record subtype. In such cases the base type of the 4351 -- current subtype we are processing is the private itype. Use the full 4352 -- of the private itype when decorating various attributes. 4353 4354 if Is_Itype (T) 4355 and then Is_Private_Type (T) 4356 and then Present (Full_View (T)) 4357 then 4358 T := Full_View (T); 4359 end if; 4360 4361 -- Inherit common attributes 4362 4363 Set_Is_Volatile (Id, Is_Volatile (T)); 4364 Set_Treat_As_Volatile (Id, Treat_As_Volatile (T)); 4365 Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T))); 4366 Set_Convention (Id, Convention (T)); 4367 4368 -- If ancestor has predicates then so does the subtype, and in addition 4369 -- we must delay the freeze to properly arrange predicate inheritance. 4370 4371 -- The Ancestor_Type test is a big kludge, there seem to be cases in 4372 -- which T = ID, so the above tests and assignments do nothing??? 4373 4374 if Has_Predicates (T) 4375 or else (Present (Ancestor_Subtype (T)) 4376 and then Has_Predicates (Ancestor_Subtype (T))) 4377 then 4378 Set_Has_Predicates (Id); 4379 Set_Has_Delayed_Freeze (Id); 4380 end if; 4381 4382 -- Subtype of Boolean cannot have a constraint in SPARK 4383 4384 if Is_Boolean_Type (T) 4385 and then Nkind (Subtype_Indication (N)) = N_Subtype_Indication 4386 then 4387 Check_SPARK_Restriction 4388 ("subtype of Boolean cannot have constraint", N); 4389 end if; 4390 4391 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then 4392 declare 4393 Cstr : constant Node_Id := Constraint (Subtype_Indication (N)); 4394 One_Cstr : Node_Id; 4395 Low : Node_Id; 4396 High : Node_Id; 4397 4398 begin 4399 if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint then 4400 One_Cstr := First (Constraints (Cstr)); 4401 while Present (One_Cstr) loop 4402 4403 -- Index or discriminant constraint in SPARK must be a 4404 -- subtype mark. 4405 4406 if not 4407 Nkind_In (One_Cstr, N_Identifier, N_Expanded_Name) 4408 then 4409 Check_SPARK_Restriction 4410 ("subtype mark required", One_Cstr); 4411 4412 -- String subtype must have a lower bound of 1 in SPARK. 4413 -- Note that we do not need to test for the non-static case 4414 -- here, since that was already taken care of in 4415 -- Process_Range_Expr_In_Decl. 4416 4417 elsif Base_Type (T) = Standard_String then 4418 Get_Index_Bounds (One_Cstr, Low, High); 4419 4420 if Is_OK_Static_Expression (Low) 4421 and then Expr_Value (Low) /= 1 4422 then 4423 Check_SPARK_Restriction 4424 ("String subtype must have lower bound of 1", N); 4425 end if; 4426 end if; 4427 4428 Next (One_Cstr); 4429 end loop; 4430 end if; 4431 end; 4432 end if; 4433 4434 -- In the case where there is no constraint given in the subtype 4435 -- indication, Process_Subtype just returns the Subtype_Mark, so its 4436 -- semantic attributes must be established here. 4437 4438 if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then 4439 Set_Etype (Id, Base_Type (T)); 4440 4441 -- Subtype of unconstrained array without constraint is not allowed 4442 -- in SPARK. 4443 4444 if Is_Array_Type (T) 4445 and then not Is_Constrained (T) 4446 then 4447 Check_SPARK_Restriction 4448 ("subtype of unconstrained array must have constraint", N); 4449 end if; 4450 4451 case Ekind (T) is 4452 when Array_Kind => 4453 Set_Ekind (Id, E_Array_Subtype); 4454 Copy_Array_Subtype_Attributes (Id, T); 4455 4456 when Decimal_Fixed_Point_Kind => 4457 Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype); 4458 Set_Digits_Value (Id, Digits_Value (T)); 4459 Set_Delta_Value (Id, Delta_Value (T)); 4460 Set_Scale_Value (Id, Scale_Value (T)); 4461 Set_Small_Value (Id, Small_Value (T)); 4462 Set_Scalar_Range (Id, Scalar_Range (T)); 4463 Set_Machine_Radix_10 (Id, Machine_Radix_10 (T)); 4464 Set_Is_Constrained (Id, Is_Constrained (T)); 4465 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 4466 Set_RM_Size (Id, RM_Size (T)); 4467 4468 when Enumeration_Kind => 4469 Set_Ekind (Id, E_Enumeration_Subtype); 4470 Set_First_Literal (Id, First_Literal (Base_Type (T))); 4471 Set_Scalar_Range (Id, Scalar_Range (T)); 4472 Set_Is_Character_Type (Id, Is_Character_Type (T)); 4473 Set_Is_Constrained (Id, Is_Constrained (T)); 4474 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 4475 Set_RM_Size (Id, RM_Size (T)); 4476 4477 when Ordinary_Fixed_Point_Kind => 4478 Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype); 4479 Set_Scalar_Range (Id, Scalar_Range (T)); 4480 Set_Small_Value (Id, Small_Value (T)); 4481 Set_Delta_Value (Id, Delta_Value (T)); 4482 Set_Is_Constrained (Id, Is_Constrained (T)); 4483 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 4484 Set_RM_Size (Id, RM_Size (T)); 4485 4486 when Float_Kind => 4487 Set_Ekind (Id, E_Floating_Point_Subtype); 4488 Set_Scalar_Range (Id, Scalar_Range (T)); 4489 Set_Digits_Value (Id, Digits_Value (T)); 4490 Set_Is_Constrained (Id, Is_Constrained (T)); 4491 4492 when Signed_Integer_Kind => 4493 Set_Ekind (Id, E_Signed_Integer_Subtype); 4494 Set_Scalar_Range (Id, Scalar_Range (T)); 4495 Set_Is_Constrained (Id, Is_Constrained (T)); 4496 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 4497 Set_RM_Size (Id, RM_Size (T)); 4498 4499 when Modular_Integer_Kind => 4500 Set_Ekind (Id, E_Modular_Integer_Subtype); 4501 Set_Scalar_Range (Id, Scalar_Range (T)); 4502 Set_Is_Constrained (Id, Is_Constrained (T)); 4503 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 4504 Set_RM_Size (Id, RM_Size (T)); 4505 4506 when Class_Wide_Kind => 4507 Set_Ekind (Id, E_Class_Wide_Subtype); 4508 Set_First_Entity (Id, First_Entity (T)); 4509 Set_Last_Entity (Id, Last_Entity (T)); 4510 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 4511 Set_Cloned_Subtype (Id, T); 4512 Set_Is_Tagged_Type (Id, True); 4513 Set_Has_Unknown_Discriminants 4514 (Id, True); 4515 4516 if Ekind (T) = E_Class_Wide_Subtype then 4517 Set_Equivalent_Type (Id, Equivalent_Type (T)); 4518 end if; 4519 4520 when E_Record_Type | E_Record_Subtype => 4521 Set_Ekind (Id, E_Record_Subtype); 4522 4523 if Ekind (T) = E_Record_Subtype 4524 and then Present (Cloned_Subtype (T)) 4525 then 4526 Set_Cloned_Subtype (Id, Cloned_Subtype (T)); 4527 else 4528 Set_Cloned_Subtype (Id, T); 4529 end if; 4530 4531 Set_First_Entity (Id, First_Entity (T)); 4532 Set_Last_Entity (Id, Last_Entity (T)); 4533 Set_Has_Discriminants (Id, Has_Discriminants (T)); 4534 Set_Is_Constrained (Id, Is_Constrained (T)); 4535 Set_Is_Limited_Record (Id, Is_Limited_Record (T)); 4536 Set_Has_Implicit_Dereference 4537 (Id, Has_Implicit_Dereference (T)); 4538 Set_Has_Unknown_Discriminants 4539 (Id, Has_Unknown_Discriminants (T)); 4540 4541 if Has_Discriminants (T) then 4542 Set_Discriminant_Constraint 4543 (Id, Discriminant_Constraint (T)); 4544 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 4545 4546 elsif Has_Unknown_Discriminants (Id) then 4547 Set_Discriminant_Constraint (Id, No_Elist); 4548 end if; 4549 4550 if Is_Tagged_Type (T) then 4551 Set_Is_Tagged_Type (Id); 4552 Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); 4553 Set_Direct_Primitive_Operations 4554 (Id, Direct_Primitive_Operations (T)); 4555 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 4556 4557 if Is_Interface (T) then 4558 Set_Is_Interface (Id); 4559 Set_Is_Limited_Interface (Id, Is_Limited_Interface (T)); 4560 end if; 4561 end if; 4562 4563 when Private_Kind => 4564 Set_Ekind (Id, Subtype_Kind (Ekind (T))); 4565 Set_Has_Discriminants (Id, Has_Discriminants (T)); 4566 Set_Is_Constrained (Id, Is_Constrained (T)); 4567 Set_First_Entity (Id, First_Entity (T)); 4568 Set_Last_Entity (Id, Last_Entity (T)); 4569 Set_Private_Dependents (Id, New_Elmt_List); 4570 Set_Is_Limited_Record (Id, Is_Limited_Record (T)); 4571 Set_Has_Implicit_Dereference 4572 (Id, Has_Implicit_Dereference (T)); 4573 Set_Has_Unknown_Discriminants 4574 (Id, Has_Unknown_Discriminants (T)); 4575 Set_Known_To_Have_Preelab_Init 4576 (Id, Known_To_Have_Preelab_Init (T)); 4577 4578 if Is_Tagged_Type (T) then 4579 Set_Is_Tagged_Type (Id); 4580 Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); 4581 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 4582 Set_Direct_Primitive_Operations (Id, 4583 Direct_Primitive_Operations (T)); 4584 end if; 4585 4586 -- In general the attributes of the subtype of a private type 4587 -- are the attributes of the partial view of parent. However, 4588 -- the full view may be a discriminated type, and the subtype 4589 -- must share the discriminant constraint to generate correct 4590 -- calls to initialization procedures. 4591 4592 if Has_Discriminants (T) then 4593 Set_Discriminant_Constraint 4594 (Id, Discriminant_Constraint (T)); 4595 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 4596 4597 elsif Present (Full_View (T)) 4598 and then Has_Discriminants (Full_View (T)) 4599 then 4600 Set_Discriminant_Constraint 4601 (Id, Discriminant_Constraint (Full_View (T))); 4602 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 4603 4604 -- This would seem semantically correct, but apparently 4605 -- generates spurious errors about missing components ??? 4606 4607 -- Set_Has_Discriminants (Id); 4608 end if; 4609 4610 Prepare_Private_Subtype_Completion (Id, N); 4611 4612 -- If this is the subtype of a constrained private type with 4613 -- discriminants that has got a full view and we also have 4614 -- built a completion just above, show that the completion 4615 -- is a clone of the full view to the back-end. 4616 4617 if Has_Discriminants (T) 4618 and then not Has_Unknown_Discriminants (T) 4619 and then not Is_Empty_Elmt_List (Discriminant_Constraint (T)) 4620 and then Present (Full_View (T)) 4621 and then Present (Full_View (Id)) 4622 then 4623 Set_Cloned_Subtype (Full_View (Id), Full_View (T)); 4624 end if; 4625 4626 when Access_Kind => 4627 Set_Ekind (Id, E_Access_Subtype); 4628 Set_Is_Constrained (Id, Is_Constrained (T)); 4629 Set_Is_Access_Constant 4630 (Id, Is_Access_Constant (T)); 4631 Set_Directly_Designated_Type 4632 (Id, Designated_Type (T)); 4633 Set_Can_Never_Be_Null (Id, Can_Never_Be_Null (T)); 4634 4635 -- A Pure library_item must not contain the declaration of a 4636 -- named access type, except within a subprogram, generic 4637 -- subprogram, task unit, or protected unit, or if it has 4638 -- a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)). 4639 4640 if Comes_From_Source (Id) 4641 and then In_Pure_Unit 4642 and then not In_Subprogram_Task_Protected_Unit 4643 and then not No_Pool_Assigned (Id) 4644 then 4645 Error_Msg_N 4646 ("named access types not allowed in pure unit", N); 4647 end if; 4648 4649 when Concurrent_Kind => 4650 Set_Ekind (Id, Subtype_Kind (Ekind (T))); 4651 Set_Corresponding_Record_Type (Id, 4652 Corresponding_Record_Type (T)); 4653 Set_First_Entity (Id, First_Entity (T)); 4654 Set_First_Private_Entity (Id, First_Private_Entity (T)); 4655 Set_Has_Discriminants (Id, Has_Discriminants (T)); 4656 Set_Is_Constrained (Id, Is_Constrained (T)); 4657 Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); 4658 Set_Last_Entity (Id, Last_Entity (T)); 4659 4660 if Has_Discriminants (T) then 4661 Set_Discriminant_Constraint (Id, 4662 Discriminant_Constraint (T)); 4663 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 4664 end if; 4665 4666 when E_Incomplete_Type => 4667 if Ada_Version >= Ada_2005 then 4668 4669 -- In Ada 2005 an incomplete type can be explicitly tagged: 4670 -- propagate indication. 4671 4672 Set_Ekind (Id, E_Incomplete_Subtype); 4673 Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); 4674 Set_Private_Dependents (Id, New_Elmt_List); 4675 4676 -- Ada 2005 (AI-412): Decorate an incomplete subtype of an 4677 -- incomplete type visible through a limited with clause. 4678 4679 if From_Limited_With (T) 4680 and then Present (Non_Limited_View (T)) 4681 then 4682 Set_From_Limited_With (Id); 4683 Set_Non_Limited_View (Id, Non_Limited_View (T)); 4684 4685 -- Ada 2005 (AI-412): Add the regular incomplete subtype 4686 -- to the private dependents of the original incomplete 4687 -- type for future transformation. 4688 4689 else 4690 Append_Elmt (Id, Private_Dependents (T)); 4691 end if; 4692 4693 -- If the subtype name denotes an incomplete type an error 4694 -- was already reported by Process_Subtype. 4695 4696 else 4697 Set_Etype (Id, Any_Type); 4698 end if; 4699 4700 when others => 4701 raise Program_Error; 4702 end case; 4703 end if; 4704 4705 if Etype (Id) = Any_Type then 4706 goto Leave; 4707 end if; 4708 4709 -- Some common processing on all types 4710 4711 Set_Size_Info (Id, T); 4712 Set_First_Rep_Item (Id, First_Rep_Item (T)); 4713 4714 -- If the parent type is a generic actual, so is the subtype. This may 4715 -- happen in a nested instance. Why Comes_From_Source test??? 4716 4717 if not Comes_From_Source (N) then 4718 Set_Is_Generic_Actual_Type (Id, Is_Generic_Actual_Type (T)); 4719 end if; 4720 4721 T := Etype (Id); 4722 4723 Set_Is_Immediately_Visible (Id, True); 4724 Set_Depends_On_Private (Id, Has_Private_Component (T)); 4725 Set_Is_Descendent_Of_Address (Id, Is_Descendent_Of_Address (T)); 4726 4727 if Is_Interface (T) then 4728 Set_Is_Interface (Id); 4729 end if; 4730 4731 if Present (Generic_Parent_Type (N)) 4732 and then 4733 (Nkind 4734 (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration 4735 or else Nkind 4736 (Formal_Type_Definition (Parent (Generic_Parent_Type (N)))) 4737 /= N_Formal_Private_Type_Definition) 4738 then 4739 if Is_Tagged_Type (Id) then 4740 4741 -- If this is a generic actual subtype for a synchronized type, 4742 -- the primitive operations are those of the corresponding record 4743 -- for which there is a separate subtype declaration. 4744 4745 if Is_Concurrent_Type (Id) then 4746 null; 4747 elsif Is_Class_Wide_Type (Id) then 4748 Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T)); 4749 else 4750 Derive_Subprograms (Generic_Parent_Type (N), Id, T); 4751 end if; 4752 4753 elsif Scope (Etype (Id)) /= Standard_Standard then 4754 Derive_Subprograms (Generic_Parent_Type (N), Id); 4755 end if; 4756 end if; 4757 4758 if Is_Private_Type (T) 4759 and then Present (Full_View (T)) 4760 then 4761 Conditional_Delay (Id, Full_View (T)); 4762 4763 -- The subtypes of components or subcomponents of protected types 4764 -- do not need freeze nodes, which would otherwise appear in the 4765 -- wrong scope (before the freeze node for the protected type). The 4766 -- proper subtypes are those of the subcomponents of the corresponding 4767 -- record. 4768 4769 elsif Ekind (Scope (Id)) /= E_Protected_Type 4770 and then Present (Scope (Scope (Id))) -- error defense 4771 and then Ekind (Scope (Scope (Id))) /= E_Protected_Type 4772 then 4773 Conditional_Delay (Id, T); 4774 end if; 4775 4776 -- Check that Constraint_Error is raised for a scalar subtype indication 4777 -- when the lower or upper bound of a non-null range lies outside the 4778 -- range of the type mark. 4779 4780 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then 4781 if Is_Scalar_Type (Etype (Id)) 4782 and then Scalar_Range (Id) /= 4783 Scalar_Range (Etype (Subtype_Mark 4784 (Subtype_Indication (N)))) 4785 then 4786 Apply_Range_Check 4787 (Scalar_Range (Id), 4788 Etype (Subtype_Mark (Subtype_Indication (N)))); 4789 4790 -- In the array case, check compatibility for each index 4791 4792 elsif Is_Array_Type (Etype (Id)) 4793 and then Present (First_Index (Id)) 4794 then 4795 -- This really should be a subprogram that finds the indications 4796 -- to check??? 4797 4798 declare 4799 Subt_Index : Node_Id := First_Index (Id); 4800 Target_Index : Node_Id := 4801 First_Index (Etype 4802 (Subtype_Mark (Subtype_Indication (N)))); 4803 Has_Dyn_Chk : Boolean := Has_Dynamic_Range_Check (N); 4804 4805 begin 4806 while Present (Subt_Index) loop 4807 if ((Nkind (Subt_Index) = N_Identifier 4808 and then Ekind (Entity (Subt_Index)) in Scalar_Kind) 4809 or else Nkind (Subt_Index) = N_Subtype_Indication) 4810 and then 4811 Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range 4812 then 4813 declare 4814 Target_Typ : constant Entity_Id := 4815 Etype (Target_Index); 4816 begin 4817 R_Checks := 4818 Get_Range_Checks 4819 (Scalar_Range (Etype (Subt_Index)), 4820 Target_Typ, 4821 Etype (Subt_Index), 4822 Defining_Identifier (N)); 4823 4824 -- Reset Has_Dynamic_Range_Check on the subtype to 4825 -- prevent elision of the index check due to a dynamic 4826 -- check generated for a preceding index (needed since 4827 -- Insert_Range_Checks tries to avoid generating 4828 -- redundant checks on a given declaration). 4829 4830 Set_Has_Dynamic_Range_Check (N, False); 4831 4832 Insert_Range_Checks 4833 (R_Checks, 4834 N, 4835 Target_Typ, 4836 Sloc (Defining_Identifier (N))); 4837 4838 -- Record whether this index involved a dynamic check 4839 4840 Has_Dyn_Chk := 4841 Has_Dyn_Chk or else Has_Dynamic_Range_Check (N); 4842 end; 4843 end if; 4844 4845 Next_Index (Subt_Index); 4846 Next_Index (Target_Index); 4847 end loop; 4848 4849 -- Finally, mark whether the subtype involves dynamic checks 4850 4851 Set_Has_Dynamic_Range_Check (N, Has_Dyn_Chk); 4852 end; 4853 end if; 4854 end if; 4855 4856 -- Make sure that generic actual types are properly frozen. The subtype 4857 -- is marked as a generic actual type when the enclosing instance is 4858 -- analyzed, so here we identify the subtype from the tree structure. 4859 4860 if Expander_Active 4861 and then Is_Generic_Actual_Type (Id) 4862 and then In_Instance 4863 and then not Comes_From_Source (N) 4864 and then Nkind (Subtype_Indication (N)) /= N_Subtype_Indication 4865 and then Is_Frozen (T) 4866 then 4867 Freeze_Before (N, Id); 4868 end if; 4869 4870 Set_Optimize_Alignment_Flags (Id); 4871 Check_Eliminated (Id); 4872 4873 <<Leave>> 4874 if Has_Aspects (N) then 4875 Analyze_Aspect_Specifications (N, Id); 4876 end if; 4877 4878 Analyze_Dimension (N); 4879 end Analyze_Subtype_Declaration; 4880 4881 -------------------------------- 4882 -- Analyze_Subtype_Indication -- 4883 -------------------------------- 4884 4885 procedure Analyze_Subtype_Indication (N : Node_Id) is 4886 T : constant Entity_Id := Subtype_Mark (N); 4887 R : constant Node_Id := Range_Expression (Constraint (N)); 4888 4889 begin 4890 Analyze (T); 4891 4892 if R /= Error then 4893 Analyze (R); 4894 Set_Etype (N, Etype (R)); 4895 Resolve (R, Entity (T)); 4896 else 4897 Set_Error_Posted (R); 4898 Set_Error_Posted (T); 4899 end if; 4900 end Analyze_Subtype_Indication; 4901 4902 -------------------------- 4903 -- Analyze_Variant_Part -- 4904 -------------------------- 4905 4906 procedure Analyze_Variant_Part (N : Node_Id) is 4907 Discr_Name : Node_Id; 4908 Discr_Type : Entity_Id; 4909 4910 procedure Process_Variant (A : Node_Id); 4911 -- Analyze declarations for a single variant 4912 4913 package Analyze_Variant_Choices is 4914 new Generic_Analyze_Choices (Process_Variant); 4915 use Analyze_Variant_Choices; 4916 4917 --------------------- 4918 -- Process_Variant -- 4919 --------------------- 4920 4921 procedure Process_Variant (A : Node_Id) is 4922 CL : constant Node_Id := Component_List (A); 4923 begin 4924 if not Null_Present (CL) then 4925 Analyze_Declarations (Component_Items (CL)); 4926 4927 if Present (Variant_Part (CL)) then 4928 Analyze (Variant_Part (CL)); 4929 end if; 4930 end if; 4931 end Process_Variant; 4932 4933 -- Start of processing for Analyze_Variant_Part 4934 4935 begin 4936 Discr_Name := Name (N); 4937 Analyze (Discr_Name); 4938 4939 -- If Discr_Name bad, get out (prevent cascaded errors) 4940 4941 if Etype (Discr_Name) = Any_Type then 4942 return; 4943 end if; 4944 4945 -- Check invalid discriminant in variant part 4946 4947 if Ekind (Entity (Discr_Name)) /= E_Discriminant then 4948 Error_Msg_N ("invalid discriminant name in variant part", Discr_Name); 4949 end if; 4950 4951 Discr_Type := Etype (Entity (Discr_Name)); 4952 4953 if not Is_Discrete_Type (Discr_Type) then 4954 Error_Msg_N 4955 ("discriminant in a variant part must be of a discrete type", 4956 Name (N)); 4957 return; 4958 end if; 4959 4960 -- Now analyze the choices, which also analyzes the declarations that 4961 -- are associated with each choice. 4962 4963 Analyze_Choices (Variants (N), Discr_Type); 4964 4965 -- Note: we used to instantiate and call Check_Choices here to check 4966 -- that the choices covered the discriminant, but it's too early to do 4967 -- that because of statically predicated subtypes, whose analysis may 4968 -- be deferred to their freeze point which may be as late as the freeze 4969 -- point of the containing record. So this call is now to be found in 4970 -- Freeze_Record_Declaration. 4971 4972 end Analyze_Variant_Part; 4973 4974 ---------------------------- 4975 -- Array_Type_Declaration -- 4976 ---------------------------- 4977 4978 procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is 4979 Component_Def : constant Node_Id := Component_Definition (Def); 4980 Component_Typ : constant Node_Id := Subtype_Indication (Component_Def); 4981 Element_Type : Entity_Id; 4982 Implicit_Base : Entity_Id; 4983 Index : Node_Id; 4984 Related_Id : Entity_Id := Empty; 4985 Nb_Index : Nat; 4986 P : constant Node_Id := Parent (Def); 4987 Priv : Entity_Id; 4988 4989 begin 4990 if Nkind (Def) = N_Constrained_Array_Definition then 4991 Index := First (Discrete_Subtype_Definitions (Def)); 4992 else 4993 Index := First (Subtype_Marks (Def)); 4994 end if; 4995 4996 -- Find proper names for the implicit types which may be public. In case 4997 -- of anonymous arrays we use the name of the first object of that type 4998 -- as prefix. 4999 5000 if No (T) then 5001 Related_Id := Defining_Identifier (P); 5002 else 5003 Related_Id := T; 5004 end if; 5005 5006 Nb_Index := 1; 5007 while Present (Index) loop 5008 Analyze (Index); 5009 5010 -- Test for odd case of trying to index a type by the type itself 5011 5012 if Is_Entity_Name (Index) and then Entity (Index) = T then 5013 Error_Msg_N ("type& cannot be indexed by itself", Index); 5014 Set_Entity (Index, Standard_Boolean); 5015 Set_Etype (Index, Standard_Boolean); 5016 end if; 5017 5018 -- Check SPARK restriction requiring a subtype mark 5019 5020 if not Nkind_In (Index, N_Identifier, N_Expanded_Name) then 5021 Check_SPARK_Restriction ("subtype mark required", Index); 5022 end if; 5023 5024 -- Add a subtype declaration for each index of private array type 5025 -- declaration whose etype is also private. For example: 5026 5027 -- package Pkg is 5028 -- type Index is private; 5029 -- private 5030 -- type Table is array (Index) of ... 5031 -- end; 5032 5033 -- This is currently required by the expander for the internally 5034 -- generated equality subprogram of records with variant parts in 5035 -- which the etype of some component is such private type. 5036 5037 if Ekind (Current_Scope) = E_Package 5038 and then In_Private_Part (Current_Scope) 5039 and then Has_Private_Declaration (Etype (Index)) 5040 then 5041 declare 5042 Loc : constant Source_Ptr := Sloc (Def); 5043 New_E : Entity_Id; 5044 Decl : Entity_Id; 5045 5046 begin 5047 New_E := Make_Temporary (Loc, 'T'); 5048 Set_Is_Internal (New_E); 5049 5050 Decl := 5051 Make_Subtype_Declaration (Loc, 5052 Defining_Identifier => New_E, 5053 Subtype_Indication => 5054 New_Occurrence_Of (Etype (Index), Loc)); 5055 5056 Insert_Before (Parent (Def), Decl); 5057 Analyze (Decl); 5058 Set_Etype (Index, New_E); 5059 5060 -- If the index is a range the Entity attribute is not 5061 -- available. Example: 5062 5063 -- package Pkg is 5064 -- type T is private; 5065 -- private 5066 -- type T is new Natural; 5067 -- Table : array (T(1) .. T(10)) of Boolean; 5068 -- end Pkg; 5069 5070 if Nkind (Index) /= N_Range then 5071 Set_Entity (Index, New_E); 5072 end if; 5073 end; 5074 end if; 5075 5076 Make_Index (Index, P, Related_Id, Nb_Index); 5077 5078 -- Check error of subtype with predicate for index type 5079 5080 Bad_Predicated_Subtype_Use 5081 ("subtype& has predicate, not allowed as index subtype", 5082 Index, Etype (Index)); 5083 5084 -- Move to next index 5085 5086 Next_Index (Index); 5087 Nb_Index := Nb_Index + 1; 5088 end loop; 5089 5090 -- Process subtype indication if one is present 5091 5092 if Present (Component_Typ) then 5093 Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C'); 5094 5095 Set_Etype (Component_Typ, Element_Type); 5096 5097 if not Nkind_In (Component_Typ, N_Identifier, N_Expanded_Name) then 5098 Check_SPARK_Restriction ("subtype mark required", Component_Typ); 5099 end if; 5100 5101 -- Ada 2005 (AI-230): Access Definition case 5102 5103 else pragma Assert (Present (Access_Definition (Component_Def))); 5104 5105 -- Indicate that the anonymous access type is created by the 5106 -- array type declaration. 5107 5108 Element_Type := Access_Definition 5109 (Related_Nod => P, 5110 N => Access_Definition (Component_Def)); 5111 Set_Is_Local_Anonymous_Access (Element_Type); 5112 5113 -- Propagate the parent. This field is needed if we have to generate 5114 -- the master_id associated with an anonymous access to task type 5115 -- component (see Expand_N_Full_Type_Declaration.Build_Master) 5116 5117 Set_Parent (Element_Type, Parent (T)); 5118 5119 -- Ada 2005 (AI-230): In case of components that are anonymous access 5120 -- types the level of accessibility depends on the enclosing type 5121 -- declaration 5122 5123 Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230) 5124 5125 -- Ada 2005 (AI-254) 5126 5127 declare 5128 CD : constant Node_Id := 5129 Access_To_Subprogram_Definition 5130 (Access_Definition (Component_Def)); 5131 begin 5132 if Present (CD) and then Protected_Present (CD) then 5133 Element_Type := 5134 Replace_Anonymous_Access_To_Protected_Subprogram (Def); 5135 end if; 5136 end; 5137 end if; 5138 5139 -- Constrained array case 5140 5141 if No (T) then 5142 T := Create_Itype (E_Void, P, Related_Id, 'T'); 5143 end if; 5144 5145 if Nkind (Def) = N_Constrained_Array_Definition then 5146 5147 -- Establish Implicit_Base as unconstrained base type 5148 5149 Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B'); 5150 5151 Set_Etype (Implicit_Base, Implicit_Base); 5152 Set_Scope (Implicit_Base, Current_Scope); 5153 Set_Has_Delayed_Freeze (Implicit_Base); 5154 5155 -- The constrained array type is a subtype of the unconstrained one 5156 5157 Set_Ekind (T, E_Array_Subtype); 5158 Init_Size_Align (T); 5159 Set_Etype (T, Implicit_Base); 5160 Set_Scope (T, Current_Scope); 5161 Set_Is_Constrained (T, True); 5162 Set_First_Index (T, First (Discrete_Subtype_Definitions (Def))); 5163 Set_Has_Delayed_Freeze (T); 5164 5165 -- Complete setup of implicit base type 5166 5167 Set_First_Index (Implicit_Base, First_Index (T)); 5168 Set_Component_Type (Implicit_Base, Element_Type); 5169 Set_Has_Task (Implicit_Base, Has_Task (Element_Type)); 5170 Set_Component_Size (Implicit_Base, Uint_0); 5171 Set_Packed_Array_Type (Implicit_Base, Empty); 5172 Set_Has_Controlled_Component 5173 (Implicit_Base, Has_Controlled_Component 5174 (Element_Type) 5175 or else Is_Controlled 5176 (Element_Type)); 5177 Set_Finalize_Storage_Only 5178 (Implicit_Base, Finalize_Storage_Only 5179 (Element_Type)); 5180 5181 -- Unconstrained array case 5182 5183 else 5184 Set_Ekind (T, E_Array_Type); 5185 Init_Size_Align (T); 5186 Set_Etype (T, T); 5187 Set_Scope (T, Current_Scope); 5188 Set_Component_Size (T, Uint_0); 5189 Set_Is_Constrained (T, False); 5190 Set_First_Index (T, First (Subtype_Marks (Def))); 5191 Set_Has_Delayed_Freeze (T, True); 5192 Set_Has_Task (T, Has_Task (Element_Type)); 5193 Set_Has_Controlled_Component (T, Has_Controlled_Component 5194 (Element_Type) 5195 or else 5196 Is_Controlled (Element_Type)); 5197 Set_Finalize_Storage_Only (T, Finalize_Storage_Only 5198 (Element_Type)); 5199 end if; 5200 5201 -- Common attributes for both cases 5202 5203 Set_Component_Type (Base_Type (T), Element_Type); 5204 Set_Packed_Array_Type (T, Empty); 5205 5206 if Aliased_Present (Component_Definition (Def)) then 5207 Check_SPARK_Restriction 5208 ("aliased is not allowed", Component_Definition (Def)); 5209 Set_Has_Aliased_Components (Etype (T)); 5210 end if; 5211 5212 -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the 5213 -- array type to ensure that objects of this type are initialized. 5214 5215 if Ada_Version >= Ada_2005 5216 and then Can_Never_Be_Null (Element_Type) 5217 then 5218 Set_Can_Never_Be_Null (T); 5219 5220 if Null_Exclusion_Present (Component_Definition (Def)) 5221 5222 -- No need to check itypes because in their case this check was 5223 -- done at their point of creation 5224 5225 and then not Is_Itype (Element_Type) 5226 then 5227 Error_Msg_N 5228 ("`NOT NULL` not allowed (null already excluded)", 5229 Subtype_Indication (Component_Definition (Def))); 5230 end if; 5231 end if; 5232 5233 Priv := Private_Component (Element_Type); 5234 5235 if Present (Priv) then 5236 5237 -- Check for circular definitions 5238 5239 if Priv = Any_Type then 5240 Set_Component_Type (Etype (T), Any_Type); 5241 5242 -- There is a gap in the visibility of operations on the composite 5243 -- type only if the component type is defined in a different scope. 5244 5245 elsif Scope (Priv) = Current_Scope then 5246 null; 5247 5248 elsif Is_Limited_Type (Priv) then 5249 Set_Is_Limited_Composite (Etype (T)); 5250 Set_Is_Limited_Composite (T); 5251 else 5252 Set_Is_Private_Composite (Etype (T)); 5253 Set_Is_Private_Composite (T); 5254 end if; 5255 end if; 5256 5257 -- A syntax error in the declaration itself may lead to an empty index 5258 -- list, in which case do a minimal patch. 5259 5260 if No (First_Index (T)) then 5261 Error_Msg_N ("missing index definition in array type declaration", T); 5262 5263 declare 5264 Indexes : constant List_Id := 5265 New_List (New_Occurrence_Of (Any_Id, Sloc (T))); 5266 begin 5267 Set_Discrete_Subtype_Definitions (Def, Indexes); 5268 Set_First_Index (T, First (Indexes)); 5269 return; 5270 end; 5271 end if; 5272 5273 -- Create a concatenation operator for the new type. Internal array 5274 -- types created for packed entities do not need such, they are 5275 -- compatible with the user-defined type. 5276 5277 if Number_Dimensions (T) = 1 5278 and then not Is_Packed_Array_Type (T) 5279 then 5280 New_Concatenation_Op (T); 5281 end if; 5282 5283 -- In the case of an unconstrained array the parser has already verified 5284 -- that all the indexes are unconstrained but we still need to make sure 5285 -- that the element type is constrained. 5286 5287 if Is_Indefinite_Subtype (Element_Type) then 5288 Error_Msg_N 5289 ("unconstrained element type in array declaration", 5290 Subtype_Indication (Component_Def)); 5291 5292 elsif Is_Abstract_Type (Element_Type) then 5293 Error_Msg_N 5294 ("the type of a component cannot be abstract", 5295 Subtype_Indication (Component_Def)); 5296 end if; 5297 5298 -- There may be an invariant declared for the component type, but 5299 -- the construction of the component invariant checking procedure 5300 -- takes place during expansion. 5301 end Array_Type_Declaration; 5302 5303 ------------------------------------------------------ 5304 -- Replace_Anonymous_Access_To_Protected_Subprogram -- 5305 ------------------------------------------------------ 5306 5307 function Replace_Anonymous_Access_To_Protected_Subprogram 5308 (N : Node_Id) return Entity_Id 5309 is 5310 Loc : constant Source_Ptr := Sloc (N); 5311 5312 Curr_Scope : constant Scope_Stack_Entry := 5313 Scope_Stack.Table (Scope_Stack.Last); 5314 5315 Anon : constant Entity_Id := Make_Temporary (Loc, 'S'); 5316 5317 Acc : Node_Id; 5318 -- Access definition in declaration 5319 5320 Comp : Node_Id; 5321 -- Object definition or formal definition with an access definition 5322 5323 Decl : Node_Id; 5324 -- Declaration of anonymous access to subprogram type 5325 5326 Spec : Node_Id; 5327 -- Original specification in access to subprogram 5328 5329 P : Node_Id; 5330 5331 begin 5332 Set_Is_Internal (Anon); 5333 5334 case Nkind (N) is 5335 when N_Component_Declaration | 5336 N_Unconstrained_Array_Definition | 5337 N_Constrained_Array_Definition => 5338 Comp := Component_Definition (N); 5339 Acc := Access_Definition (Comp); 5340 5341 when N_Discriminant_Specification => 5342 Comp := Discriminant_Type (N); 5343 Acc := Comp; 5344 5345 when N_Parameter_Specification => 5346 Comp := Parameter_Type (N); 5347 Acc := Comp; 5348 5349 when N_Access_Function_Definition => 5350 Comp := Result_Definition (N); 5351 Acc := Comp; 5352 5353 when N_Object_Declaration => 5354 Comp := Object_Definition (N); 5355 Acc := Comp; 5356 5357 when N_Function_Specification => 5358 Comp := Result_Definition (N); 5359 Acc := Comp; 5360 5361 when others => 5362 raise Program_Error; 5363 end case; 5364 5365 Spec := Access_To_Subprogram_Definition (Acc); 5366 5367 Decl := 5368 Make_Full_Type_Declaration (Loc, 5369 Defining_Identifier => Anon, 5370 Type_Definition => Copy_Separate_Tree (Spec)); 5371 5372 Mark_Rewrite_Insertion (Decl); 5373 5374 -- In ASIS mode, analyze the profile on the original node, because 5375 -- the separate copy does not provide enough links to recover the 5376 -- original tree. Analysis is limited to type annotations, within 5377 -- a temporary scope that serves as an anonymous subprogram to collect 5378 -- otherwise useless temporaries and itypes. 5379 5380 if ASIS_Mode then 5381 declare 5382 Typ : constant Entity_Id := Make_Temporary (Loc, 'S'); 5383 5384 begin 5385 if Nkind (Spec) = N_Access_Function_Definition then 5386 Set_Ekind (Typ, E_Function); 5387 else 5388 Set_Ekind (Typ, E_Procedure); 5389 end if; 5390 5391 Set_Parent (Typ, N); 5392 Set_Scope (Typ, Current_Scope); 5393 Push_Scope (Typ); 5394 5395 Process_Formals (Parameter_Specifications (Spec), Spec); 5396 5397 if Nkind (Spec) = N_Access_Function_Definition then 5398 declare 5399 Def : constant Node_Id := Result_Definition (Spec); 5400 5401 begin 5402 -- The result might itself be an anonymous access type, so 5403 -- have to recurse. 5404 5405 if Nkind (Def) = N_Access_Definition then 5406 if Present (Access_To_Subprogram_Definition (Def)) then 5407 Set_Etype 5408 (Def, 5409 Replace_Anonymous_Access_To_Protected_Subprogram 5410 (Spec)); 5411 else 5412 Find_Type (Subtype_Mark (Def)); 5413 end if; 5414 5415 else 5416 Find_Type (Def); 5417 end if; 5418 end; 5419 end if; 5420 5421 End_Scope; 5422 end; 5423 end if; 5424 5425 -- Insert the new declaration in the nearest enclosing scope. If the 5426 -- node is a body and N is its return type, the declaration belongs in 5427 -- the enclosing scope. 5428 5429 P := Parent (N); 5430 5431 if Nkind (P) = N_Subprogram_Body 5432 and then Nkind (N) = N_Function_Specification 5433 then 5434 P := Parent (P); 5435 end if; 5436 5437 while Present (P) and then not Has_Declarations (P) loop 5438 P := Parent (P); 5439 end loop; 5440 5441 pragma Assert (Present (P)); 5442 5443 if Nkind (P) = N_Package_Specification then 5444 Prepend (Decl, Visible_Declarations (P)); 5445 else 5446 Prepend (Decl, Declarations (P)); 5447 end if; 5448 5449 -- Replace the anonymous type with an occurrence of the new declaration. 5450 -- In all cases the rewritten node does not have the null-exclusion 5451 -- attribute because (if present) it was already inherited by the 5452 -- anonymous entity (Anon). Thus, in case of components we do not 5453 -- inherit this attribute. 5454 5455 if Nkind (N) = N_Parameter_Specification then 5456 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 5457 Set_Etype (Defining_Identifier (N), Anon); 5458 Set_Null_Exclusion_Present (N, False); 5459 5460 elsif Nkind (N) = N_Object_Declaration then 5461 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 5462 Set_Etype (Defining_Identifier (N), Anon); 5463 5464 elsif Nkind (N) = N_Access_Function_Definition then 5465 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 5466 5467 elsif Nkind (N) = N_Function_Specification then 5468 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 5469 Set_Etype (Defining_Unit_Name (N), Anon); 5470 5471 else 5472 Rewrite (Comp, 5473 Make_Component_Definition (Loc, 5474 Subtype_Indication => New_Occurrence_Of (Anon, Loc))); 5475 end if; 5476 5477 Mark_Rewrite_Insertion (Comp); 5478 5479 if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then 5480 Analyze (Decl); 5481 5482 else 5483 -- Temporarily remove the current scope (record or subprogram) from 5484 -- the stack to add the new declarations to the enclosing scope. 5485 5486 Scope_Stack.Decrement_Last; 5487 Analyze (Decl); 5488 Set_Is_Itype (Anon); 5489 Scope_Stack.Append (Curr_Scope); 5490 end if; 5491 5492 Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type); 5493 Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target); 5494 return Anon; 5495 end Replace_Anonymous_Access_To_Protected_Subprogram; 5496 5497 ------------------------------- 5498 -- Build_Derived_Access_Type -- 5499 ------------------------------- 5500 5501 procedure Build_Derived_Access_Type 5502 (N : Node_Id; 5503 Parent_Type : Entity_Id; 5504 Derived_Type : Entity_Id) 5505 is 5506 S : constant Node_Id := Subtype_Indication (Type_Definition (N)); 5507 5508 Desig_Type : Entity_Id; 5509 Discr : Entity_Id; 5510 Discr_Con_Elist : Elist_Id; 5511 Discr_Con_El : Elmt_Id; 5512 Subt : Entity_Id; 5513 5514 begin 5515 -- Set the designated type so it is available in case this is an access 5516 -- to a self-referential type, e.g. a standard list type with a next 5517 -- pointer. Will be reset after subtype is built. 5518 5519 Set_Directly_Designated_Type 5520 (Derived_Type, Designated_Type (Parent_Type)); 5521 5522 Subt := Process_Subtype (S, N); 5523 5524 if Nkind (S) /= N_Subtype_Indication 5525 and then Subt /= Base_Type (Subt) 5526 then 5527 Set_Ekind (Derived_Type, E_Access_Subtype); 5528 end if; 5529 5530 if Ekind (Derived_Type) = E_Access_Subtype then 5531 declare 5532 Pbase : constant Entity_Id := Base_Type (Parent_Type); 5533 Ibase : constant Entity_Id := 5534 Create_Itype (Ekind (Pbase), N, Derived_Type, 'B'); 5535 Svg_Chars : constant Name_Id := Chars (Ibase); 5536 Svg_Next_E : constant Entity_Id := Next_Entity (Ibase); 5537 5538 begin 5539 Copy_Node (Pbase, Ibase); 5540 5541 Set_Chars (Ibase, Svg_Chars); 5542 Set_Next_Entity (Ibase, Svg_Next_E); 5543 Set_Sloc (Ibase, Sloc (Derived_Type)); 5544 Set_Scope (Ibase, Scope (Derived_Type)); 5545 Set_Freeze_Node (Ibase, Empty); 5546 Set_Is_Frozen (Ibase, False); 5547 Set_Comes_From_Source (Ibase, False); 5548 Set_Is_First_Subtype (Ibase, False); 5549 5550 Set_Etype (Ibase, Pbase); 5551 Set_Etype (Derived_Type, Ibase); 5552 end; 5553 end if; 5554 5555 Set_Directly_Designated_Type 5556 (Derived_Type, Designated_Type (Subt)); 5557 5558 Set_Is_Constrained (Derived_Type, Is_Constrained (Subt)); 5559 Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type)); 5560 Set_Size_Info (Derived_Type, Parent_Type); 5561 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 5562 Set_Depends_On_Private (Derived_Type, 5563 Has_Private_Component (Derived_Type)); 5564 Conditional_Delay (Derived_Type, Subt); 5565 5566 -- Ada 2005 (AI-231): Set the null-exclusion attribute, and verify 5567 -- that it is not redundant. 5568 5569 if Null_Exclusion_Present (Type_Definition (N)) then 5570 Set_Can_Never_Be_Null (Derived_Type); 5571 5572 if Can_Never_Be_Null (Parent_Type) 5573 and then False 5574 then 5575 Error_Msg_NE 5576 ("`NOT NULL` not allowed (& already excludes null)", 5577 N, Parent_Type); 5578 end if; 5579 5580 elsif Can_Never_Be_Null (Parent_Type) then 5581 Set_Can_Never_Be_Null (Derived_Type); 5582 end if; 5583 5584 -- Note: we do not copy the Storage_Size_Variable, since we always go to 5585 -- the root type for this information. 5586 5587 -- Apply range checks to discriminants for derived record case 5588 -- ??? THIS CODE SHOULD NOT BE HERE REALLY. 5589 5590 Desig_Type := Designated_Type (Derived_Type); 5591 if Is_Composite_Type (Desig_Type) 5592 and then (not Is_Array_Type (Desig_Type)) 5593 and then Has_Discriminants (Desig_Type) 5594 and then Base_Type (Desig_Type) /= Desig_Type 5595 then 5596 Discr_Con_Elist := Discriminant_Constraint (Desig_Type); 5597 Discr_Con_El := First_Elmt (Discr_Con_Elist); 5598 5599 Discr := First_Discriminant (Base_Type (Desig_Type)); 5600 while Present (Discr_Con_El) loop 5601 Apply_Range_Check (Node (Discr_Con_El), Etype (Discr)); 5602 Next_Elmt (Discr_Con_El); 5603 Next_Discriminant (Discr); 5604 end loop; 5605 end if; 5606 end Build_Derived_Access_Type; 5607 5608 ------------------------------ 5609 -- Build_Derived_Array_Type -- 5610 ------------------------------ 5611 5612 procedure Build_Derived_Array_Type 5613 (N : Node_Id; 5614 Parent_Type : Entity_Id; 5615 Derived_Type : Entity_Id) 5616 is 5617 Loc : constant Source_Ptr := Sloc (N); 5618 Tdef : constant Node_Id := Type_Definition (N); 5619 Indic : constant Node_Id := Subtype_Indication (Tdef); 5620 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 5621 Implicit_Base : Entity_Id; 5622 New_Indic : Node_Id; 5623 5624 procedure Make_Implicit_Base; 5625 -- If the parent subtype is constrained, the derived type is a subtype 5626 -- of an implicit base type derived from the parent base. 5627 5628 ------------------------ 5629 -- Make_Implicit_Base -- 5630 ------------------------ 5631 5632 procedure Make_Implicit_Base is 5633 begin 5634 Implicit_Base := 5635 Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); 5636 5637 Set_Ekind (Implicit_Base, Ekind (Parent_Base)); 5638 Set_Etype (Implicit_Base, Parent_Base); 5639 5640 Copy_Array_Subtype_Attributes (Implicit_Base, Parent_Base); 5641 Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base); 5642 5643 Set_Has_Delayed_Freeze (Implicit_Base, True); 5644 end Make_Implicit_Base; 5645 5646 -- Start of processing for Build_Derived_Array_Type 5647 5648 begin 5649 if not Is_Constrained (Parent_Type) then 5650 if Nkind (Indic) /= N_Subtype_Indication then 5651 Set_Ekind (Derived_Type, E_Array_Type); 5652 5653 Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); 5654 Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type); 5655 5656 Set_Has_Delayed_Freeze (Derived_Type, True); 5657 5658 else 5659 Make_Implicit_Base; 5660 Set_Etype (Derived_Type, Implicit_Base); 5661 5662 New_Indic := 5663 Make_Subtype_Declaration (Loc, 5664 Defining_Identifier => Derived_Type, 5665 Subtype_Indication => 5666 Make_Subtype_Indication (Loc, 5667 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc), 5668 Constraint => Constraint (Indic))); 5669 5670 Rewrite (N, New_Indic); 5671 Analyze (N); 5672 end if; 5673 5674 else 5675 if Nkind (Indic) /= N_Subtype_Indication then 5676 Make_Implicit_Base; 5677 5678 Set_Ekind (Derived_Type, Ekind (Parent_Type)); 5679 Set_Etype (Derived_Type, Implicit_Base); 5680 Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); 5681 5682 else 5683 Error_Msg_N ("illegal constraint on constrained type", Indic); 5684 end if; 5685 end if; 5686 5687 -- If parent type is not a derived type itself, and is declared in 5688 -- closed scope (e.g. a subprogram), then we must explicitly introduce 5689 -- the new type's concatenation operator since Derive_Subprograms 5690 -- will not inherit the parent's operator. If the parent type is 5691 -- unconstrained, the operator is of the unconstrained base type. 5692 5693 if Number_Dimensions (Parent_Type) = 1 5694 and then not Is_Limited_Type (Parent_Type) 5695 and then not Is_Derived_Type (Parent_Type) 5696 and then not Is_Package_Or_Generic_Package 5697 (Scope (Base_Type (Parent_Type))) 5698 then 5699 if not Is_Constrained (Parent_Type) 5700 and then Is_Constrained (Derived_Type) 5701 then 5702 New_Concatenation_Op (Implicit_Base); 5703 else 5704 New_Concatenation_Op (Derived_Type); 5705 end if; 5706 end if; 5707 end Build_Derived_Array_Type; 5708 5709 ----------------------------------- 5710 -- Build_Derived_Concurrent_Type -- 5711 ----------------------------------- 5712 5713 procedure Build_Derived_Concurrent_Type 5714 (N : Node_Id; 5715 Parent_Type : Entity_Id; 5716 Derived_Type : Entity_Id) 5717 is 5718 Loc : constant Source_Ptr := Sloc (N); 5719 5720 Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C'); 5721 Corr_Decl : Node_Id; 5722 Corr_Decl_Needed : Boolean; 5723 -- If the derived type has fewer discriminants than its parent, the 5724 -- corresponding record is also a derived type, in order to account for 5725 -- the bound discriminants. We create a full type declaration for it in 5726 -- this case. 5727 5728 Constraint_Present : constant Boolean := 5729 Nkind (Subtype_Indication (Type_Definition (N))) = 5730 N_Subtype_Indication; 5731 5732 D_Constraint : Node_Id; 5733 New_Constraint : Elist_Id; 5734 Old_Disc : Entity_Id; 5735 New_Disc : Entity_Id; 5736 New_N : Node_Id; 5737 5738 begin 5739 Set_Stored_Constraint (Derived_Type, No_Elist); 5740 Corr_Decl_Needed := False; 5741 Old_Disc := Empty; 5742 5743 if Present (Discriminant_Specifications (N)) 5744 and then Constraint_Present 5745 then 5746 Old_Disc := First_Discriminant (Parent_Type); 5747 New_Disc := First (Discriminant_Specifications (N)); 5748 while Present (New_Disc) and then Present (Old_Disc) loop 5749 Next_Discriminant (Old_Disc); 5750 Next (New_Disc); 5751 end loop; 5752 end if; 5753 5754 if Present (Old_Disc) and then Expander_Active then 5755 5756 -- The new type has fewer discriminants, so we need to create a new 5757 -- corresponding record, which is derived from the corresponding 5758 -- record of the parent, and has a stored constraint that captures 5759 -- the values of the discriminant constraints. The corresponding 5760 -- record is needed only if expander is active and code generation is 5761 -- enabled. 5762 5763 -- The type declaration for the derived corresponding record has the 5764 -- same discriminant part and constraints as the current declaration. 5765 -- Copy the unanalyzed tree to build declaration. 5766 5767 Corr_Decl_Needed := True; 5768 New_N := Copy_Separate_Tree (N); 5769 5770 Corr_Decl := 5771 Make_Full_Type_Declaration (Loc, 5772 Defining_Identifier => Corr_Record, 5773 Discriminant_Specifications => 5774 Discriminant_Specifications (New_N), 5775 Type_Definition => 5776 Make_Derived_Type_Definition (Loc, 5777 Subtype_Indication => 5778 Make_Subtype_Indication (Loc, 5779 Subtype_Mark => 5780 New_Occurrence_Of 5781 (Corresponding_Record_Type (Parent_Type), Loc), 5782 Constraint => 5783 Constraint 5784 (Subtype_Indication (Type_Definition (New_N)))))); 5785 end if; 5786 5787 -- Copy Storage_Size and Relative_Deadline variables if task case 5788 5789 if Is_Task_Type (Parent_Type) then 5790 Set_Storage_Size_Variable (Derived_Type, 5791 Storage_Size_Variable (Parent_Type)); 5792 Set_Relative_Deadline_Variable (Derived_Type, 5793 Relative_Deadline_Variable (Parent_Type)); 5794 end if; 5795 5796 if Present (Discriminant_Specifications (N)) then 5797 Push_Scope (Derived_Type); 5798 Check_Or_Process_Discriminants (N, Derived_Type); 5799 5800 if Constraint_Present then 5801 New_Constraint := 5802 Expand_To_Stored_Constraint 5803 (Parent_Type, 5804 Build_Discriminant_Constraints 5805 (Parent_Type, 5806 Subtype_Indication (Type_Definition (N)), True)); 5807 end if; 5808 5809 End_Scope; 5810 5811 elsif Constraint_Present then 5812 5813 -- Build constrained subtype, copying the constraint, and derive 5814 -- from it to create a derived constrained type. 5815 5816 declare 5817 Loc : constant Source_Ptr := Sloc (N); 5818 Anon : constant Entity_Id := 5819 Make_Defining_Identifier (Loc, 5820 Chars => New_External_Name (Chars (Derived_Type), 'T')); 5821 Decl : Node_Id; 5822 5823 begin 5824 Decl := 5825 Make_Subtype_Declaration (Loc, 5826 Defining_Identifier => Anon, 5827 Subtype_Indication => 5828 New_Copy_Tree (Subtype_Indication (Type_Definition (N)))); 5829 Insert_Before (N, Decl); 5830 Analyze (Decl); 5831 5832 Rewrite (Subtype_Indication (Type_Definition (N)), 5833 New_Occurrence_Of (Anon, Loc)); 5834 Set_Analyzed (Derived_Type, False); 5835 Analyze (N); 5836 return; 5837 end; 5838 end if; 5839 5840 -- By default, operations and private data are inherited from parent. 5841 -- However, in the presence of bound discriminants, a new corresponding 5842 -- record will be created, see below. 5843 5844 Set_Has_Discriminants 5845 (Derived_Type, Has_Discriminants (Parent_Type)); 5846 Set_Corresponding_Record_Type 5847 (Derived_Type, Corresponding_Record_Type (Parent_Type)); 5848 5849 -- Is_Constrained is set according the parent subtype, but is set to 5850 -- False if the derived type is declared with new discriminants. 5851 5852 Set_Is_Constrained 5853 (Derived_Type, 5854 (Is_Constrained (Parent_Type) or else Constraint_Present) 5855 and then not Present (Discriminant_Specifications (N))); 5856 5857 if Constraint_Present then 5858 if not Has_Discriminants (Parent_Type) then 5859 Error_Msg_N ("untagged parent must have discriminants", N); 5860 5861 elsif Present (Discriminant_Specifications (N)) then 5862 5863 -- Verify that new discriminants are used to constrain old ones 5864 5865 D_Constraint := 5866 First 5867 (Constraints 5868 (Constraint (Subtype_Indication (Type_Definition (N))))); 5869 5870 Old_Disc := First_Discriminant (Parent_Type); 5871 5872 while Present (D_Constraint) loop 5873 if Nkind (D_Constraint) /= N_Discriminant_Association then 5874 5875 -- Positional constraint. If it is a reference to a new 5876 -- discriminant, it constrains the corresponding old one. 5877 5878 if Nkind (D_Constraint) = N_Identifier then 5879 New_Disc := First_Discriminant (Derived_Type); 5880 while Present (New_Disc) loop 5881 exit when Chars (New_Disc) = Chars (D_Constraint); 5882 Next_Discriminant (New_Disc); 5883 end loop; 5884 5885 if Present (New_Disc) then 5886 Set_Corresponding_Discriminant (New_Disc, Old_Disc); 5887 end if; 5888 end if; 5889 5890 Next_Discriminant (Old_Disc); 5891 5892 -- if this is a named constraint, search by name for the old 5893 -- discriminants constrained by the new one. 5894 5895 elsif Nkind (Expression (D_Constraint)) = N_Identifier then 5896 5897 -- Find new discriminant with that name 5898 5899 New_Disc := First_Discriminant (Derived_Type); 5900 while Present (New_Disc) loop 5901 exit when 5902 Chars (New_Disc) = Chars (Expression (D_Constraint)); 5903 Next_Discriminant (New_Disc); 5904 end loop; 5905 5906 if Present (New_Disc) then 5907 5908 -- Verify that new discriminant renames some discriminant 5909 -- of the parent type, and associate the new discriminant 5910 -- with one or more old ones that it renames. 5911 5912 declare 5913 Selector : Node_Id; 5914 5915 begin 5916 Selector := First (Selector_Names (D_Constraint)); 5917 while Present (Selector) loop 5918 Old_Disc := First_Discriminant (Parent_Type); 5919 while Present (Old_Disc) loop 5920 exit when Chars (Old_Disc) = Chars (Selector); 5921 Next_Discriminant (Old_Disc); 5922 end loop; 5923 5924 if Present (Old_Disc) then 5925 Set_Corresponding_Discriminant 5926 (New_Disc, Old_Disc); 5927 end if; 5928 5929 Next (Selector); 5930 end loop; 5931 end; 5932 end if; 5933 end if; 5934 5935 Next (D_Constraint); 5936 end loop; 5937 5938 New_Disc := First_Discriminant (Derived_Type); 5939 while Present (New_Disc) loop 5940 if No (Corresponding_Discriminant (New_Disc)) then 5941 Error_Msg_NE 5942 ("new discriminant& must constrain old one", N, New_Disc); 5943 5944 elsif not 5945 Subtypes_Statically_Compatible 5946 (Etype (New_Disc), 5947 Etype (Corresponding_Discriminant (New_Disc))) 5948 then 5949 Error_Msg_NE 5950 ("& not statically compatible with parent discriminant", 5951 N, New_Disc); 5952 end if; 5953 5954 Next_Discriminant (New_Disc); 5955 end loop; 5956 end if; 5957 5958 elsif Present (Discriminant_Specifications (N)) then 5959 Error_Msg_N 5960 ("missing discriminant constraint in untagged derivation", N); 5961 end if; 5962 5963 -- The entity chain of the derived type includes the new discriminants 5964 -- but shares operations with the parent. 5965 5966 if Present (Discriminant_Specifications (N)) then 5967 Old_Disc := First_Discriminant (Parent_Type); 5968 while Present (Old_Disc) loop 5969 if No (Next_Entity (Old_Disc)) 5970 or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant 5971 then 5972 Set_Next_Entity 5973 (Last_Entity (Derived_Type), Next_Entity (Old_Disc)); 5974 exit; 5975 end if; 5976 5977 Next_Discriminant (Old_Disc); 5978 end loop; 5979 5980 else 5981 Set_First_Entity (Derived_Type, First_Entity (Parent_Type)); 5982 if Has_Discriminants (Parent_Type) then 5983 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 5984 Set_Discriminant_Constraint ( 5985 Derived_Type, Discriminant_Constraint (Parent_Type)); 5986 end if; 5987 end if; 5988 5989 Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type)); 5990 5991 Set_Has_Completion (Derived_Type); 5992 5993 if Corr_Decl_Needed then 5994 Set_Stored_Constraint (Derived_Type, New_Constraint); 5995 Insert_After (N, Corr_Decl); 5996 Analyze (Corr_Decl); 5997 Set_Corresponding_Record_Type (Derived_Type, Corr_Record); 5998 end if; 5999 end Build_Derived_Concurrent_Type; 6000 6001 ------------------------------------ 6002 -- Build_Derived_Enumeration_Type -- 6003 ------------------------------------ 6004 6005 procedure Build_Derived_Enumeration_Type 6006 (N : Node_Id; 6007 Parent_Type : Entity_Id; 6008 Derived_Type : Entity_Id) 6009 is 6010 Loc : constant Source_Ptr := Sloc (N); 6011 Def : constant Node_Id := Type_Definition (N); 6012 Indic : constant Node_Id := Subtype_Indication (Def); 6013 Implicit_Base : Entity_Id; 6014 Literal : Entity_Id; 6015 New_Lit : Entity_Id; 6016 Literals_List : List_Id; 6017 Type_Decl : Node_Id; 6018 Hi, Lo : Node_Id; 6019 Rang_Expr : Node_Id; 6020 6021 begin 6022 -- Since types Standard.Character and Standard.[Wide_]Wide_Character do 6023 -- not have explicit literals lists we need to process types derived 6024 -- from them specially. This is handled by Derived_Standard_Character. 6025 -- If the parent type is a generic type, there are no literals either, 6026 -- and we construct the same skeletal representation as for the generic 6027 -- parent type. 6028 6029 if Is_Standard_Character_Type (Parent_Type) then 6030 Derived_Standard_Character (N, Parent_Type, Derived_Type); 6031 6032 elsif Is_Generic_Type (Root_Type (Parent_Type)) then 6033 declare 6034 Lo : Node_Id; 6035 Hi : Node_Id; 6036 6037 begin 6038 if Nkind (Indic) /= N_Subtype_Indication then 6039 Lo := 6040 Make_Attribute_Reference (Loc, 6041 Attribute_Name => Name_First, 6042 Prefix => New_Occurrence_Of (Derived_Type, Loc)); 6043 Set_Etype (Lo, Derived_Type); 6044 6045 Hi := 6046 Make_Attribute_Reference (Loc, 6047 Attribute_Name => Name_Last, 6048 Prefix => New_Occurrence_Of (Derived_Type, Loc)); 6049 Set_Etype (Hi, Derived_Type); 6050 6051 Set_Scalar_Range (Derived_Type, 6052 Make_Range (Loc, 6053 Low_Bound => Lo, 6054 High_Bound => Hi)); 6055 else 6056 6057 -- Analyze subtype indication and verify compatibility 6058 -- with parent type. 6059 6060 if Base_Type (Process_Subtype (Indic, N)) /= 6061 Base_Type (Parent_Type) 6062 then 6063 Error_Msg_N 6064 ("illegal constraint for formal discrete type", N); 6065 end if; 6066 end if; 6067 end; 6068 6069 else 6070 -- If a constraint is present, analyze the bounds to catch 6071 -- premature usage of the derived literals. 6072 6073 if Nkind (Indic) = N_Subtype_Indication 6074 and then Nkind (Range_Expression (Constraint (Indic))) = N_Range 6075 then 6076 Analyze (Low_Bound (Range_Expression (Constraint (Indic)))); 6077 Analyze (High_Bound (Range_Expression (Constraint (Indic)))); 6078 end if; 6079 6080 -- Introduce an implicit base type for the derived type even if there 6081 -- is no constraint attached to it, since this seems closer to the 6082 -- Ada semantics. Build a full type declaration tree for the derived 6083 -- type using the implicit base type as the defining identifier. The 6084 -- build a subtype declaration tree which applies the constraint (if 6085 -- any) have it replace the derived type declaration. 6086 6087 Literal := First_Literal (Parent_Type); 6088 Literals_List := New_List; 6089 while Present (Literal) 6090 and then Ekind (Literal) = E_Enumeration_Literal 6091 loop 6092 -- Literals of the derived type have the same representation as 6093 -- those of the parent type, but this representation can be 6094 -- overridden by an explicit representation clause. Indicate 6095 -- that there is no explicit representation given yet. These 6096 -- derived literals are implicit operations of the new type, 6097 -- and can be overridden by explicit ones. 6098 6099 if Nkind (Literal) = N_Defining_Character_Literal then 6100 New_Lit := 6101 Make_Defining_Character_Literal (Loc, Chars (Literal)); 6102 else 6103 New_Lit := Make_Defining_Identifier (Loc, Chars (Literal)); 6104 end if; 6105 6106 Set_Ekind (New_Lit, E_Enumeration_Literal); 6107 Set_Enumeration_Pos (New_Lit, Enumeration_Pos (Literal)); 6108 Set_Enumeration_Rep (New_Lit, Enumeration_Rep (Literal)); 6109 Set_Enumeration_Rep_Expr (New_Lit, Empty); 6110 Set_Alias (New_Lit, Literal); 6111 Set_Is_Known_Valid (New_Lit, True); 6112 6113 Append (New_Lit, Literals_List); 6114 Next_Literal (Literal); 6115 end loop; 6116 6117 Implicit_Base := 6118 Make_Defining_Identifier (Sloc (Derived_Type), 6119 Chars => New_External_Name (Chars (Derived_Type), 'B')); 6120 6121 -- Indicate the proper nature of the derived type. This must be done 6122 -- before analysis of the literals, to recognize cases when a literal 6123 -- may be hidden by a previous explicit function definition (cf. 6124 -- c83031a). 6125 6126 Set_Ekind (Derived_Type, E_Enumeration_Subtype); 6127 Set_Etype (Derived_Type, Implicit_Base); 6128 6129 Type_Decl := 6130 Make_Full_Type_Declaration (Loc, 6131 Defining_Identifier => Implicit_Base, 6132 Discriminant_Specifications => No_List, 6133 Type_Definition => 6134 Make_Enumeration_Type_Definition (Loc, Literals_List)); 6135 6136 Mark_Rewrite_Insertion (Type_Decl); 6137 Insert_Before (N, Type_Decl); 6138 Analyze (Type_Decl); 6139 6140 -- After the implicit base is analyzed its Etype needs to be changed 6141 -- to reflect the fact that it is derived from the parent type which 6142 -- was ignored during analysis. We also set the size at this point. 6143 6144 Set_Etype (Implicit_Base, Parent_Type); 6145 6146 Set_Size_Info (Implicit_Base, Parent_Type); 6147 Set_RM_Size (Implicit_Base, RM_Size (Parent_Type)); 6148 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type)); 6149 6150 -- Copy other flags from parent type 6151 6152 Set_Has_Non_Standard_Rep 6153 (Implicit_Base, Has_Non_Standard_Rep 6154 (Parent_Type)); 6155 Set_Has_Pragma_Ordered 6156 (Implicit_Base, Has_Pragma_Ordered 6157 (Parent_Type)); 6158 Set_Has_Delayed_Freeze (Implicit_Base); 6159 6160 -- Process the subtype indication including a validation check on the 6161 -- constraint, if any. If a constraint is given, its bounds must be 6162 -- implicitly converted to the new type. 6163 6164 if Nkind (Indic) = N_Subtype_Indication then 6165 declare 6166 R : constant Node_Id := 6167 Range_Expression (Constraint (Indic)); 6168 6169 begin 6170 if Nkind (R) = N_Range then 6171 Hi := Build_Scalar_Bound 6172 (High_Bound (R), Parent_Type, Implicit_Base); 6173 Lo := Build_Scalar_Bound 6174 (Low_Bound (R), Parent_Type, Implicit_Base); 6175 6176 else 6177 -- Constraint is a Range attribute. Replace with explicit 6178 -- mention of the bounds of the prefix, which must be a 6179 -- subtype. 6180 6181 Analyze (Prefix (R)); 6182 Hi := 6183 Convert_To (Implicit_Base, 6184 Make_Attribute_Reference (Loc, 6185 Attribute_Name => Name_Last, 6186 Prefix => 6187 New_Occurrence_Of (Entity (Prefix (R)), Loc))); 6188 6189 Lo := 6190 Convert_To (Implicit_Base, 6191 Make_Attribute_Reference (Loc, 6192 Attribute_Name => Name_First, 6193 Prefix => 6194 New_Occurrence_Of (Entity (Prefix (R)), Loc))); 6195 end if; 6196 end; 6197 6198 else 6199 Hi := 6200 Build_Scalar_Bound 6201 (Type_High_Bound (Parent_Type), 6202 Parent_Type, Implicit_Base); 6203 Lo := 6204 Build_Scalar_Bound 6205 (Type_Low_Bound (Parent_Type), 6206 Parent_Type, Implicit_Base); 6207 end if; 6208 6209 Rang_Expr := 6210 Make_Range (Loc, 6211 Low_Bound => Lo, 6212 High_Bound => Hi); 6213 6214 -- If we constructed a default range for the case where no range 6215 -- was given, then the expressions in the range must not freeze 6216 -- since they do not correspond to expressions in the source. 6217 6218 if Nkind (Indic) /= N_Subtype_Indication then 6219 Set_Must_Not_Freeze (Lo); 6220 Set_Must_Not_Freeze (Hi); 6221 Set_Must_Not_Freeze (Rang_Expr); 6222 end if; 6223 6224 Rewrite (N, 6225 Make_Subtype_Declaration (Loc, 6226 Defining_Identifier => Derived_Type, 6227 Subtype_Indication => 6228 Make_Subtype_Indication (Loc, 6229 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc), 6230 Constraint => 6231 Make_Range_Constraint (Loc, 6232 Range_Expression => Rang_Expr)))); 6233 6234 Analyze (N); 6235 6236 -- Apply a range check. Since this range expression doesn't have an 6237 -- Etype, we have to specifically pass the Source_Typ parameter. Is 6238 -- this right??? 6239 6240 if Nkind (Indic) = N_Subtype_Indication then 6241 Apply_Range_Check (Range_Expression (Constraint (Indic)), 6242 Parent_Type, 6243 Source_Typ => Entity (Subtype_Mark (Indic))); 6244 end if; 6245 end if; 6246 end Build_Derived_Enumeration_Type; 6247 6248 -------------------------------- 6249 -- Build_Derived_Numeric_Type -- 6250 -------------------------------- 6251 6252 procedure Build_Derived_Numeric_Type 6253 (N : Node_Id; 6254 Parent_Type : Entity_Id; 6255 Derived_Type : Entity_Id) 6256 is 6257 Loc : constant Source_Ptr := Sloc (N); 6258 Tdef : constant Node_Id := Type_Definition (N); 6259 Indic : constant Node_Id := Subtype_Indication (Tdef); 6260 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 6261 No_Constraint : constant Boolean := Nkind (Indic) /= 6262 N_Subtype_Indication; 6263 Implicit_Base : Entity_Id; 6264 6265 Lo : Node_Id; 6266 Hi : Node_Id; 6267 6268 begin 6269 -- Process the subtype indication including a validation check on 6270 -- the constraint if any. 6271 6272 Discard_Node (Process_Subtype (Indic, N)); 6273 6274 -- Introduce an implicit base type for the derived type even if there 6275 -- is no constraint attached to it, since this seems closer to the Ada 6276 -- semantics. 6277 6278 Implicit_Base := 6279 Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); 6280 6281 Set_Etype (Implicit_Base, Parent_Base); 6282 Set_Ekind (Implicit_Base, Ekind (Parent_Base)); 6283 Set_Size_Info (Implicit_Base, Parent_Base); 6284 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base)); 6285 Set_Parent (Implicit_Base, Parent (Derived_Type)); 6286 Set_Is_Known_Valid (Implicit_Base, Is_Known_Valid (Parent_Base)); 6287 6288 -- Set RM Size for discrete type or decimal fixed-point type 6289 -- Ordinary fixed-point is excluded, why??? 6290 6291 if Is_Discrete_Type (Parent_Base) 6292 or else Is_Decimal_Fixed_Point_Type (Parent_Base) 6293 then 6294 Set_RM_Size (Implicit_Base, RM_Size (Parent_Base)); 6295 end if; 6296 6297 Set_Has_Delayed_Freeze (Implicit_Base); 6298 6299 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); 6300 Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); 6301 6302 Set_Scalar_Range (Implicit_Base, 6303 Make_Range (Loc, 6304 Low_Bound => Lo, 6305 High_Bound => Hi)); 6306 6307 if Has_Infinities (Parent_Base) then 6308 Set_Includes_Infinities (Scalar_Range (Implicit_Base)); 6309 end if; 6310 6311 -- The Derived_Type, which is the entity of the declaration, is a 6312 -- subtype of the implicit base. Its Ekind is a subtype, even in the 6313 -- absence of an explicit constraint. 6314 6315 Set_Etype (Derived_Type, Implicit_Base); 6316 6317 -- If we did not have a constraint, then the Ekind is set from the 6318 -- parent type (otherwise Process_Subtype has set the bounds) 6319 6320 if No_Constraint then 6321 Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type))); 6322 end if; 6323 6324 -- If we did not have a range constraint, then set the range from the 6325 -- parent type. Otherwise, the Process_Subtype call has set the bounds. 6326 6327 if No_Constraint 6328 or else not Has_Range_Constraint (Indic) 6329 then 6330 Set_Scalar_Range (Derived_Type, 6331 Make_Range (Loc, 6332 Low_Bound => New_Copy_Tree (Type_Low_Bound (Parent_Type)), 6333 High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type)))); 6334 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 6335 6336 if Has_Infinities (Parent_Type) then 6337 Set_Includes_Infinities (Scalar_Range (Derived_Type)); 6338 end if; 6339 6340 Set_Is_Known_Valid (Derived_Type, Is_Known_Valid (Parent_Type)); 6341 end if; 6342 6343 Set_Is_Descendent_Of_Address (Derived_Type, 6344 Is_Descendent_Of_Address (Parent_Type)); 6345 Set_Is_Descendent_Of_Address (Implicit_Base, 6346 Is_Descendent_Of_Address (Parent_Type)); 6347 6348 -- Set remaining type-specific fields, depending on numeric type 6349 6350 if Is_Modular_Integer_Type (Parent_Type) then 6351 Set_Modulus (Implicit_Base, Modulus (Parent_Base)); 6352 6353 Set_Non_Binary_Modulus 6354 (Implicit_Base, Non_Binary_Modulus (Parent_Base)); 6355 6356 Set_Is_Known_Valid 6357 (Implicit_Base, Is_Known_Valid (Parent_Base)); 6358 6359 elsif Is_Floating_Point_Type (Parent_Type) then 6360 6361 -- Digits of base type is always copied from the digits value of 6362 -- the parent base type, but the digits of the derived type will 6363 -- already have been set if there was a constraint present. 6364 6365 Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); 6366 Set_Float_Rep (Implicit_Base, Float_Rep (Parent_Base)); 6367 6368 if No_Constraint then 6369 Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type)); 6370 end if; 6371 6372 elsif Is_Fixed_Point_Type (Parent_Type) then 6373 6374 -- Small of base type and derived type are always copied from the 6375 -- parent base type, since smalls never change. The delta of the 6376 -- base type is also copied from the parent base type. However the 6377 -- delta of the derived type will have been set already if a 6378 -- constraint was present. 6379 6380 Set_Small_Value (Derived_Type, Small_Value (Parent_Base)); 6381 Set_Small_Value (Implicit_Base, Small_Value (Parent_Base)); 6382 Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base)); 6383 6384 if No_Constraint then 6385 Set_Delta_Value (Derived_Type, Delta_Value (Parent_Type)); 6386 end if; 6387 6388 -- The scale and machine radix in the decimal case are always 6389 -- copied from the parent base type. 6390 6391 if Is_Decimal_Fixed_Point_Type (Parent_Type) then 6392 Set_Scale_Value (Derived_Type, Scale_Value (Parent_Base)); 6393 Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base)); 6394 6395 Set_Machine_Radix_10 6396 (Derived_Type, Machine_Radix_10 (Parent_Base)); 6397 Set_Machine_Radix_10 6398 (Implicit_Base, Machine_Radix_10 (Parent_Base)); 6399 6400 Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); 6401 6402 if No_Constraint then 6403 Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base)); 6404 6405 else 6406 -- the analysis of the subtype_indication sets the 6407 -- digits value of the derived type. 6408 6409 null; 6410 end if; 6411 end if; 6412 end if; 6413 6414 if Is_Integer_Type (Parent_Type) then 6415 Set_Has_Shift_Operator 6416 (Implicit_Base, Has_Shift_Operator (Parent_Type)); 6417 end if; 6418 6419 -- The type of the bounds is that of the parent type, and they 6420 -- must be converted to the derived type. 6421 6422 Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); 6423 6424 -- The implicit_base should be frozen when the derived type is frozen, 6425 -- but note that it is used in the conversions of the bounds. For fixed 6426 -- types we delay the determination of the bounds until the proper 6427 -- freezing point. For other numeric types this is rejected by GCC, for 6428 -- reasons that are currently unclear (???), so we choose to freeze the 6429 -- implicit base now. In the case of integers and floating point types 6430 -- this is harmless because subsequent representation clauses cannot 6431 -- affect anything, but it is still baffling that we cannot use the 6432 -- same mechanism for all derived numeric types. 6433 6434 -- There is a further complication: actually some representation 6435 -- clauses can affect the implicit base type. For example, attribute 6436 -- definition clauses for stream-oriented attributes need to set the 6437 -- corresponding TSS entries on the base type, and this normally 6438 -- cannot be done after the base type is frozen, so the circuitry in 6439 -- Sem_Ch13.New_Stream_Subprogram must account for this possibility 6440 -- and not use Set_TSS in this case. 6441 6442 -- There are also consequences for the case of delayed representation 6443 -- aspects for some cases. For example, a Size aspect is delayed and 6444 -- should not be evaluated to the freeze point. This early freezing 6445 -- means that the size attribute evaluation happens too early??? 6446 6447 if Is_Fixed_Point_Type (Parent_Type) then 6448 Conditional_Delay (Implicit_Base, Parent_Type); 6449 else 6450 Freeze_Before (N, Implicit_Base); 6451 end if; 6452 end Build_Derived_Numeric_Type; 6453 6454 -------------------------------- 6455 -- Build_Derived_Private_Type -- 6456 -------------------------------- 6457 6458 procedure Build_Derived_Private_Type 6459 (N : Node_Id; 6460 Parent_Type : Entity_Id; 6461 Derived_Type : Entity_Id; 6462 Is_Completion : Boolean; 6463 Derive_Subps : Boolean := True) 6464 is 6465 Loc : constant Source_Ptr := Sloc (N); 6466 Der_Base : Entity_Id; 6467 Discr : Entity_Id; 6468 Full_Decl : Node_Id := Empty; 6469 Full_Der : Entity_Id; 6470 Full_P : Entity_Id; 6471 Last_Discr : Entity_Id; 6472 Par_Scope : constant Entity_Id := Scope (Base_Type (Parent_Type)); 6473 Swapped : Boolean := False; 6474 6475 procedure Copy_And_Build; 6476 -- Copy derived type declaration, replace parent with its full view, 6477 -- and analyze new declaration. 6478 6479 -------------------- 6480 -- Copy_And_Build -- 6481 -------------------- 6482 6483 procedure Copy_And_Build is 6484 Full_N : Node_Id; 6485 6486 begin 6487 if Ekind (Parent_Type) in Record_Kind 6488 or else 6489 (Ekind (Parent_Type) in Enumeration_Kind 6490 and then not Is_Standard_Character_Type (Parent_Type) 6491 and then not Is_Generic_Type (Root_Type (Parent_Type))) 6492 then 6493 Full_N := New_Copy_Tree (N); 6494 Insert_After (N, Full_N); 6495 Build_Derived_Type ( 6496 Full_N, Parent_Type, Full_Der, True, Derive_Subps => False); 6497 6498 else 6499 Build_Derived_Type ( 6500 N, Parent_Type, Full_Der, True, Derive_Subps => False); 6501 end if; 6502 end Copy_And_Build; 6503 6504 -- Start of processing for Build_Derived_Private_Type 6505 6506 begin 6507 if Is_Tagged_Type (Parent_Type) then 6508 Full_P := Full_View (Parent_Type); 6509 6510 -- A type extension of a type with unknown discriminants is an 6511 -- indefinite type that the back-end cannot handle directly. 6512 -- We treat it as a private type, and build a completion that is 6513 -- derived from the full view of the parent, and hopefully has 6514 -- known discriminants. 6515 6516 -- If the full view of the parent type has an underlying record view, 6517 -- use it to generate the underlying record view of this derived type 6518 -- (required for chains of derivations with unknown discriminants). 6519 6520 -- Minor optimization: we avoid the generation of useless underlying 6521 -- record view entities if the private type declaration has unknown 6522 -- discriminants but its corresponding full view has no 6523 -- discriminants. 6524 6525 if Has_Unknown_Discriminants (Parent_Type) 6526 and then Present (Full_P) 6527 and then (Has_Discriminants (Full_P) 6528 or else Present (Underlying_Record_View (Full_P))) 6529 and then not In_Open_Scopes (Par_Scope) 6530 and then Expander_Active 6531 then 6532 declare 6533 Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T'); 6534 New_Ext : constant Node_Id := 6535 Copy_Separate_Tree 6536 (Record_Extension_Part (Type_Definition (N))); 6537 Decl : Node_Id; 6538 6539 begin 6540 Build_Derived_Record_Type 6541 (N, Parent_Type, Derived_Type, Derive_Subps); 6542 6543 -- Build anonymous completion, as a derivation from the full 6544 -- view of the parent. This is not a completion in the usual 6545 -- sense, because the current type is not private. 6546 6547 Decl := 6548 Make_Full_Type_Declaration (Loc, 6549 Defining_Identifier => Full_Der, 6550 Type_Definition => 6551 Make_Derived_Type_Definition (Loc, 6552 Subtype_Indication => 6553 New_Copy_Tree 6554 (Subtype_Indication (Type_Definition (N))), 6555 Record_Extension_Part => New_Ext)); 6556 6557 -- If the parent type has an underlying record view, use it 6558 -- here to build the new underlying record view. 6559 6560 if Present (Underlying_Record_View (Full_P)) then 6561 pragma Assert 6562 (Nkind (Subtype_Indication (Type_Definition (Decl))) 6563 = N_Identifier); 6564 Set_Entity (Subtype_Indication (Type_Definition (Decl)), 6565 Underlying_Record_View (Full_P)); 6566 end if; 6567 6568 Install_Private_Declarations (Par_Scope); 6569 Install_Visible_Declarations (Par_Scope); 6570 Insert_Before (N, Decl); 6571 6572 -- Mark entity as an underlying record view before analysis, 6573 -- to avoid generating the list of its primitive operations 6574 -- (which is not really required for this entity) and thus 6575 -- prevent spurious errors associated with missing overriding 6576 -- of abstract primitives (overridden only for Derived_Type). 6577 6578 Set_Ekind (Full_Der, E_Record_Type); 6579 Set_Is_Underlying_Record_View (Full_Der); 6580 6581 Analyze (Decl); 6582 6583 pragma Assert (Has_Discriminants (Full_Der) 6584 and then not Has_Unknown_Discriminants (Full_Der)); 6585 6586 Uninstall_Declarations (Par_Scope); 6587 6588 -- Freeze the underlying record view, to prevent generation of 6589 -- useless dispatching information, which is simply shared with 6590 -- the real derived type. 6591 6592 Set_Is_Frozen (Full_Der); 6593 6594 -- Set up links between real entity and underlying record view 6595 6596 Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der)); 6597 Set_Underlying_Record_View (Base_Type (Full_Der), Derived_Type); 6598 end; 6599 6600 -- If discriminants are known, build derived record 6601 6602 else 6603 Build_Derived_Record_Type 6604 (N, Parent_Type, Derived_Type, Derive_Subps); 6605 end if; 6606 6607 return; 6608 6609 elsif Has_Discriminants (Parent_Type) then 6610 if Present (Full_View (Parent_Type)) then 6611 if not Is_Completion then 6612 6613 -- Copy declaration for subsequent analysis, to provide a 6614 -- completion for what is a private declaration. Indicate that 6615 -- the full type is internally generated. 6616 6617 Full_Decl := New_Copy_Tree (N); 6618 Full_Der := New_Copy (Derived_Type); 6619 Set_Comes_From_Source (Full_Decl, False); 6620 Set_Comes_From_Source (Full_Der, False); 6621 Set_Parent (Full_Der, Full_Decl); 6622 6623 Insert_After (N, Full_Decl); 6624 6625 else 6626 -- If this is a completion, the full view being built is itself 6627 -- private. We build a subtype of the parent with the same 6628 -- constraints as this full view, to convey to the back end the 6629 -- constrained components and the size of this subtype. If the 6630 -- parent is constrained, its full view can serve as the 6631 -- underlying full view of the derived type. 6632 6633 if No (Discriminant_Specifications (N)) then 6634 if Nkind (Subtype_Indication (Type_Definition (N))) = 6635 N_Subtype_Indication 6636 then 6637 Build_Underlying_Full_View (N, Derived_Type, Parent_Type); 6638 6639 elsif Is_Constrained (Full_View (Parent_Type)) then 6640 Set_Underlying_Full_View 6641 (Derived_Type, Full_View (Parent_Type)); 6642 end if; 6643 6644 else 6645 -- If there are new discriminants, the parent subtype is 6646 -- constrained by them, but it is not clear how to build 6647 -- the Underlying_Full_View in this case??? 6648 6649 null; 6650 end if; 6651 end if; 6652 end if; 6653 6654 -- Build partial view of derived type from partial view of parent 6655 6656 Build_Derived_Record_Type 6657 (N, Parent_Type, Derived_Type, Derive_Subps); 6658 6659 if Present (Full_View (Parent_Type)) and then not Is_Completion then 6660 if not In_Open_Scopes (Par_Scope) 6661 or else not In_Same_Source_Unit (N, Parent_Type) 6662 then 6663 -- Swap partial and full views temporarily 6664 6665 Install_Private_Declarations (Par_Scope); 6666 Install_Visible_Declarations (Par_Scope); 6667 Swapped := True; 6668 end if; 6669 6670 -- Build full view of derived type from full view of parent which 6671 -- is now installed. Subprograms have been derived on the partial 6672 -- view, the completion does not derive them anew. 6673 6674 if not Is_Tagged_Type (Parent_Type) then 6675 6676 -- If the parent is itself derived from another private type, 6677 -- installing the private declarations has not affected its 6678 -- privacy status, so use its own full view explicitly. 6679 6680 if Is_Private_Type (Parent_Type) then 6681 Build_Derived_Record_Type 6682 (Full_Decl, Full_View (Parent_Type), Full_Der, False); 6683 else 6684 Build_Derived_Record_Type 6685 (Full_Decl, Parent_Type, Full_Der, False); 6686 end if; 6687 6688 else 6689 -- If full view of parent is tagged, the completion inherits 6690 -- the proper primitive operations. 6691 6692 Set_Defining_Identifier (Full_Decl, Full_Der); 6693 Build_Derived_Record_Type 6694 (Full_Decl, Parent_Type, Full_Der, Derive_Subps); 6695 end if; 6696 6697 -- The full declaration has been introduced into the tree and 6698 -- processed in the step above. It should not be analyzed again 6699 -- (when encountered later in the current list of declarations) 6700 -- to prevent spurious name conflicts. The full entity remains 6701 -- invisible. 6702 6703 Set_Analyzed (Full_Decl); 6704 6705 if Swapped then 6706 Uninstall_Declarations (Par_Scope); 6707 6708 if In_Open_Scopes (Par_Scope) then 6709 Install_Visible_Declarations (Par_Scope); 6710 end if; 6711 end if; 6712 6713 Der_Base := Base_Type (Derived_Type); 6714 Set_Full_View (Derived_Type, Full_Der); 6715 Set_Full_View (Der_Base, Base_Type (Full_Der)); 6716 6717 -- Copy the discriminant list from full view to the partial views 6718 -- (base type and its subtype). Gigi requires that the partial and 6719 -- full views have the same discriminants. 6720 6721 -- Note that since the partial view is pointing to discriminants 6722 -- in the full view, their scope will be that of the full view. 6723 -- This might cause some front end problems and need adjustment??? 6724 6725 Discr := First_Discriminant (Base_Type (Full_Der)); 6726 Set_First_Entity (Der_Base, Discr); 6727 6728 loop 6729 Last_Discr := Discr; 6730 Next_Discriminant (Discr); 6731 exit when No (Discr); 6732 end loop; 6733 6734 Set_Last_Entity (Der_Base, Last_Discr); 6735 6736 Set_First_Entity (Derived_Type, First_Entity (Der_Base)); 6737 Set_Last_Entity (Derived_Type, Last_Entity (Der_Base)); 6738 Set_Stored_Constraint (Full_Der, Stored_Constraint (Derived_Type)); 6739 6740 else 6741 -- If this is a completion, the derived type stays private and 6742 -- there is no need to create a further full view, except in the 6743 -- unusual case when the derivation is nested within a child unit, 6744 -- see below. 6745 6746 null; 6747 end if; 6748 6749 elsif Present (Full_View (Parent_Type)) 6750 and then Has_Discriminants (Full_View (Parent_Type)) 6751 then 6752 if Has_Unknown_Discriminants (Parent_Type) 6753 and then Nkind (Subtype_Indication (Type_Definition (N))) = 6754 N_Subtype_Indication 6755 then 6756 Error_Msg_N 6757 ("cannot constrain type with unknown discriminants", 6758 Subtype_Indication (Type_Definition (N))); 6759 return; 6760 end if; 6761 6762 -- If full view of parent is a record type, build full view as a 6763 -- derivation from the parent's full view. Partial view remains 6764 -- private. For code generation and linking, the full view must have 6765 -- the same public status as the partial one. This full view is only 6766 -- needed if the parent type is in an enclosing scope, so that the 6767 -- full view may actually become visible, e.g. in a child unit. This 6768 -- is both more efficient, and avoids order of freezing problems with 6769 -- the added entities. 6770 6771 if not Is_Private_Type (Full_View (Parent_Type)) 6772 and then (In_Open_Scopes (Scope (Parent_Type))) 6773 then 6774 Full_Der := 6775 Make_Defining_Identifier (Sloc (Derived_Type), 6776 Chars => Chars (Derived_Type)); 6777 6778 Set_Is_Itype (Full_Der); 6779 Set_Has_Private_Declaration (Full_Der); 6780 Set_Has_Private_Declaration (Derived_Type); 6781 Set_Associated_Node_For_Itype (Full_Der, N); 6782 Set_Parent (Full_Der, Parent (Derived_Type)); 6783 Set_Full_View (Derived_Type, Full_Der); 6784 Set_Is_Public (Full_Der, Is_Public (Derived_Type)); 6785 Full_P := Full_View (Parent_Type); 6786 Exchange_Declarations (Parent_Type); 6787 Copy_And_Build; 6788 Exchange_Declarations (Full_P); 6789 6790 else 6791 Build_Derived_Record_Type 6792 (N, Full_View (Parent_Type), Derived_Type, 6793 Derive_Subps => False); 6794 6795 -- Except in the context of the full view of the parent, there 6796 -- are no non-extension aggregates for the derived type. 6797 6798 Set_Has_Private_Ancestor (Derived_Type); 6799 end if; 6800 6801 -- In any case, the primitive operations are inherited from the 6802 -- parent type, not from the internal full view. 6803 6804 Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type)); 6805 6806 if Derive_Subps then 6807 Derive_Subprograms (Parent_Type, Derived_Type); 6808 end if; 6809 6810 else 6811 -- Untagged type, No discriminants on either view 6812 6813 if Nkind (Subtype_Indication (Type_Definition (N))) = 6814 N_Subtype_Indication 6815 then 6816 Error_Msg_N 6817 ("illegal constraint on type without discriminants", N); 6818 end if; 6819 6820 if Present (Discriminant_Specifications (N)) 6821 and then Present (Full_View (Parent_Type)) 6822 and then not Is_Tagged_Type (Full_View (Parent_Type)) 6823 then 6824 Error_Msg_N ("cannot add discriminants to untagged type", N); 6825 end if; 6826 6827 Set_Stored_Constraint (Derived_Type, No_Elist); 6828 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 6829 Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); 6830 Set_Has_Controlled_Component 6831 (Derived_Type, Has_Controlled_Component 6832 (Parent_Type)); 6833 6834 -- Direct controlled types do not inherit Finalize_Storage_Only flag 6835 6836 if not Is_Controlled (Parent_Type) then 6837 Set_Finalize_Storage_Only 6838 (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type)); 6839 end if; 6840 6841 -- Construct the implicit full view by deriving from full view of the 6842 -- parent type. In order to get proper visibility, we install the 6843 -- parent scope and its declarations. 6844 6845 -- ??? If the parent is untagged private and its completion is 6846 -- tagged, this mechanism will not work because we cannot derive from 6847 -- the tagged full view unless we have an extension. 6848 6849 if Present (Full_View (Parent_Type)) 6850 and then not Is_Tagged_Type (Full_View (Parent_Type)) 6851 and then not Is_Completion 6852 then 6853 Full_Der := 6854 Make_Defining_Identifier 6855 (Sloc (Derived_Type), Chars (Derived_Type)); 6856 Set_Is_Itype (Full_Der); 6857 Set_Has_Private_Declaration (Full_Der); 6858 Set_Has_Private_Declaration (Derived_Type); 6859 Set_Associated_Node_For_Itype (Full_Der, N); 6860 Set_Parent (Full_Der, Parent (Derived_Type)); 6861 Set_Full_View (Derived_Type, Full_Der); 6862 6863 if not In_Open_Scopes (Par_Scope) then 6864 Install_Private_Declarations (Par_Scope); 6865 Install_Visible_Declarations (Par_Scope); 6866 Copy_And_Build; 6867 Uninstall_Declarations (Par_Scope); 6868 6869 -- If parent scope is open and in another unit, and parent has a 6870 -- completion, then the derivation is taking place in the visible 6871 -- part of a child unit. In that case retrieve the full view of 6872 -- the parent momentarily. 6873 6874 elsif not In_Same_Source_Unit (N, Parent_Type) then 6875 Full_P := Full_View (Parent_Type); 6876 Exchange_Declarations (Parent_Type); 6877 Copy_And_Build; 6878 Exchange_Declarations (Full_P); 6879 6880 -- Otherwise it is a local derivation 6881 6882 else 6883 Copy_And_Build; 6884 end if; 6885 6886 Set_Scope (Full_Der, Current_Scope); 6887 Set_Is_First_Subtype (Full_Der, 6888 Is_First_Subtype (Derived_Type)); 6889 Set_Has_Size_Clause (Full_Der, False); 6890 Set_Has_Alignment_Clause (Full_Der, False); 6891 Set_Next_Entity (Full_Der, Empty); 6892 Set_Has_Delayed_Freeze (Full_Der); 6893 Set_Is_Frozen (Full_Der, False); 6894 Set_Freeze_Node (Full_Der, Empty); 6895 Set_Depends_On_Private (Full_Der, 6896 Has_Private_Component (Full_Der)); 6897 Set_Public_Status (Full_Der); 6898 end if; 6899 end if; 6900 6901 Set_Has_Unknown_Discriminants (Derived_Type, 6902 Has_Unknown_Discriminants (Parent_Type)); 6903 6904 if Is_Private_Type (Derived_Type) then 6905 Set_Private_Dependents (Derived_Type, New_Elmt_List); 6906 end if; 6907 6908 if Is_Private_Type (Parent_Type) 6909 and then Base_Type (Parent_Type) = Parent_Type 6910 and then In_Open_Scopes (Scope (Parent_Type)) 6911 then 6912 Append_Elmt (Derived_Type, Private_Dependents (Parent_Type)); 6913 6914 -- Check for unusual case where a type completed by a private 6915 -- derivation occurs within a package nested in a child unit, and 6916 -- the parent is declared in an ancestor. 6917 6918 if Is_Child_Unit (Scope (Current_Scope)) 6919 and then Is_Completion 6920 and then In_Private_Part (Current_Scope) 6921 and then Scope (Parent_Type) /= Current_Scope 6922 6923 -- Note that if the parent has a completion in the private part, 6924 -- (which is itself a derivation from some other private type) 6925 -- it is that completion that is visible, there is no full view 6926 -- available, and no special processing is needed. 6927 6928 and then Present (Full_View (Parent_Type)) 6929 then 6930 -- In this case, the full view of the parent type will become 6931 -- visible in the body of the enclosing child, and only then will 6932 -- the current type be possibly non-private. We build an 6933 -- underlying full view that will be installed when the enclosing 6934 -- child body is compiled. 6935 6936 Full_Der := 6937 Make_Defining_Identifier 6938 (Sloc (Derived_Type), Chars (Derived_Type)); 6939 Set_Is_Itype (Full_Der); 6940 Build_Itype_Reference (Full_Der, N); 6941 6942 -- The full view will be used to swap entities on entry/exit to 6943 -- the body, and must appear in the entity list for the package. 6944 6945 Append_Entity (Full_Der, Scope (Derived_Type)); 6946 Set_Has_Private_Declaration (Full_Der); 6947 Set_Has_Private_Declaration (Derived_Type); 6948 Set_Associated_Node_For_Itype (Full_Der, N); 6949 Set_Parent (Full_Der, Parent (Derived_Type)); 6950 Full_P := Full_View (Parent_Type); 6951 Exchange_Declarations (Parent_Type); 6952 Copy_And_Build; 6953 Exchange_Declarations (Full_P); 6954 Set_Underlying_Full_View (Derived_Type, Full_Der); 6955 end if; 6956 end if; 6957 end Build_Derived_Private_Type; 6958 6959 ------------------------------- 6960 -- Build_Derived_Record_Type -- 6961 ------------------------------- 6962 6963 -- 1. INTRODUCTION 6964 6965 -- Ideally we would like to use the same model of type derivation for 6966 -- tagged and untagged record types. Unfortunately this is not quite 6967 -- possible because the semantics of representation clauses is different 6968 -- for tagged and untagged records under inheritance. Consider the 6969 -- following: 6970 6971 -- type R (...) is [tagged] record ... end record; 6972 -- type T (...) is new R (...) [with ...]; 6973 6974 -- The representation clauses for T can specify a completely different 6975 -- record layout from R's. Hence the same component can be placed in two 6976 -- very different positions in objects of type T and R. If R and T are 6977 -- tagged types, representation clauses for T can only specify the layout 6978 -- of non inherited components, thus components that are common in R and T 6979 -- have the same position in objects of type R and T. 6980 6981 -- This has two implications. The first is that the entire tree for R's 6982 -- declaration needs to be copied for T in the untagged case, so that T 6983 -- can be viewed as a record type of its own with its own representation 6984 -- clauses. The second implication is the way we handle discriminants. 6985 -- Specifically, in the untagged case we need a way to communicate to Gigi 6986 -- what are the real discriminants in the record, while for the semantics 6987 -- we need to consider those introduced by the user to rename the 6988 -- discriminants in the parent type. This is handled by introducing the 6989 -- notion of stored discriminants. See below for more. 6990 6991 -- Fortunately the way regular components are inherited can be handled in 6992 -- the same way in tagged and untagged types. 6993 6994 -- To complicate things a bit more the private view of a private extension 6995 -- cannot be handled in the same way as the full view (for one thing the 6996 -- semantic rules are somewhat different). We will explain what differs 6997 -- below. 6998 6999 -- 2. DISCRIMINANTS UNDER INHERITANCE 7000 7001 -- The semantic rules governing the discriminants of derived types are 7002 -- quite subtle. 7003 7004 -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new 7005 -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART] 7006 7007 -- If parent type has discriminants, then the discriminants that are 7008 -- declared in the derived type are [3.4 (11)]: 7009 7010 -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if 7011 -- there is one; 7012 7013 -- o Otherwise, each discriminant of the parent type (implicitly declared 7014 -- in the same order with the same specifications). In this case, the 7015 -- discriminants are said to be "inherited", or if unknown in the parent 7016 -- are also unknown in the derived type. 7017 7018 -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]: 7019 7020 -- o The parent subtype shall be constrained; 7021 7022 -- o If the parent type is not a tagged type, then each discriminant of 7023 -- the derived type shall be used in the constraint defining a parent 7024 -- subtype. [Implementation note: This ensures that the new discriminant 7025 -- can share storage with an existing discriminant.] 7026 7027 -- For the derived type each discriminant of the parent type is either 7028 -- inherited, constrained to equal some new discriminant of the derived 7029 -- type, or constrained to the value of an expression. 7030 7031 -- When inherited or constrained to equal some new discriminant, the 7032 -- parent discriminant and the discriminant of the derived type are said 7033 -- to "correspond". 7034 7035 -- If a discriminant of the parent type is constrained to a specific value 7036 -- in the derived type definition, then the discriminant is said to be 7037 -- "specified" by that derived type definition. 7038 7039 -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES 7040 7041 -- We have spoken about stored discriminants in point 1 (introduction) 7042 -- above. There are two sort of stored discriminants: implicit and 7043 -- explicit. As long as the derived type inherits the same discriminants as 7044 -- the root record type, stored discriminants are the same as regular 7045 -- discriminants, and are said to be implicit. However, if any discriminant 7046 -- in the root type was renamed in the derived type, then the derived 7047 -- type will contain explicit stored discriminants. Explicit stored 7048 -- discriminants are discriminants in addition to the semantically visible 7049 -- discriminants defined for the derived type. Stored discriminants are 7050 -- used by Gigi to figure out what are the physical discriminants in 7051 -- objects of the derived type (see precise definition in einfo.ads). 7052 -- As an example, consider the following: 7053 7054 -- type R (D1, D2, D3 : Int) is record ... end record; 7055 -- type T1 is new R; 7056 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1); 7057 -- type T3 is new T2; 7058 -- type T4 (Y : Int) is new T3 (Y, 99); 7059 7060 -- The following table summarizes the discriminants and stored 7061 -- discriminants in R and T1 through T4. 7062 7063 -- Type Discrim Stored Discrim Comment 7064 -- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R 7065 -- T1 (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in T1 7066 -- T2 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T2 7067 -- T3 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T3 7068 -- T4 (Y) (D1, D2, D3) Girder discrims EXPLICIT in T4 7069 7070 -- Field Corresponding_Discriminant (abbreviated CD below) allows us to 7071 -- find the corresponding discriminant in the parent type, while 7072 -- Original_Record_Component (abbreviated ORC below), the actual physical 7073 -- component that is renamed. Finally the field Is_Completely_Hidden 7074 -- (abbreviated ICH below) is set for all explicit stored discriminants 7075 -- (see einfo.ads for more info). For the above example this gives: 7076 7077 -- Discrim CD ORC ICH 7078 -- ^^^^^^^ ^^ ^^^ ^^^ 7079 -- D1 in R empty itself no 7080 -- D2 in R empty itself no 7081 -- D3 in R empty itself no 7082 7083 -- D1 in T1 D1 in R itself no 7084 -- D2 in T1 D2 in R itself no 7085 -- D3 in T1 D3 in R itself no 7086 7087 -- X1 in T2 D3 in T1 D3 in T2 no 7088 -- X2 in T2 D1 in T1 D1 in T2 no 7089 -- D1 in T2 empty itself yes 7090 -- D2 in T2 empty itself yes 7091 -- D3 in T2 empty itself yes 7092 7093 -- X1 in T3 X1 in T2 D3 in T3 no 7094 -- X2 in T3 X2 in T2 D1 in T3 no 7095 -- D1 in T3 empty itself yes 7096 -- D2 in T3 empty itself yes 7097 -- D3 in T3 empty itself yes 7098 7099 -- Y in T4 X1 in T3 D3 in T3 no 7100 -- D1 in T3 empty itself yes 7101 -- D2 in T3 empty itself yes 7102 -- D3 in T3 empty itself yes 7103 7104 -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES 7105 7106 -- Type derivation for tagged types is fairly straightforward. If no 7107 -- discriminants are specified by the derived type, these are inherited 7108 -- from the parent. No explicit stored discriminants are ever necessary. 7109 -- The only manipulation that is done to the tree is that of adding a 7110 -- _parent field with parent type and constrained to the same constraint 7111 -- specified for the parent in the derived type definition. For instance: 7112 7113 -- type R (D1, D2, D3 : Int) is tagged record ... end record; 7114 -- type T1 is new R with null record; 7115 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record; 7116 7117 -- are changed into: 7118 7119 -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record 7120 -- _parent : R (D1, D2, D3); 7121 -- end record; 7122 7123 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record 7124 -- _parent : T1 (X2, 88, X1); 7125 -- end record; 7126 7127 -- The discriminants actually present in R, T1 and T2 as well as their CD, 7128 -- ORC and ICH fields are: 7129 7130 -- Discrim CD ORC ICH 7131 -- ^^^^^^^ ^^ ^^^ ^^^ 7132 -- D1 in R empty itself no 7133 -- D2 in R empty itself no 7134 -- D3 in R empty itself no 7135 7136 -- D1 in T1 D1 in R D1 in R no 7137 -- D2 in T1 D2 in R D2 in R no 7138 -- D3 in T1 D3 in R D3 in R no 7139 7140 -- X1 in T2 D3 in T1 D3 in R no 7141 -- X2 in T2 D1 in T1 D1 in R no 7142 7143 -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS 7144 -- 7145 -- Regardless of whether we dealing with a tagged or untagged type 7146 -- we will transform all derived type declarations of the form 7147 -- 7148 -- type T is new R (...) [with ...]; 7149 -- or 7150 -- subtype S is R (...); 7151 -- type T is new S [with ...]; 7152 -- into 7153 -- type BT is new R [with ...]; 7154 -- subtype T is BT (...); 7155 -- 7156 -- That is, the base derived type is constrained only if it has no 7157 -- discriminants. The reason for doing this is that GNAT's semantic model 7158 -- assumes that a base type with discriminants is unconstrained. 7159 -- 7160 -- Note that, strictly speaking, the above transformation is not always 7161 -- correct. Consider for instance the following excerpt from ACVC b34011a: 7162 -- 7163 -- procedure B34011A is 7164 -- type REC (D : integer := 0) is record 7165 -- I : Integer; 7166 -- end record; 7167 7168 -- package P is 7169 -- type T6 is new Rec; 7170 -- function F return T6; 7171 -- end P; 7172 7173 -- use P; 7174 -- package Q6 is 7175 -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F. 7176 -- end Q6; 7177 -- 7178 -- The definition of Q6.U is illegal. However transforming Q6.U into 7179 7180 -- type BaseU is new T6; 7181 -- subtype U is BaseU (Q6.F.I) 7182 7183 -- turns U into a legal subtype, which is incorrect. To avoid this problem 7184 -- we always analyze the constraint (in this case (Q6.F.I)) before applying 7185 -- the transformation described above. 7186 7187 -- There is another instance where the above transformation is incorrect. 7188 -- Consider: 7189 7190 -- package Pack is 7191 -- type Base (D : Integer) is tagged null record; 7192 -- procedure P (X : Base); 7193 7194 -- type Der is new Base (2) with null record; 7195 -- procedure P (X : Der); 7196 -- end Pack; 7197 7198 -- Then the above transformation turns this into 7199 7200 -- type Der_Base is new Base with null record; 7201 -- -- procedure P (X : Base) is implicitly inherited here 7202 -- -- as procedure P (X : Der_Base). 7203 7204 -- subtype Der is Der_Base (2); 7205 -- procedure P (X : Der); 7206 -- -- The overriding of P (X : Der_Base) is illegal since we 7207 -- -- have a parameter conformance problem. 7208 7209 -- To get around this problem, after having semantically processed Der_Base 7210 -- and the rewritten subtype declaration for Der, we copy Der_Base field 7211 -- Discriminant_Constraint from Der so that when parameter conformance is 7212 -- checked when P is overridden, no semantic errors are flagged. 7213 7214 -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS 7215 7216 -- Regardless of whether we are dealing with a tagged or untagged type 7217 -- we will transform all derived type declarations of the form 7218 7219 -- type R (D1, .., Dn : ...) is [tagged] record ...; 7220 -- type T is new R [with ...]; 7221 -- into 7222 -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...]; 7223 7224 -- The reason for such transformation is that it allows us to implement a 7225 -- very clean form of component inheritance as explained below. 7226 7227 -- Note that this transformation is not achieved by direct tree rewriting 7228 -- and manipulation, but rather by redoing the semantic actions that the 7229 -- above transformation will entail. This is done directly in routine 7230 -- Inherit_Components. 7231 7232 -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE 7233 7234 -- In both tagged and untagged derived types, regular non discriminant 7235 -- components are inherited in the derived type from the parent type. In 7236 -- the absence of discriminants component, inheritance is straightforward 7237 -- as components can simply be copied from the parent. 7238 7239 -- If the parent has discriminants, inheriting components constrained with 7240 -- these discriminants requires caution. Consider the following example: 7241 7242 -- type R (D1, D2 : Positive) is [tagged] record 7243 -- S : String (D1 .. D2); 7244 -- end record; 7245 7246 -- type T1 is new R [with null record]; 7247 -- type T2 (X : positive) is new R (1, X) [with null record]; 7248 7249 -- As explained in 6. above, T1 is rewritten as 7250 -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record]; 7251 -- which makes the treatment for T1 and T2 identical. 7252 7253 -- What we want when inheriting S, is that references to D1 and D2 in R are 7254 -- replaced with references to their correct constraints, i.e. D1 and D2 in 7255 -- T1 and 1 and X in T2. So all R's discriminant references are replaced 7256 -- with either discriminant references in the derived type or expressions. 7257 -- This replacement is achieved as follows: before inheriting R's 7258 -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is 7259 -- created in the scope of T1 (resp. scope of T2) so that discriminants D1 7260 -- and D2 of T1 are visible (resp. discriminant X of T2 is visible). 7261 -- For T2, for instance, this has the effect of replacing String (D1 .. D2) 7262 -- by String (1 .. X). 7263 7264 -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS 7265 7266 -- We explain here the rules governing private type extensions relevant to 7267 -- type derivation. These rules are explained on the following example: 7268 7269 -- type D [(...)] is new A [(...)] with private; <-- partial view 7270 -- type D [(...)] is new P [(...)] with null record; <-- full view 7271 7272 -- Type A is called the ancestor subtype of the private extension. 7273 -- Type P is the parent type of the full view of the private extension. It 7274 -- must be A or a type derived from A. 7275 7276 -- The rules concerning the discriminants of private type extensions are 7277 -- [7.3(10-13)]: 7278 7279 -- o If a private extension inherits known discriminants from the ancestor 7280 -- subtype, then the full view shall also inherit its discriminants from 7281 -- the ancestor subtype and the parent subtype of the full view shall be 7282 -- constrained if and only if the ancestor subtype is constrained. 7283 7284 -- o If a partial view has unknown discriminants, then the full view may 7285 -- define a definite or an indefinite subtype, with or without 7286 -- discriminants. 7287 7288 -- o If a partial view has neither known nor unknown discriminants, then 7289 -- the full view shall define a definite subtype. 7290 7291 -- o If the ancestor subtype of a private extension has constrained 7292 -- discriminants, then the parent subtype of the full view shall impose a 7293 -- statically matching constraint on those discriminants. 7294 7295 -- This means that only the following forms of private extensions are 7296 -- allowed: 7297 7298 -- type D is new A with private; <-- partial view 7299 -- type D is new P with null record; <-- full view 7300 7301 -- If A has no discriminants than P has no discriminants, otherwise P must 7302 -- inherit A's discriminants. 7303 7304 -- type D is new A (...) with private; <-- partial view 7305 -- type D is new P (:::) with null record; <-- full view 7306 7307 -- P must inherit A's discriminants and (...) and (:::) must statically 7308 -- match. 7309 7310 -- subtype A is R (...); 7311 -- type D is new A with private; <-- partial view 7312 -- type D is new P with null record; <-- full view 7313 7314 -- P must have inherited R's discriminants and must be derived from A or 7315 -- any of its subtypes. 7316 7317 -- type D (..) is new A with private; <-- partial view 7318 -- type D (..) is new P [(:::)] with null record; <-- full view 7319 7320 -- No specific constraints on P's discriminants or constraint (:::). 7321 -- Note that A can be unconstrained, but the parent subtype P must either 7322 -- be constrained or (:::) must be present. 7323 7324 -- type D (..) is new A [(...)] with private; <-- partial view 7325 -- type D (..) is new P [(:::)] with null record; <-- full view 7326 7327 -- P's constraints on A's discriminants must statically match those 7328 -- imposed by (...). 7329 7330 -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS 7331 7332 -- The full view of a private extension is handled exactly as described 7333 -- above. The model chose for the private view of a private extension is 7334 -- the same for what concerns discriminants (i.e. they receive the same 7335 -- treatment as in the tagged case). However, the private view of the 7336 -- private extension always inherits the components of the parent base, 7337 -- without replacing any discriminant reference. Strictly speaking this is 7338 -- incorrect. However, Gigi never uses this view to generate code so this 7339 -- is a purely semantic issue. In theory, a set of transformations similar 7340 -- to those given in 5. and 6. above could be applied to private views of 7341 -- private extensions to have the same model of component inheritance as 7342 -- for non private extensions. However, this is not done because it would 7343 -- further complicate private type processing. Semantically speaking, this 7344 -- leaves us in an uncomfortable situation. As an example consider: 7345 7346 -- package Pack is 7347 -- type R (D : integer) is tagged record 7348 -- S : String (1 .. D); 7349 -- end record; 7350 -- procedure P (X : R); 7351 -- type T is new R (1) with private; 7352 -- private 7353 -- type T is new R (1) with null record; 7354 -- end; 7355 7356 -- This is transformed into: 7357 7358 -- package Pack is 7359 -- type R (D : integer) is tagged record 7360 -- S : String (1 .. D); 7361 -- end record; 7362 -- procedure P (X : R); 7363 -- type T is new R (1) with private; 7364 -- private 7365 -- type BaseT is new R with null record; 7366 -- subtype T is BaseT (1); 7367 -- end; 7368 7369 -- (strictly speaking the above is incorrect Ada) 7370 7371 -- From the semantic standpoint the private view of private extension T 7372 -- should be flagged as constrained since one can clearly have 7373 -- 7374 -- Obj : T; 7375 -- 7376 -- in a unit withing Pack. However, when deriving subprograms for the 7377 -- private view of private extension T, T must be seen as unconstrained 7378 -- since T has discriminants (this is a constraint of the current 7379 -- subprogram derivation model). Thus, when processing the private view of 7380 -- a private extension such as T, we first mark T as unconstrained, we 7381 -- process it, we perform program derivation and just before returning from 7382 -- Build_Derived_Record_Type we mark T as constrained. 7383 7384 -- ??? Are there are other uncomfortable cases that we will have to 7385 -- deal with. 7386 7387 -- 10. RECORD_TYPE_WITH_PRIVATE complications 7388 7389 -- Types that are derived from a visible record type and have a private 7390 -- extension present other peculiarities. They behave mostly like private 7391 -- types, but if they have primitive operations defined, these will not 7392 -- have the proper signatures for further inheritance, because other 7393 -- primitive operations will use the implicit base that we define for 7394 -- private derivations below. This affect subprogram inheritance (see 7395 -- Derive_Subprograms for details). We also derive the implicit base from 7396 -- the base type of the full view, so that the implicit base is a record 7397 -- type and not another private type, This avoids infinite loops. 7398 7399 procedure Build_Derived_Record_Type 7400 (N : Node_Id; 7401 Parent_Type : Entity_Id; 7402 Derived_Type : Entity_Id; 7403 Derive_Subps : Boolean := True) 7404 is 7405 Discriminant_Specs : constant Boolean := 7406 Present (Discriminant_Specifications (N)); 7407 Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type); 7408 Loc : constant Source_Ptr := Sloc (N); 7409 Private_Extension : constant Boolean := 7410 Nkind (N) = N_Private_Extension_Declaration; 7411 Assoc_List : Elist_Id; 7412 Constraint_Present : Boolean; 7413 Constrs : Elist_Id; 7414 Discrim : Entity_Id; 7415 Indic : Node_Id; 7416 Inherit_Discrims : Boolean := False; 7417 Last_Discrim : Entity_Id; 7418 New_Base : Entity_Id; 7419 New_Decl : Node_Id; 7420 New_Discrs : Elist_Id; 7421 New_Indic : Node_Id; 7422 Parent_Base : Entity_Id; 7423 Save_Etype : Entity_Id; 7424 Save_Discr_Constr : Elist_Id; 7425 Save_Next_Entity : Entity_Id; 7426 Type_Def : Node_Id; 7427 7428 Discs : Elist_Id := New_Elmt_List; 7429 -- An empty Discs list means that there were no constraints in the 7430 -- subtype indication or that there was an error processing it. 7431 7432 begin 7433 if Ekind (Parent_Type) = E_Record_Type_With_Private 7434 and then Present (Full_View (Parent_Type)) 7435 and then Has_Discriminants (Parent_Type) 7436 then 7437 Parent_Base := Base_Type (Full_View (Parent_Type)); 7438 else 7439 Parent_Base := Base_Type (Parent_Type); 7440 end if; 7441 7442 -- AI05-0115 : if this is a derivation from a private type in some 7443 -- other scope that may lead to invisible components for the derived 7444 -- type, mark it accordingly. 7445 7446 if Is_Private_Type (Parent_Type) then 7447 if Scope (Parent_Type) = Scope (Derived_Type) then 7448 null; 7449 7450 elsif In_Open_Scopes (Scope (Parent_Type)) 7451 and then In_Private_Part (Scope (Parent_Type)) 7452 then 7453 null; 7454 7455 else 7456 Set_Has_Private_Ancestor (Derived_Type); 7457 end if; 7458 7459 else 7460 Set_Has_Private_Ancestor 7461 (Derived_Type, Has_Private_Ancestor (Parent_Type)); 7462 end if; 7463 7464 -- Before we start the previously documented transformations, here is 7465 -- little fix for size and alignment of tagged types. Normally when we 7466 -- derive type D from type P, we copy the size and alignment of P as the 7467 -- default for D, and in the absence of explicit representation clauses 7468 -- for D, the size and alignment are indeed the same as the parent. 7469 7470 -- But this is wrong for tagged types, since fields may be added, and 7471 -- the default size may need to be larger, and the default alignment may 7472 -- need to be larger. 7473 7474 -- We therefore reset the size and alignment fields in the tagged case. 7475 -- Note that the size and alignment will in any case be at least as 7476 -- large as the parent type (since the derived type has a copy of the 7477 -- parent type in the _parent field) 7478 7479 -- The type is also marked as being tagged here, which is needed when 7480 -- processing components with a self-referential anonymous access type 7481 -- in the call to Check_Anonymous_Access_Components below. Note that 7482 -- this flag is also set later on for completeness. 7483 7484 if Is_Tagged then 7485 Set_Is_Tagged_Type (Derived_Type); 7486 Init_Size_Align (Derived_Type); 7487 end if; 7488 7489 -- STEP 0a: figure out what kind of derived type declaration we have 7490 7491 if Private_Extension then 7492 Type_Def := N; 7493 Set_Ekind (Derived_Type, E_Record_Type_With_Private); 7494 7495 else 7496 Type_Def := Type_Definition (N); 7497 7498 -- Ekind (Parent_Base) is not necessarily E_Record_Type since 7499 -- Parent_Base can be a private type or private extension. However, 7500 -- for tagged types with an extension the newly added fields are 7501 -- visible and hence the Derived_Type is always an E_Record_Type. 7502 -- (except that the parent may have its own private fields). 7503 -- For untagged types we preserve the Ekind of the Parent_Base. 7504 7505 if Present (Record_Extension_Part (Type_Def)) then 7506 Set_Ekind (Derived_Type, E_Record_Type); 7507 7508 -- Create internal access types for components with anonymous 7509 -- access types. 7510 7511 if Ada_Version >= Ada_2005 then 7512 Check_Anonymous_Access_Components 7513 (N, Derived_Type, Derived_Type, 7514 Component_List (Record_Extension_Part (Type_Def))); 7515 end if; 7516 7517 else 7518 Set_Ekind (Derived_Type, Ekind (Parent_Base)); 7519 end if; 7520 end if; 7521 7522 -- Indic can either be an N_Identifier if the subtype indication 7523 -- contains no constraint or an N_Subtype_Indication if the subtype 7524 -- indication has a constraint. 7525 7526 Indic := Subtype_Indication (Type_Def); 7527 Constraint_Present := (Nkind (Indic) = N_Subtype_Indication); 7528 7529 -- Check that the type has visible discriminants. The type may be 7530 -- a private type with unknown discriminants whose full view has 7531 -- discriminants which are invisible. 7532 7533 if Constraint_Present then 7534 if not Has_Discriminants (Parent_Base) 7535 or else 7536 (Has_Unknown_Discriminants (Parent_Base) 7537 and then Is_Private_Type (Parent_Base)) 7538 then 7539 Error_Msg_N 7540 ("invalid constraint: type has no discriminant", 7541 Constraint (Indic)); 7542 7543 Constraint_Present := False; 7544 Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic))); 7545 7546 elsif Is_Constrained (Parent_Type) then 7547 Error_Msg_N 7548 ("invalid constraint: parent type is already constrained", 7549 Constraint (Indic)); 7550 7551 Constraint_Present := False; 7552 Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic))); 7553 end if; 7554 end if; 7555 7556 -- STEP 0b: If needed, apply transformation given in point 5. above 7557 7558 if not Private_Extension 7559 and then Has_Discriminants (Parent_Type) 7560 and then not Discriminant_Specs 7561 and then (Is_Constrained (Parent_Type) or else Constraint_Present) 7562 then 7563 -- First, we must analyze the constraint (see comment in point 5.) 7564 -- The constraint may come from the subtype indication of the full 7565 -- declaration. 7566 7567 if Constraint_Present then 7568 New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic); 7569 7570 -- If there is no explicit constraint, there might be one that is 7571 -- inherited from a constrained parent type. In that case verify that 7572 -- it conforms to the constraint in the partial view. In perverse 7573 -- cases the parent subtypes of the partial and full view can have 7574 -- different constraints. 7575 7576 elsif Present (Stored_Constraint (Parent_Type)) then 7577 New_Discrs := Stored_Constraint (Parent_Type); 7578 7579 else 7580 New_Discrs := No_Elist; 7581 end if; 7582 7583 if Has_Discriminants (Derived_Type) 7584 and then Has_Private_Declaration (Derived_Type) 7585 and then Present (Discriminant_Constraint (Derived_Type)) 7586 and then Present (New_Discrs) 7587 then 7588 -- Verify that constraints of the full view statically match 7589 -- those given in the partial view. 7590 7591 declare 7592 C1, C2 : Elmt_Id; 7593 7594 begin 7595 C1 := First_Elmt (New_Discrs); 7596 C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); 7597 while Present (C1) and then Present (C2) loop 7598 if Fully_Conformant_Expressions (Node (C1), Node (C2)) 7599 or else 7600 (Is_OK_Static_Expression (Node (C1)) 7601 and then Is_OK_Static_Expression (Node (C2)) 7602 and then 7603 Expr_Value (Node (C1)) = Expr_Value (Node (C2))) 7604 then 7605 null; 7606 7607 else 7608 if Constraint_Present then 7609 Error_Msg_N 7610 ("constraint not conformant to previous declaration", 7611 Node (C1)); 7612 else 7613 Error_Msg_N 7614 ("constraint of full view is incompatible " 7615 & "with partial view", N); 7616 end if; 7617 end if; 7618 7619 Next_Elmt (C1); 7620 Next_Elmt (C2); 7621 end loop; 7622 end; 7623 end if; 7624 7625 -- Insert and analyze the declaration for the unconstrained base type 7626 7627 New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B'); 7628 7629 New_Decl := 7630 Make_Full_Type_Declaration (Loc, 7631 Defining_Identifier => New_Base, 7632 Type_Definition => 7633 Make_Derived_Type_Definition (Loc, 7634 Abstract_Present => Abstract_Present (Type_Def), 7635 Limited_Present => Limited_Present (Type_Def), 7636 Subtype_Indication => 7637 New_Occurrence_Of (Parent_Base, Loc), 7638 Record_Extension_Part => 7639 Relocate_Node (Record_Extension_Part (Type_Def)), 7640 Interface_List => Interface_List (Type_Def))); 7641 7642 Set_Parent (New_Decl, Parent (N)); 7643 Mark_Rewrite_Insertion (New_Decl); 7644 Insert_Before (N, New_Decl); 7645 7646 -- In the extension case, make sure ancestor is frozen appropriately 7647 -- (see also non-discriminated case below). 7648 7649 if Present (Record_Extension_Part (Type_Def)) 7650 or else Is_Interface (Parent_Base) 7651 then 7652 Freeze_Before (New_Decl, Parent_Type); 7653 end if; 7654 7655 -- Note that this call passes False for the Derive_Subps parameter 7656 -- because subprogram derivation is deferred until after creating 7657 -- the subtype (see below). 7658 7659 Build_Derived_Type 7660 (New_Decl, Parent_Base, New_Base, 7661 Is_Completion => True, Derive_Subps => False); 7662 7663 -- ??? This needs re-examination to determine whether the 7664 -- above call can simply be replaced by a call to Analyze. 7665 7666 Set_Analyzed (New_Decl); 7667 7668 -- Insert and analyze the declaration for the constrained subtype 7669 7670 if Constraint_Present then 7671 New_Indic := 7672 Make_Subtype_Indication (Loc, 7673 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 7674 Constraint => Relocate_Node (Constraint (Indic))); 7675 7676 else 7677 declare 7678 Constr_List : constant List_Id := New_List; 7679 C : Elmt_Id; 7680 Expr : Node_Id; 7681 7682 begin 7683 C := First_Elmt (Discriminant_Constraint (Parent_Type)); 7684 while Present (C) loop 7685 Expr := Node (C); 7686 7687 -- It is safe here to call New_Copy_Tree since 7688 -- Force_Evaluation was called on each constraint in 7689 -- Build_Discriminant_Constraints. 7690 7691 Append (New_Copy_Tree (Expr), To => Constr_List); 7692 7693 Next_Elmt (C); 7694 end loop; 7695 7696 New_Indic := 7697 Make_Subtype_Indication (Loc, 7698 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 7699 Constraint => 7700 Make_Index_Or_Discriminant_Constraint (Loc, Constr_List)); 7701 end; 7702 end if; 7703 7704 Rewrite (N, 7705 Make_Subtype_Declaration (Loc, 7706 Defining_Identifier => Derived_Type, 7707 Subtype_Indication => New_Indic)); 7708 7709 Analyze (N); 7710 7711 -- Derivation of subprograms must be delayed until the full subtype 7712 -- has been established, to ensure proper overriding of subprograms 7713 -- inherited by full types. If the derivations occurred as part of 7714 -- the call to Build_Derived_Type above, then the check for type 7715 -- conformance would fail because earlier primitive subprograms 7716 -- could still refer to the full type prior the change to the new 7717 -- subtype and hence would not match the new base type created here. 7718 -- Subprograms are not derived, however, when Derive_Subps is False 7719 -- (since otherwise there could be redundant derivations). 7720 7721 if Derive_Subps then 7722 Derive_Subprograms (Parent_Type, Derived_Type); 7723 end if; 7724 7725 -- For tagged types the Discriminant_Constraint of the new base itype 7726 -- is inherited from the first subtype so that no subtype conformance 7727 -- problem arise when the first subtype overrides primitive 7728 -- operations inherited by the implicit base type. 7729 7730 if Is_Tagged then 7731 Set_Discriminant_Constraint 7732 (New_Base, Discriminant_Constraint (Derived_Type)); 7733 end if; 7734 7735 return; 7736 end if; 7737 7738 -- If we get here Derived_Type will have no discriminants or it will be 7739 -- a discriminated unconstrained base type. 7740 7741 -- STEP 1a: perform preliminary actions/checks for derived tagged types 7742 7743 if Is_Tagged then 7744 7745 -- The parent type is frozen for non-private extensions (RM 13.14(7)) 7746 -- The declaration of a specific descendant of an interface type 7747 -- freezes the interface type (RM 13.14). 7748 7749 if not Private_Extension or else Is_Interface (Parent_Base) then 7750 Freeze_Before (N, Parent_Type); 7751 end if; 7752 7753 -- In Ada 2005 (AI-344), the restriction that a derived tagged type 7754 -- cannot be declared at a deeper level than its parent type is 7755 -- removed. The check on derivation within a generic body is also 7756 -- relaxed, but there's a restriction that a derived tagged type 7757 -- cannot be declared in a generic body if it's derived directly 7758 -- or indirectly from a formal type of that generic. 7759 7760 if Ada_Version >= Ada_2005 then 7761 if Present (Enclosing_Generic_Body (Derived_Type)) then 7762 declare 7763 Ancestor_Type : Entity_Id; 7764 7765 begin 7766 -- Check to see if any ancestor of the derived type is a 7767 -- formal type. 7768 7769 Ancestor_Type := Parent_Type; 7770 while not Is_Generic_Type (Ancestor_Type) 7771 and then Etype (Ancestor_Type) /= Ancestor_Type 7772 loop 7773 Ancestor_Type := Etype (Ancestor_Type); 7774 end loop; 7775 7776 -- If the derived type does have a formal type as an 7777 -- ancestor, then it's an error if the derived type is 7778 -- declared within the body of the generic unit that 7779 -- declares the formal type in its generic formal part. It's 7780 -- sufficient to check whether the ancestor type is declared 7781 -- inside the same generic body as the derived type (such as 7782 -- within a nested generic spec), in which case the 7783 -- derivation is legal. If the formal type is declared 7784 -- outside of that generic body, then it's guaranteed that 7785 -- the derived type is declared within the generic body of 7786 -- the generic unit declaring the formal type. 7787 7788 if Is_Generic_Type (Ancestor_Type) 7789 and then Enclosing_Generic_Body (Ancestor_Type) /= 7790 Enclosing_Generic_Body (Derived_Type) 7791 then 7792 Error_Msg_NE 7793 ("parent type of& must not be descendant of formal type" 7794 & " of an enclosing generic body", 7795 Indic, Derived_Type); 7796 end if; 7797 end; 7798 end if; 7799 7800 elsif Type_Access_Level (Derived_Type) /= 7801 Type_Access_Level (Parent_Type) 7802 and then not Is_Generic_Type (Derived_Type) 7803 then 7804 if Is_Controlled (Parent_Type) then 7805 Error_Msg_N 7806 ("controlled type must be declared at the library level", 7807 Indic); 7808 else 7809 Error_Msg_N 7810 ("type extension at deeper accessibility level than parent", 7811 Indic); 7812 end if; 7813 7814 else 7815 declare 7816 GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type); 7817 7818 begin 7819 if Present (GB) 7820 and then GB /= Enclosing_Generic_Body (Parent_Base) 7821 then 7822 Error_Msg_NE 7823 ("parent type of& must not be outside generic body" 7824 & " (RM 3.9.1(4))", 7825 Indic, Derived_Type); 7826 end if; 7827 end; 7828 end if; 7829 end if; 7830 7831 -- Ada 2005 (AI-251) 7832 7833 if Ada_Version >= Ada_2005 and then Is_Tagged then 7834 7835 -- "The declaration of a specific descendant of an interface type 7836 -- freezes the interface type" (RM 13.14). 7837 7838 declare 7839 Iface : Node_Id; 7840 begin 7841 if Is_Non_Empty_List (Interface_List (Type_Def)) then 7842 Iface := First (Interface_List (Type_Def)); 7843 while Present (Iface) loop 7844 Freeze_Before (N, Etype (Iface)); 7845 Next (Iface); 7846 end loop; 7847 end if; 7848 end; 7849 end if; 7850 7851 -- STEP 1b : preliminary cleanup of the full view of private types 7852 7853 -- If the type is already marked as having discriminants, then it's the 7854 -- completion of a private type or private extension and we need to 7855 -- retain the discriminants from the partial view if the current 7856 -- declaration has Discriminant_Specifications so that we can verify 7857 -- conformance. However, we must remove any existing components that 7858 -- were inherited from the parent (and attached in Copy_And_Swap) 7859 -- because the full type inherits all appropriate components anyway, and 7860 -- we do not want the partial view's components interfering. 7861 7862 if Has_Discriminants (Derived_Type) and then Discriminant_Specs then 7863 Discrim := First_Discriminant (Derived_Type); 7864 loop 7865 Last_Discrim := Discrim; 7866 Next_Discriminant (Discrim); 7867 exit when No (Discrim); 7868 end loop; 7869 7870 Set_Last_Entity (Derived_Type, Last_Discrim); 7871 7872 -- In all other cases wipe out the list of inherited components (even 7873 -- inherited discriminants), it will be properly rebuilt here. 7874 7875 else 7876 Set_First_Entity (Derived_Type, Empty); 7877 Set_Last_Entity (Derived_Type, Empty); 7878 end if; 7879 7880 -- STEP 1c: Initialize some flags for the Derived_Type 7881 7882 -- The following flags must be initialized here so that 7883 -- Process_Discriminants can check that discriminants of tagged types do 7884 -- not have a default initial value and that access discriminants are 7885 -- only specified for limited records. For completeness, these flags are 7886 -- also initialized along with all the other flags below. 7887 7888 -- AI-419: Limitedness is not inherited from an interface parent, so to 7889 -- be limited in that case the type must be explicitly declared as 7890 -- limited. However, task and protected interfaces are always limited. 7891 7892 if Limited_Present (Type_Def) then 7893 Set_Is_Limited_Record (Derived_Type); 7894 7895 elsif Is_Limited_Record (Parent_Type) 7896 or else (Present (Full_View (Parent_Type)) 7897 and then Is_Limited_Record (Full_View (Parent_Type))) 7898 then 7899 if not Is_Interface (Parent_Type) 7900 or else Is_Synchronized_Interface (Parent_Type) 7901 or else Is_Protected_Interface (Parent_Type) 7902 or else Is_Task_Interface (Parent_Type) 7903 then 7904 Set_Is_Limited_Record (Derived_Type); 7905 end if; 7906 end if; 7907 7908 -- STEP 2a: process discriminants of derived type if any 7909 7910 Push_Scope (Derived_Type); 7911 7912 if Discriminant_Specs then 7913 Set_Has_Unknown_Discriminants (Derived_Type, False); 7914 7915 -- The following call initializes fields Has_Discriminants and 7916 -- Discriminant_Constraint, unless we are processing the completion 7917 -- of a private type declaration. 7918 7919 Check_Or_Process_Discriminants (N, Derived_Type); 7920 7921 -- For untagged types, the constraint on the Parent_Type must be 7922 -- present and is used to rename the discriminants. 7923 7924 if not Is_Tagged and then not Has_Discriminants (Parent_Type) then 7925 Error_Msg_N ("untagged parent must have discriminants", Indic); 7926 7927 elsif not Is_Tagged and then not Constraint_Present then 7928 Error_Msg_N 7929 ("discriminant constraint needed for derived untagged records", 7930 Indic); 7931 7932 -- Otherwise the parent subtype must be constrained unless we have a 7933 -- private extension. 7934 7935 elsif not Constraint_Present 7936 and then not Private_Extension 7937 and then not Is_Constrained (Parent_Type) 7938 then 7939 Error_Msg_N 7940 ("unconstrained type not allowed in this context", Indic); 7941 7942 elsif Constraint_Present then 7943 -- The following call sets the field Corresponding_Discriminant 7944 -- for the discriminants in the Derived_Type. 7945 7946 Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True); 7947 7948 -- For untagged types all new discriminants must rename 7949 -- discriminants in the parent. For private extensions new 7950 -- discriminants cannot rename old ones (implied by [7.3(13)]). 7951 7952 Discrim := First_Discriminant (Derived_Type); 7953 while Present (Discrim) loop 7954 if not Is_Tagged 7955 and then No (Corresponding_Discriminant (Discrim)) 7956 then 7957 Error_Msg_N 7958 ("new discriminants must constrain old ones", Discrim); 7959 7960 elsif Private_Extension 7961 and then Present (Corresponding_Discriminant (Discrim)) 7962 then 7963 Error_Msg_N 7964 ("only static constraints allowed for parent" 7965 & " discriminants in the partial view", Indic); 7966 exit; 7967 end if; 7968 7969 -- If a new discriminant is used in the constraint, then its 7970 -- subtype must be statically compatible with the parent 7971 -- discriminant's subtype (3.7(15)). 7972 7973 -- However, if the record contains an array constrained by 7974 -- the discriminant but with some different bound, the compiler 7975 -- attemps to create a smaller range for the discriminant type. 7976 -- (See exp_ch3.Adjust_Discriminants). In this case, where 7977 -- the discriminant type is a scalar type, the check must use 7978 -- the original discriminant type in the parent declaration. 7979 7980 declare 7981 Corr_Disc : constant Entity_Id := 7982 Corresponding_Discriminant (Discrim); 7983 Disc_Type : constant Entity_Id := Etype (Discrim); 7984 Corr_Type : Entity_Id; 7985 7986 begin 7987 if Present (Corr_Disc) then 7988 if Is_Scalar_Type (Disc_Type) then 7989 Corr_Type := 7990 Entity (Discriminant_Type (Parent (Corr_Disc))); 7991 else 7992 Corr_Type := Etype (Corr_Disc); 7993 end if; 7994 7995 if not 7996 Subtypes_Statically_Compatible (Disc_Type, Corr_Type) 7997 then 7998 Error_Msg_N 7999 ("subtype must be compatible " 8000 & "with parent discriminant", 8001 Discrim); 8002 end if; 8003 end if; 8004 end; 8005 8006 Next_Discriminant (Discrim); 8007 end loop; 8008 8009 -- Check whether the constraints of the full view statically 8010 -- match those imposed by the parent subtype [7.3(13)]. 8011 8012 if Present (Stored_Constraint (Derived_Type)) then 8013 declare 8014 C1, C2 : Elmt_Id; 8015 8016 begin 8017 C1 := First_Elmt (Discs); 8018 C2 := First_Elmt (Stored_Constraint (Derived_Type)); 8019 while Present (C1) and then Present (C2) loop 8020 if not 8021 Fully_Conformant_Expressions (Node (C1), Node (C2)) 8022 then 8023 Error_Msg_N 8024 ("not conformant with previous declaration", 8025 Node (C1)); 8026 end if; 8027 8028 Next_Elmt (C1); 8029 Next_Elmt (C2); 8030 end loop; 8031 end; 8032 end if; 8033 end if; 8034 8035 -- STEP 2b: No new discriminants, inherit discriminants if any 8036 8037 else 8038 if Private_Extension then 8039 Set_Has_Unknown_Discriminants 8040 (Derived_Type, 8041 Has_Unknown_Discriminants (Parent_Type) 8042 or else Unknown_Discriminants_Present (N)); 8043 8044 -- The partial view of the parent may have unknown discriminants, 8045 -- but if the full view has discriminants and the parent type is 8046 -- in scope they must be inherited. 8047 8048 elsif Has_Unknown_Discriminants (Parent_Type) 8049 and then 8050 (not Has_Discriminants (Parent_Type) 8051 or else not In_Open_Scopes (Scope (Parent_Type))) 8052 then 8053 Set_Has_Unknown_Discriminants (Derived_Type); 8054 end if; 8055 8056 if not Has_Unknown_Discriminants (Derived_Type) 8057 and then not Has_Unknown_Discriminants (Parent_Base) 8058 and then Has_Discriminants (Parent_Type) 8059 then 8060 Inherit_Discrims := True; 8061 Set_Has_Discriminants 8062 (Derived_Type, True); 8063 Set_Discriminant_Constraint 8064 (Derived_Type, Discriminant_Constraint (Parent_Base)); 8065 end if; 8066 8067 -- The following test is true for private types (remember 8068 -- transformation 5. is not applied to those) and in an error 8069 -- situation. 8070 8071 if Constraint_Present then 8072 Discs := Build_Discriminant_Constraints (Parent_Type, Indic); 8073 end if; 8074 8075 -- For now mark a new derived type as constrained only if it has no 8076 -- discriminants. At the end of Build_Derived_Record_Type we properly 8077 -- set this flag in the case of private extensions. See comments in 8078 -- point 9. just before body of Build_Derived_Record_Type. 8079 8080 Set_Is_Constrained 8081 (Derived_Type, 8082 not (Inherit_Discrims 8083 or else Has_Unknown_Discriminants (Derived_Type))); 8084 end if; 8085 8086 -- STEP 3: initialize fields of derived type 8087 8088 Set_Is_Tagged_Type (Derived_Type, Is_Tagged); 8089 Set_Stored_Constraint (Derived_Type, No_Elist); 8090 8091 -- Ada 2005 (AI-251): Private type-declarations can implement interfaces 8092 -- but cannot be interfaces 8093 8094 if not Private_Extension 8095 and then Ekind (Derived_Type) /= E_Private_Type 8096 and then Ekind (Derived_Type) /= E_Limited_Private_Type 8097 then 8098 if Interface_Present (Type_Def) then 8099 Analyze_Interface_Declaration (Derived_Type, Type_Def); 8100 end if; 8101 8102 Set_Interfaces (Derived_Type, No_Elist); 8103 end if; 8104 8105 -- Fields inherited from the Parent_Type 8106 8107 Set_Has_Specified_Layout 8108 (Derived_Type, Has_Specified_Layout (Parent_Type)); 8109 Set_Is_Limited_Composite 8110 (Derived_Type, Is_Limited_Composite (Parent_Type)); 8111 Set_Is_Private_Composite 8112 (Derived_Type, Is_Private_Composite (Parent_Type)); 8113 8114 -- Fields inherited from the Parent_Base 8115 8116 Set_Has_Controlled_Component 8117 (Derived_Type, Has_Controlled_Component (Parent_Base)); 8118 Set_Has_Non_Standard_Rep 8119 (Derived_Type, Has_Non_Standard_Rep (Parent_Base)); 8120 Set_Has_Primitive_Operations 8121 (Derived_Type, Has_Primitive_Operations (Parent_Base)); 8122 8123 -- Fields inherited from the Parent_Base in the non-private case 8124 8125 if Ekind (Derived_Type) = E_Record_Type then 8126 Set_Has_Complex_Representation 8127 (Derived_Type, Has_Complex_Representation (Parent_Base)); 8128 end if; 8129 8130 -- Fields inherited from the Parent_Base for record types 8131 8132 if Is_Record_Type (Derived_Type) then 8133 8134 declare 8135 Parent_Full : Entity_Id; 8136 8137 begin 8138 -- Ekind (Parent_Base) is not necessarily E_Record_Type since 8139 -- Parent_Base can be a private type or private extension. Go 8140 -- to the full view here to get the E_Record_Type specific flags. 8141 8142 if Present (Full_View (Parent_Base)) then 8143 Parent_Full := Full_View (Parent_Base); 8144 else 8145 Parent_Full := Parent_Base; 8146 end if; 8147 8148 Set_OK_To_Reorder_Components 8149 (Derived_Type, OK_To_Reorder_Components (Parent_Full)); 8150 end; 8151 end if; 8152 8153 -- Set fields for private derived types 8154 8155 if Is_Private_Type (Derived_Type) then 8156 Set_Depends_On_Private (Derived_Type, True); 8157 Set_Private_Dependents (Derived_Type, New_Elmt_List); 8158 8159 -- Inherit fields from non private record types. If this is the 8160 -- completion of a derivation from a private type, the parent itself 8161 -- is private, and the attributes come from its full view, which must 8162 -- be present. 8163 8164 else 8165 if Is_Private_Type (Parent_Base) 8166 and then not Is_Record_Type (Parent_Base) 8167 then 8168 Set_Component_Alignment 8169 (Derived_Type, Component_Alignment (Full_View (Parent_Base))); 8170 Set_C_Pass_By_Copy 8171 (Derived_Type, C_Pass_By_Copy (Full_View (Parent_Base))); 8172 else 8173 Set_Component_Alignment 8174 (Derived_Type, Component_Alignment (Parent_Base)); 8175 Set_C_Pass_By_Copy 8176 (Derived_Type, C_Pass_By_Copy (Parent_Base)); 8177 end if; 8178 end if; 8179 8180 -- Set fields for tagged types 8181 8182 if Is_Tagged then 8183 Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); 8184 8185 -- All tagged types defined in Ada.Finalization are controlled 8186 8187 if Chars (Scope (Derived_Type)) = Name_Finalization 8188 and then Chars (Scope (Scope (Derived_Type))) = Name_Ada 8189 and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard 8190 then 8191 Set_Is_Controlled (Derived_Type); 8192 else 8193 Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base)); 8194 end if; 8195 8196 -- Minor optimization: there is no need to generate the class-wide 8197 -- entity associated with an underlying record view. 8198 8199 if not Is_Underlying_Record_View (Derived_Type) then 8200 Make_Class_Wide_Type (Derived_Type); 8201 end if; 8202 8203 Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def)); 8204 8205 if Has_Discriminants (Derived_Type) 8206 and then Constraint_Present 8207 then 8208 Set_Stored_Constraint 8209 (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs)); 8210 end if; 8211 8212 if Ada_Version >= Ada_2005 then 8213 declare 8214 Ifaces_List : Elist_Id; 8215 8216 begin 8217 -- Checks rules 3.9.4 (13/2 and 14/2) 8218 8219 if Comes_From_Source (Derived_Type) 8220 and then not Is_Private_Type (Derived_Type) 8221 and then Is_Interface (Parent_Type) 8222 and then not Is_Interface (Derived_Type) 8223 then 8224 if Is_Task_Interface (Parent_Type) then 8225 Error_Msg_N 8226 ("(Ada 2005) task type required (RM 3.9.4 (13.2))", 8227 Derived_Type); 8228 8229 elsif Is_Protected_Interface (Parent_Type) then 8230 Error_Msg_N 8231 ("(Ada 2005) protected type required (RM 3.9.4 (14.2))", 8232 Derived_Type); 8233 end if; 8234 end if; 8235 8236 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) 8237 8238 Check_Interfaces (N, Type_Def); 8239 8240 -- Ada 2005 (AI-251): Collect the list of progenitors that are 8241 -- not already in the parents. 8242 8243 Collect_Interfaces 8244 (T => Derived_Type, 8245 Ifaces_List => Ifaces_List, 8246 Exclude_Parents => True); 8247 8248 Set_Interfaces (Derived_Type, Ifaces_List); 8249 8250 -- If the derived type is the anonymous type created for 8251 -- a declaration whose parent has a constraint, propagate 8252 -- the interface list to the source type. This must be done 8253 -- prior to the completion of the analysis of the source type 8254 -- because the components in the extension may contain current 8255 -- instances whose legality depends on some ancestor. 8256 8257 if Is_Itype (Derived_Type) then 8258 declare 8259 Def : constant Node_Id := 8260 Associated_Node_For_Itype (Derived_Type); 8261 begin 8262 if Present (Def) 8263 and then Nkind (Def) = N_Full_Type_Declaration 8264 then 8265 Set_Interfaces 8266 (Defining_Identifier (Def), Ifaces_List); 8267 end if; 8268 end; 8269 end if; 8270 end; 8271 end if; 8272 8273 else 8274 Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base)); 8275 Set_Has_Non_Standard_Rep 8276 (Derived_Type, Has_Non_Standard_Rep (Parent_Base)); 8277 end if; 8278 8279 -- STEP 4: Inherit components from the parent base and constrain them. 8280 -- Apply the second transformation described in point 6. above. 8281 8282 if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims) 8283 or else not Has_Discriminants (Parent_Type) 8284 or else not Is_Constrained (Parent_Type) 8285 then 8286 Constrs := Discs; 8287 else 8288 Constrs := Discriminant_Constraint (Parent_Type); 8289 end if; 8290 8291 Assoc_List := 8292 Inherit_Components 8293 (N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs); 8294 8295 -- STEP 5a: Copy the parent record declaration for untagged types 8296 8297 if not Is_Tagged then 8298 8299 -- Discriminant_Constraint (Derived_Type) has been properly 8300 -- constructed. Save it and temporarily set it to Empty because we 8301 -- do not want the call to New_Copy_Tree below to mess this list. 8302 8303 if Has_Discriminants (Derived_Type) then 8304 Save_Discr_Constr := Discriminant_Constraint (Derived_Type); 8305 Set_Discriminant_Constraint (Derived_Type, No_Elist); 8306 else 8307 Save_Discr_Constr := No_Elist; 8308 end if; 8309 8310 -- Save the Etype field of Derived_Type. It is correctly set now, 8311 -- but the call to New_Copy tree may remap it to point to itself, 8312 -- which is not what we want. Ditto for the Next_Entity field. 8313 8314 Save_Etype := Etype (Derived_Type); 8315 Save_Next_Entity := Next_Entity (Derived_Type); 8316 8317 -- Assoc_List maps all stored discriminants in the Parent_Base to 8318 -- stored discriminants in the Derived_Type. It is fundamental that 8319 -- no types or itypes with discriminants other than the stored 8320 -- discriminants appear in the entities declared inside 8321 -- Derived_Type, since the back end cannot deal with it. 8322 8323 New_Decl := 8324 New_Copy_Tree 8325 (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc); 8326 8327 -- Restore the fields saved prior to the New_Copy_Tree call 8328 -- and compute the stored constraint. 8329 8330 Set_Etype (Derived_Type, Save_Etype); 8331 Set_Next_Entity (Derived_Type, Save_Next_Entity); 8332 8333 if Has_Discriminants (Derived_Type) then 8334 Set_Discriminant_Constraint 8335 (Derived_Type, Save_Discr_Constr); 8336 Set_Stored_Constraint 8337 (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs)); 8338 Replace_Components (Derived_Type, New_Decl); 8339 Set_Has_Implicit_Dereference 8340 (Derived_Type, Has_Implicit_Dereference (Parent_Type)); 8341 end if; 8342 8343 -- Insert the new derived type declaration 8344 8345 Rewrite (N, New_Decl); 8346 8347 -- STEP 5b: Complete the processing for record extensions in generics 8348 8349 -- There is no completion for record extensions declared in the 8350 -- parameter part of a generic, so we need to complete processing for 8351 -- these generic record extensions here. The Record_Type_Definition call 8352 -- will change the Ekind of the components from E_Void to E_Component. 8353 8354 elsif Private_Extension and then Is_Generic_Type (Derived_Type) then 8355 Record_Type_Definition (Empty, Derived_Type); 8356 8357 -- STEP 5c: Process the record extension for non private tagged types 8358 8359 elsif not Private_Extension then 8360 8361 -- Add the _parent field in the derived type 8362 8363 Expand_Record_Extension (Derived_Type, Type_Def); 8364 8365 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the 8366 -- implemented interfaces if we are in expansion mode 8367 8368 if Expander_Active 8369 and then Has_Interfaces (Derived_Type) 8370 then 8371 Add_Interface_Tag_Components (N, Derived_Type); 8372 end if; 8373 8374 -- Analyze the record extension 8375 8376 Record_Type_Definition 8377 (Record_Extension_Part (Type_Def), Derived_Type); 8378 end if; 8379 8380 End_Scope; 8381 8382 -- Nothing else to do if there is an error in the derivation. 8383 -- An unusual case: the full view may be derived from a type in an 8384 -- instance, when the partial view was used illegally as an actual 8385 -- in that instance, leading to a circular definition. 8386 8387 if Etype (Derived_Type) = Any_Type 8388 or else Etype (Parent_Type) = Derived_Type 8389 then 8390 return; 8391 end if; 8392 8393 -- Set delayed freeze and then derive subprograms, we need to do 8394 -- this in this order so that derived subprograms inherit the 8395 -- derived freeze if necessary. 8396 8397 Set_Has_Delayed_Freeze (Derived_Type); 8398 8399 if Derive_Subps then 8400 Derive_Subprograms (Parent_Type, Derived_Type); 8401 end if; 8402 8403 -- If we have a private extension which defines a constrained derived 8404 -- type mark as constrained here after we have derived subprograms. See 8405 -- comment on point 9. just above the body of Build_Derived_Record_Type. 8406 8407 if Private_Extension and then Inherit_Discrims then 8408 if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then 8409 Set_Is_Constrained (Derived_Type, True); 8410 Set_Discriminant_Constraint (Derived_Type, Discs); 8411 8412 elsif Is_Constrained (Parent_Type) then 8413 Set_Is_Constrained 8414 (Derived_Type, True); 8415 Set_Discriminant_Constraint 8416 (Derived_Type, Discriminant_Constraint (Parent_Type)); 8417 end if; 8418 end if; 8419 8420 -- Update the class-wide type, which shares the now-completed entity 8421 -- list with its specific type. In case of underlying record views, 8422 -- we do not generate the corresponding class wide entity. 8423 8424 if Is_Tagged 8425 and then not Is_Underlying_Record_View (Derived_Type) 8426 then 8427 Set_First_Entity 8428 (Class_Wide_Type (Derived_Type), First_Entity (Derived_Type)); 8429 Set_Last_Entity 8430 (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type)); 8431 end if; 8432 8433 Check_Function_Writable_Actuals (N); 8434 end Build_Derived_Record_Type; 8435 8436 ------------------------ 8437 -- Build_Derived_Type -- 8438 ------------------------ 8439 8440 procedure Build_Derived_Type 8441 (N : Node_Id; 8442 Parent_Type : Entity_Id; 8443 Derived_Type : Entity_Id; 8444 Is_Completion : Boolean; 8445 Derive_Subps : Boolean := True) 8446 is 8447 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 8448 8449 begin 8450 -- Set common attributes 8451 8452 Set_Scope (Derived_Type, Current_Scope); 8453 8454 Set_Ekind (Derived_Type, Ekind (Parent_Base)); 8455 Set_Etype (Derived_Type, Parent_Base); 8456 Set_Has_Task (Derived_Type, Has_Task (Parent_Base)); 8457 8458 Set_Size_Info (Derived_Type, Parent_Type); 8459 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 8460 Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); 8461 Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); 8462 8463 -- If the parent type is a private subtype, the convention on the base 8464 -- type may be set in the private part, and not propagated to the 8465 -- subtype until later, so we obtain the convention from the base type. 8466 8467 Set_Convention (Derived_Type, Convention (Parent_Base)); 8468 8469 -- Propagate invariant information. The new type has invariants if 8470 -- they are inherited from the parent type, and these invariants can 8471 -- be further inherited, so both flags are set. 8472 8473 -- We similarly inherit predicates 8474 8475 if Has_Predicates (Parent_Type) then 8476 Set_Has_Predicates (Derived_Type); 8477 end if; 8478 8479 -- The derived type inherits the representation clauses of the parent. 8480 -- However, for a private type that is completed by a derivation, there 8481 -- may be operation attributes that have been specified already (stream 8482 -- attributes and External_Tag) and those must be provided. Finally, 8483 -- if the partial view is a private extension, the representation items 8484 -- of the parent have been inherited already, and should not be chained 8485 -- twice to the derived type. 8486 8487 if Is_Tagged_Type (Parent_Type) 8488 and then Present (First_Rep_Item (Derived_Type)) 8489 then 8490 -- The existing items are either operational items or items inherited 8491 -- from a private extension declaration. 8492 8493 declare 8494 Rep : Node_Id; 8495 -- Used to iterate over representation items of the derived type 8496 8497 Last_Rep : Node_Id; 8498 -- Last representation item of the (non-empty) representation 8499 -- item list of the derived type. 8500 8501 Found : Boolean := False; 8502 8503 begin 8504 Rep := First_Rep_Item (Derived_Type); 8505 Last_Rep := Rep; 8506 while Present (Rep) loop 8507 if Rep = First_Rep_Item (Parent_Type) then 8508 Found := True; 8509 exit; 8510 8511 else 8512 Rep := Next_Rep_Item (Rep); 8513 8514 if Present (Rep) then 8515 Last_Rep := Rep; 8516 end if; 8517 end if; 8518 end loop; 8519 8520 -- Here if we either encountered the parent type's first rep 8521 -- item on the derived type's rep item list (in which case 8522 -- Found is True, and we have nothing else to do), or if we 8523 -- reached the last rep item of the derived type, which is 8524 -- Last_Rep, in which case we further chain the parent type's 8525 -- rep items to those of the derived type. 8526 8527 if not Found then 8528 Set_Next_Rep_Item (Last_Rep, First_Rep_Item (Parent_Type)); 8529 end if; 8530 end; 8531 8532 else 8533 Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type)); 8534 end if; 8535 8536 -- If the parent type has delayed rep aspects, then mark the derived 8537 -- type as possibly inheriting a delayed rep aspect. 8538 8539 if Has_Delayed_Rep_Aspects (Parent_Type) then 8540 Set_May_Inherit_Delayed_Rep_Aspects (Derived_Type); 8541 end if; 8542 8543 -- Type dependent processing 8544 8545 case Ekind (Parent_Type) is 8546 when Numeric_Kind => 8547 Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type); 8548 8549 when Array_Kind => 8550 Build_Derived_Array_Type (N, Parent_Type, Derived_Type); 8551 8552 when E_Record_Type 8553 | E_Record_Subtype 8554 | Class_Wide_Kind => 8555 Build_Derived_Record_Type 8556 (N, Parent_Type, Derived_Type, Derive_Subps); 8557 return; 8558 8559 when Enumeration_Kind => 8560 Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type); 8561 8562 when Access_Kind => 8563 Build_Derived_Access_Type (N, Parent_Type, Derived_Type); 8564 8565 when Incomplete_Or_Private_Kind => 8566 Build_Derived_Private_Type 8567 (N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps); 8568 8569 -- For discriminated types, the derivation includes deriving 8570 -- primitive operations. For others it is done below. 8571 8572 if Is_Tagged_Type (Parent_Type) 8573 or else Has_Discriminants (Parent_Type) 8574 or else (Present (Full_View (Parent_Type)) 8575 and then Has_Discriminants (Full_View (Parent_Type))) 8576 then 8577 return; 8578 end if; 8579 8580 when Concurrent_Kind => 8581 Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type); 8582 8583 when others => 8584 raise Program_Error; 8585 end case; 8586 8587 -- Nothing more to do if some error occurred 8588 8589 if Etype (Derived_Type) = Any_Type then 8590 return; 8591 end if; 8592 8593 -- Set delayed freeze and then derive subprograms, we need to do this 8594 -- in this order so that derived subprograms inherit the derived freeze 8595 -- if necessary. 8596 8597 Set_Has_Delayed_Freeze (Derived_Type); 8598 8599 if Derive_Subps then 8600 Derive_Subprograms (Parent_Type, Derived_Type); 8601 end if; 8602 8603 Set_Has_Primitive_Operations 8604 (Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type)); 8605 end Build_Derived_Type; 8606 8607 ----------------------- 8608 -- Build_Discriminal -- 8609 ----------------------- 8610 8611 procedure Build_Discriminal (Discrim : Entity_Id) is 8612 D_Minal : Entity_Id; 8613 CR_Disc : Entity_Id; 8614 8615 begin 8616 -- A discriminal has the same name as the discriminant 8617 8618 D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); 8619 8620 Set_Ekind (D_Minal, E_In_Parameter); 8621 Set_Mechanism (D_Minal, Default_Mechanism); 8622 Set_Etype (D_Minal, Etype (Discrim)); 8623 Set_Scope (D_Minal, Current_Scope); 8624 8625 Set_Discriminal (Discrim, D_Minal); 8626 Set_Discriminal_Link (D_Minal, Discrim); 8627 8628 -- For task types, build at once the discriminants of the corresponding 8629 -- record, which are needed if discriminants are used in entry defaults 8630 -- and in family bounds. 8631 8632 if Is_Concurrent_Type (Current_Scope) 8633 or else Is_Limited_Type (Current_Scope) 8634 then 8635 CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); 8636 8637 Set_Ekind (CR_Disc, E_In_Parameter); 8638 Set_Mechanism (CR_Disc, Default_Mechanism); 8639 Set_Etype (CR_Disc, Etype (Discrim)); 8640 Set_Scope (CR_Disc, Current_Scope); 8641 Set_Discriminal_Link (CR_Disc, Discrim); 8642 Set_CR_Discriminant (Discrim, CR_Disc); 8643 end if; 8644 end Build_Discriminal; 8645 8646 ------------------------------------ 8647 -- Build_Discriminant_Constraints -- 8648 ------------------------------------ 8649 8650 function Build_Discriminant_Constraints 8651 (T : Entity_Id; 8652 Def : Node_Id; 8653 Derived_Def : Boolean := False) return Elist_Id 8654 is 8655 C : constant Node_Id := Constraint (Def); 8656 Nb_Discr : constant Nat := Number_Discriminants (T); 8657 8658 Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty); 8659 -- Saves the expression corresponding to a given discriminant in T 8660 8661 function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat; 8662 -- Return the Position number within array Discr_Expr of a discriminant 8663 -- D within the discriminant list of the discriminated type T. 8664 8665 procedure Process_Discriminant_Expression 8666 (Expr : Node_Id; 8667 D : Entity_Id); 8668 -- If this is a discriminant constraint on a partial view, do not 8669 -- generate an overflow check on the discriminant expression. The check 8670 -- will be generated when constraining the full view. Otherwise the 8671 -- backend creates duplicate symbols for the temporaries corresponding 8672 -- to the expressions to be checked, causing spurious assembler errors. 8673 8674 ------------------ 8675 -- Pos_Of_Discr -- 8676 ------------------ 8677 8678 function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is 8679 Disc : Entity_Id; 8680 8681 begin 8682 Disc := First_Discriminant (T); 8683 for J in Discr_Expr'Range loop 8684 if Disc = D then 8685 return J; 8686 end if; 8687 8688 Next_Discriminant (Disc); 8689 end loop; 8690 8691 -- Note: Since this function is called on discriminants that are 8692 -- known to belong to the discriminated type, falling through the 8693 -- loop with no match signals an internal compiler error. 8694 8695 raise Program_Error; 8696 end Pos_Of_Discr; 8697 8698 ------------------------------------- 8699 -- Process_Discriminant_Expression -- 8700 ------------------------------------- 8701 8702 procedure Process_Discriminant_Expression 8703 (Expr : Node_Id; 8704 D : Entity_Id) 8705 is 8706 BDT : constant Entity_Id := Base_Type (Etype (D)); 8707 8708 begin 8709 -- If this is a discriminant constraint on a partial view, do 8710 -- not generate an overflow on the discriminant expression. The 8711 -- check will be generated when constraining the full view. 8712 8713 if Is_Private_Type (T) 8714 and then Present (Full_View (T)) 8715 then 8716 Analyze_And_Resolve (Expr, BDT, Suppress => Overflow_Check); 8717 else 8718 Analyze_And_Resolve (Expr, BDT); 8719 end if; 8720 end Process_Discriminant_Expression; 8721 8722 -- Declarations local to Build_Discriminant_Constraints 8723 8724 Discr : Entity_Id; 8725 E : Entity_Id; 8726 Elist : constant Elist_Id := New_Elmt_List; 8727 8728 Constr : Node_Id; 8729 Expr : Node_Id; 8730 Id : Node_Id; 8731 Position : Nat; 8732 Found : Boolean; 8733 8734 Discrim_Present : Boolean := False; 8735 8736 -- Start of processing for Build_Discriminant_Constraints 8737 8738 begin 8739 -- The following loop will process positional associations only. 8740 -- For a positional association, the (single) discriminant is 8741 -- implicitly specified by position, in textual order (RM 3.7.2). 8742 8743 Discr := First_Discriminant (T); 8744 Constr := First (Constraints (C)); 8745 for D in Discr_Expr'Range loop 8746 exit when Nkind (Constr) = N_Discriminant_Association; 8747 8748 if No (Constr) then 8749 Error_Msg_N ("too few discriminants given in constraint", C); 8750 return New_Elmt_List; 8751 8752 elsif Nkind (Constr) = N_Range 8753 or else (Nkind (Constr) = N_Attribute_Reference 8754 and then 8755 Attribute_Name (Constr) = Name_Range) 8756 then 8757 Error_Msg_N 8758 ("a range is not a valid discriminant constraint", Constr); 8759 Discr_Expr (D) := Error; 8760 8761 else 8762 Process_Discriminant_Expression (Constr, Discr); 8763 Discr_Expr (D) := Constr; 8764 end if; 8765 8766 Next_Discriminant (Discr); 8767 Next (Constr); 8768 end loop; 8769 8770 if No (Discr) and then Present (Constr) then 8771 Error_Msg_N ("too many discriminants given in constraint", Constr); 8772 return New_Elmt_List; 8773 end if; 8774 8775 -- Named associations can be given in any order, but if both positional 8776 -- and named associations are used in the same discriminant constraint, 8777 -- then positional associations must occur first, at their normal 8778 -- position. Hence once a named association is used, the rest of the 8779 -- discriminant constraint must use only named associations. 8780 8781 while Present (Constr) loop 8782 8783 -- Positional association forbidden after a named association 8784 8785 if Nkind (Constr) /= N_Discriminant_Association then 8786 Error_Msg_N ("positional association follows named one", Constr); 8787 return New_Elmt_List; 8788 8789 -- Otherwise it is a named association 8790 8791 else 8792 -- E records the type of the discriminants in the named 8793 -- association. All the discriminants specified in the same name 8794 -- association must have the same type. 8795 8796 E := Empty; 8797 8798 -- Search the list of discriminants in T to see if the simple name 8799 -- given in the constraint matches any of them. 8800 8801 Id := First (Selector_Names (Constr)); 8802 while Present (Id) loop 8803 Found := False; 8804 8805 -- If Original_Discriminant is present, we are processing a 8806 -- generic instantiation and this is an instance node. We need 8807 -- to find the name of the corresponding discriminant in the 8808 -- actual record type T and not the name of the discriminant in 8809 -- the generic formal. Example: 8810 8811 -- generic 8812 -- type G (D : int) is private; 8813 -- package P is 8814 -- subtype W is G (D => 1); 8815 -- end package; 8816 -- type Rec (X : int) is record ... end record; 8817 -- package Q is new P (G => Rec); 8818 8819 -- At the point of the instantiation, formal type G is Rec 8820 -- and therefore when reanalyzing "subtype W is G (D => 1);" 8821 -- which really looks like "subtype W is Rec (D => 1);" at 8822 -- the point of instantiation, we want to find the discriminant 8823 -- that corresponds to D in Rec, i.e. X. 8824 8825 if Present (Original_Discriminant (Id)) 8826 and then In_Instance 8827 then 8828 Discr := Find_Corresponding_Discriminant (Id, T); 8829 Found := True; 8830 8831 else 8832 Discr := First_Discriminant (T); 8833 while Present (Discr) loop 8834 if Chars (Discr) = Chars (Id) then 8835 Found := True; 8836 exit; 8837 end if; 8838 8839 Next_Discriminant (Discr); 8840 end loop; 8841 8842 if not Found then 8843 Error_Msg_N ("& does not match any discriminant", Id); 8844 return New_Elmt_List; 8845 8846 -- If the parent type is a generic formal, preserve the 8847 -- name of the discriminant for subsequent instances. 8848 -- see comment at the beginning of this if statement. 8849 8850 elsif Is_Generic_Type (Root_Type (T)) then 8851 Set_Original_Discriminant (Id, Discr); 8852 end if; 8853 end if; 8854 8855 Position := Pos_Of_Discr (T, Discr); 8856 8857 if Present (Discr_Expr (Position)) then 8858 Error_Msg_N ("duplicate constraint for discriminant&", Id); 8859 8860 else 8861 -- Each discriminant specified in the same named association 8862 -- must be associated with a separate copy of the 8863 -- corresponding expression. 8864 8865 if Present (Next (Id)) then 8866 Expr := New_Copy_Tree (Expression (Constr)); 8867 Set_Parent (Expr, Parent (Expression (Constr))); 8868 else 8869 Expr := Expression (Constr); 8870 end if; 8871 8872 Discr_Expr (Position) := Expr; 8873 Process_Discriminant_Expression (Expr, Discr); 8874 end if; 8875 8876 -- A discriminant association with more than one discriminant 8877 -- name is only allowed if the named discriminants are all of 8878 -- the same type (RM 3.7.1(8)). 8879 8880 if E = Empty then 8881 E := Base_Type (Etype (Discr)); 8882 8883 elsif Base_Type (Etype (Discr)) /= E then 8884 Error_Msg_N 8885 ("all discriminants in an association " & 8886 "must have the same type", Id); 8887 end if; 8888 8889 Next (Id); 8890 end loop; 8891 end if; 8892 8893 Next (Constr); 8894 end loop; 8895 8896 -- A discriminant constraint must provide exactly one value for each 8897 -- discriminant of the type (RM 3.7.1(8)). 8898 8899 for J in Discr_Expr'Range loop 8900 if No (Discr_Expr (J)) then 8901 Error_Msg_N ("too few discriminants given in constraint", C); 8902 return New_Elmt_List; 8903 end if; 8904 end loop; 8905 8906 -- Determine if there are discriminant expressions in the constraint 8907 8908 for J in Discr_Expr'Range loop 8909 if Denotes_Discriminant 8910 (Discr_Expr (J), Check_Concurrent => True) 8911 then 8912 Discrim_Present := True; 8913 end if; 8914 end loop; 8915 8916 -- Build an element list consisting of the expressions given in the 8917 -- discriminant constraint and apply the appropriate checks. The list 8918 -- is constructed after resolving any named discriminant associations 8919 -- and therefore the expressions appear in the textual order of the 8920 -- discriminants. 8921 8922 Discr := First_Discriminant (T); 8923 for J in Discr_Expr'Range loop 8924 if Discr_Expr (J) /= Error then 8925 Append_Elmt (Discr_Expr (J), Elist); 8926 8927 -- If any of the discriminant constraints is given by a 8928 -- discriminant and we are in a derived type declaration we 8929 -- have a discriminant renaming. Establish link between new 8930 -- and old discriminant. 8931 8932 if Denotes_Discriminant (Discr_Expr (J)) then 8933 if Derived_Def then 8934 Set_Corresponding_Discriminant 8935 (Entity (Discr_Expr (J)), Discr); 8936 end if; 8937 8938 -- Force the evaluation of non-discriminant expressions. 8939 -- If we have found a discriminant in the constraint 3.4(26) 8940 -- and 3.8(18) demand that no range checks are performed are 8941 -- after evaluation. If the constraint is for a component 8942 -- definition that has a per-object constraint, expressions are 8943 -- evaluated but not checked either. In all other cases perform 8944 -- a range check. 8945 8946 else 8947 if Discrim_Present then 8948 null; 8949 8950 elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration 8951 and then 8952 Has_Per_Object_Constraint 8953 (Defining_Identifier (Parent (Parent (Def)))) 8954 then 8955 null; 8956 8957 elsif Is_Access_Type (Etype (Discr)) then 8958 Apply_Constraint_Check (Discr_Expr (J), Etype (Discr)); 8959 8960 else 8961 Apply_Range_Check (Discr_Expr (J), Etype (Discr)); 8962 end if; 8963 8964 Force_Evaluation (Discr_Expr (J)); 8965 end if; 8966 8967 -- Check that the designated type of an access discriminant's 8968 -- expression is not a class-wide type unless the discriminant's 8969 -- designated type is also class-wide. 8970 8971 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type 8972 and then not Is_Class_Wide_Type 8973 (Designated_Type (Etype (Discr))) 8974 and then Etype (Discr_Expr (J)) /= Any_Type 8975 and then Is_Class_Wide_Type 8976 (Designated_Type (Etype (Discr_Expr (J)))) 8977 then 8978 Wrong_Type (Discr_Expr (J), Etype (Discr)); 8979 8980 elsif Is_Access_Type (Etype (Discr)) 8981 and then not Is_Access_Constant (Etype (Discr)) 8982 and then Is_Access_Type (Etype (Discr_Expr (J))) 8983 and then Is_Access_Constant (Etype (Discr_Expr (J))) 8984 then 8985 Error_Msg_NE 8986 ("constraint for discriminant& must be access to variable", 8987 Def, Discr); 8988 end if; 8989 end if; 8990 8991 Next_Discriminant (Discr); 8992 end loop; 8993 8994 return Elist; 8995 end Build_Discriminant_Constraints; 8996 8997 --------------------------------- 8998 -- Build_Discriminated_Subtype -- 8999 --------------------------------- 9000 9001 procedure Build_Discriminated_Subtype 9002 (T : Entity_Id; 9003 Def_Id : Entity_Id; 9004 Elist : Elist_Id; 9005 Related_Nod : Node_Id; 9006 For_Access : Boolean := False) 9007 is 9008 Has_Discrs : constant Boolean := Has_Discriminants (T); 9009 Constrained : constant Boolean := 9010 (Has_Discrs 9011 and then not Is_Empty_Elmt_List (Elist) 9012 and then not Is_Class_Wide_Type (T)) 9013 or else Is_Constrained (T); 9014 9015 begin 9016 if Ekind (T) = E_Record_Type then 9017 if For_Access then 9018 Set_Ekind (Def_Id, E_Private_Subtype); 9019 Set_Is_For_Access_Subtype (Def_Id, True); 9020 else 9021 Set_Ekind (Def_Id, E_Record_Subtype); 9022 end if; 9023 9024 -- Inherit preelaboration flag from base, for types for which it 9025 -- may have been set: records, private types, protected types. 9026 9027 Set_Known_To_Have_Preelab_Init 9028 (Def_Id, Known_To_Have_Preelab_Init (T)); 9029 9030 elsif Ekind (T) = E_Task_Type then 9031 Set_Ekind (Def_Id, E_Task_Subtype); 9032 9033 elsif Ekind (T) = E_Protected_Type then 9034 Set_Ekind (Def_Id, E_Protected_Subtype); 9035 Set_Known_To_Have_Preelab_Init 9036 (Def_Id, Known_To_Have_Preelab_Init (T)); 9037 9038 elsif Is_Private_Type (T) then 9039 Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); 9040 Set_Known_To_Have_Preelab_Init 9041 (Def_Id, Known_To_Have_Preelab_Init (T)); 9042 9043 -- Private subtypes may have private dependents 9044 9045 Set_Private_Dependents (Def_Id, New_Elmt_List); 9046 9047 elsif Is_Class_Wide_Type (T) then 9048 Set_Ekind (Def_Id, E_Class_Wide_Subtype); 9049 9050 else 9051 -- Incomplete type. Attach subtype to list of dependents, to be 9052 -- completed with full view of parent type, unless is it the 9053 -- designated subtype of a record component within an init_proc. 9054 -- This last case arises for a component of an access type whose 9055 -- designated type is incomplete (e.g. a Taft Amendment type). 9056 -- The designated subtype is within an inner scope, and needs no 9057 -- elaboration, because only the access type is needed in the 9058 -- initialization procedure. 9059 9060 Set_Ekind (Def_Id, Ekind (T)); 9061 9062 if For_Access and then Within_Init_Proc then 9063 null; 9064 else 9065 Append_Elmt (Def_Id, Private_Dependents (T)); 9066 end if; 9067 end if; 9068 9069 Set_Etype (Def_Id, T); 9070 Init_Size_Align (Def_Id); 9071 Set_Has_Discriminants (Def_Id, Has_Discrs); 9072 Set_Is_Constrained (Def_Id, Constrained); 9073 9074 Set_First_Entity (Def_Id, First_Entity (T)); 9075 Set_Last_Entity (Def_Id, Last_Entity (T)); 9076 Set_Has_Implicit_Dereference 9077 (Def_Id, Has_Implicit_Dereference (T)); 9078 9079 -- If the subtype is the completion of a private declaration, there may 9080 -- have been representation clauses for the partial view, and they must 9081 -- be preserved. Build_Derived_Type chains the inherited clauses with 9082 -- the ones appearing on the extension. If this comes from a subtype 9083 -- declaration, all clauses are inherited. 9084 9085 if No (First_Rep_Item (Def_Id)) then 9086 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 9087 end if; 9088 9089 if Is_Tagged_Type (T) then 9090 Set_Is_Tagged_Type (Def_Id); 9091 Make_Class_Wide_Type (Def_Id); 9092 end if; 9093 9094 Set_Stored_Constraint (Def_Id, No_Elist); 9095 9096 if Has_Discrs then 9097 Set_Discriminant_Constraint (Def_Id, Elist); 9098 Set_Stored_Constraint_From_Discriminant_Constraint (Def_Id); 9099 end if; 9100 9101 if Is_Tagged_Type (T) then 9102 9103 -- Ada 2005 (AI-251): In case of concurrent types we inherit the 9104 -- concurrent record type (which has the list of primitive 9105 -- operations). 9106 9107 if Ada_Version >= Ada_2005 9108 and then Is_Concurrent_Type (T) 9109 then 9110 Set_Corresponding_Record_Type (Def_Id, 9111 Corresponding_Record_Type (T)); 9112 else 9113 Set_Direct_Primitive_Operations (Def_Id, 9114 Direct_Primitive_Operations (T)); 9115 end if; 9116 9117 Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T)); 9118 end if; 9119 9120 -- Subtypes introduced by component declarations do not need to be 9121 -- marked as delayed, and do not get freeze nodes, because the semantics 9122 -- verifies that the parents of the subtypes are frozen before the 9123 -- enclosing record is frozen. 9124 9125 if not Is_Type (Scope (Def_Id)) then 9126 Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); 9127 9128 if Is_Private_Type (T) 9129 and then Present (Full_View (T)) 9130 then 9131 Conditional_Delay (Def_Id, Full_View (T)); 9132 else 9133 Conditional_Delay (Def_Id, T); 9134 end if; 9135 end if; 9136 9137 if Is_Record_Type (T) then 9138 Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T)); 9139 9140 if Has_Discrs 9141 and then not Is_Empty_Elmt_List (Elist) 9142 and then not For_Access 9143 then 9144 Create_Constrained_Components (Def_Id, Related_Nod, T, Elist); 9145 elsif not For_Access then 9146 Set_Cloned_Subtype (Def_Id, T); 9147 end if; 9148 end if; 9149 end Build_Discriminated_Subtype; 9150 9151 --------------------------- 9152 -- Build_Itype_Reference -- 9153 --------------------------- 9154 9155 procedure Build_Itype_Reference 9156 (Ityp : Entity_Id; 9157 Nod : Node_Id) 9158 is 9159 IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod)); 9160 begin 9161 9162 -- Itype references are only created for use by the back-end 9163 9164 if Inside_A_Generic then 9165 return; 9166 else 9167 Set_Itype (IR, Ityp); 9168 Insert_After (Nod, IR); 9169 end if; 9170 end Build_Itype_Reference; 9171 9172 ------------------------ 9173 -- Build_Scalar_Bound -- 9174 ------------------------ 9175 9176 function Build_Scalar_Bound 9177 (Bound : Node_Id; 9178 Par_T : Entity_Id; 9179 Der_T : Entity_Id) return Node_Id 9180 is 9181 New_Bound : Entity_Id; 9182 9183 begin 9184 -- Note: not clear why this is needed, how can the original bound 9185 -- be unanalyzed at this point? and if it is, what business do we 9186 -- have messing around with it? and why is the base type of the 9187 -- parent type the right type for the resolution. It probably is 9188 -- not. It is OK for the new bound we are creating, but not for 9189 -- the old one??? Still if it never happens, no problem. 9190 9191 Analyze_And_Resolve (Bound, Base_Type (Par_T)); 9192 9193 if Nkind_In (Bound, N_Integer_Literal, N_Real_Literal) then 9194 New_Bound := New_Copy (Bound); 9195 Set_Etype (New_Bound, Der_T); 9196 Set_Analyzed (New_Bound); 9197 9198 elsif Is_Entity_Name (Bound) then 9199 New_Bound := OK_Convert_To (Der_T, New_Copy (Bound)); 9200 9201 -- The following is almost certainly wrong. What business do we have 9202 -- relocating a node (Bound) that is presumably still attached to 9203 -- the tree elsewhere??? 9204 9205 else 9206 New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound)); 9207 end if; 9208 9209 Set_Etype (New_Bound, Der_T); 9210 return New_Bound; 9211 end Build_Scalar_Bound; 9212 9213 -------------------------------- 9214 -- Build_Underlying_Full_View -- 9215 -------------------------------- 9216 9217 procedure Build_Underlying_Full_View 9218 (N : Node_Id; 9219 Typ : Entity_Id; 9220 Par : Entity_Id) 9221 is 9222 Loc : constant Source_Ptr := Sloc (N); 9223 Subt : constant Entity_Id := 9224 Make_Defining_Identifier 9225 (Loc, New_External_Name (Chars (Typ), 'S')); 9226 9227 Constr : Node_Id; 9228 Indic : Node_Id; 9229 C : Node_Id; 9230 Id : Node_Id; 9231 9232 procedure Set_Discriminant_Name (Id : Node_Id); 9233 -- If the derived type has discriminants, they may rename discriminants 9234 -- of the parent. When building the full view of the parent, we need to 9235 -- recover the names of the original discriminants if the constraint is 9236 -- given by named associations. 9237 9238 --------------------------- 9239 -- Set_Discriminant_Name -- 9240 --------------------------- 9241 9242 procedure Set_Discriminant_Name (Id : Node_Id) is 9243 Disc : Entity_Id; 9244 9245 begin 9246 Set_Original_Discriminant (Id, Empty); 9247 9248 if Has_Discriminants (Typ) then 9249 Disc := First_Discriminant (Typ); 9250 while Present (Disc) loop 9251 if Chars (Disc) = Chars (Id) 9252 and then Present (Corresponding_Discriminant (Disc)) 9253 then 9254 Set_Chars (Id, Chars (Corresponding_Discriminant (Disc))); 9255 end if; 9256 Next_Discriminant (Disc); 9257 end loop; 9258 end if; 9259 end Set_Discriminant_Name; 9260 9261 -- Start of processing for Build_Underlying_Full_View 9262 9263 begin 9264 if Nkind (N) = N_Full_Type_Declaration then 9265 Constr := Constraint (Subtype_Indication (Type_Definition (N))); 9266 9267 elsif Nkind (N) = N_Subtype_Declaration then 9268 Constr := New_Copy_Tree (Constraint (Subtype_Indication (N))); 9269 9270 elsif Nkind (N) = N_Component_Declaration then 9271 Constr := 9272 New_Copy_Tree 9273 (Constraint (Subtype_Indication (Component_Definition (N)))); 9274 9275 else 9276 raise Program_Error; 9277 end if; 9278 9279 C := First (Constraints (Constr)); 9280 while Present (C) loop 9281 if Nkind (C) = N_Discriminant_Association then 9282 Id := First (Selector_Names (C)); 9283 while Present (Id) loop 9284 Set_Discriminant_Name (Id); 9285 Next (Id); 9286 end loop; 9287 end if; 9288 9289 Next (C); 9290 end loop; 9291 9292 Indic := 9293 Make_Subtype_Declaration (Loc, 9294 Defining_Identifier => Subt, 9295 Subtype_Indication => 9296 Make_Subtype_Indication (Loc, 9297 Subtype_Mark => New_Occurrence_Of (Par, Loc), 9298 Constraint => New_Copy_Tree (Constr))); 9299 9300 -- If this is a component subtype for an outer itype, it is not 9301 -- a list member, so simply set the parent link for analysis: if 9302 -- the enclosing type does not need to be in a declarative list, 9303 -- neither do the components. 9304 9305 if Is_List_Member (N) 9306 and then Nkind (N) /= N_Component_Declaration 9307 then 9308 Insert_Before (N, Indic); 9309 else 9310 Set_Parent (Indic, Parent (N)); 9311 end if; 9312 9313 Analyze (Indic); 9314 Set_Underlying_Full_View (Typ, Full_View (Subt)); 9315 end Build_Underlying_Full_View; 9316 9317 ------------------------------- 9318 -- Check_Abstract_Overriding -- 9319 ------------------------------- 9320 9321 procedure Check_Abstract_Overriding (T : Entity_Id) is 9322 Alias_Subp : Entity_Id; 9323 Elmt : Elmt_Id; 9324 Op_List : Elist_Id; 9325 Subp : Entity_Id; 9326 Type_Def : Node_Id; 9327 9328 procedure Check_Pragma_Implemented (Subp : Entity_Id); 9329 -- Ada 2012 (AI05-0030): Subprogram Subp overrides an interface routine 9330 -- which has pragma Implemented already set. Check whether Subp's entity 9331 -- kind conforms to the implementation kind of the overridden routine. 9332 9333 procedure Check_Pragma_Implemented 9334 (Subp : Entity_Id; 9335 Iface_Subp : Entity_Id); 9336 -- Ada 2012 (AI05-0030): Subprogram Subp overrides interface routine 9337 -- Iface_Subp and both entities have pragma Implemented already set on 9338 -- them. Check whether the two implementation kinds are conforming. 9339 9340 procedure Inherit_Pragma_Implemented 9341 (Subp : Entity_Id; 9342 Iface_Subp : Entity_Id); 9343 -- Ada 2012 (AI05-0030): Interface primitive Subp overrides interface 9344 -- subprogram Iface_Subp which has been marked by pragma Implemented. 9345 -- Propagate the implementation kind of Iface_Subp to Subp. 9346 9347 ------------------------------ 9348 -- Check_Pragma_Implemented -- 9349 ------------------------------ 9350 9351 procedure Check_Pragma_Implemented (Subp : Entity_Id) is 9352 Iface_Alias : constant Entity_Id := Interface_Alias (Subp); 9353 Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias); 9354 Subp_Alias : constant Entity_Id := Alias (Subp); 9355 Contr_Typ : Entity_Id; 9356 Impl_Subp : Entity_Id; 9357 9358 begin 9359 -- Subp must have an alias since it is a hidden entity used to link 9360 -- an interface subprogram to its overriding counterpart. 9361 9362 pragma Assert (Present (Subp_Alias)); 9363 9364 -- Handle aliases to synchronized wrappers 9365 9366 Impl_Subp := Subp_Alias; 9367 9368 if Is_Primitive_Wrapper (Impl_Subp) then 9369 Impl_Subp := Wrapped_Entity (Impl_Subp); 9370 end if; 9371 9372 -- Extract the type of the controlling formal 9373 9374 Contr_Typ := Etype (First_Formal (Subp_Alias)); 9375 9376 if Is_Concurrent_Record_Type (Contr_Typ) then 9377 Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ); 9378 end if; 9379 9380 -- An interface subprogram whose implementation kind is By_Entry must 9381 -- be implemented by an entry. 9382 9383 if Impl_Kind = Name_By_Entry 9384 and then Ekind (Impl_Subp) /= E_Entry 9385 then 9386 Error_Msg_Node_2 := Iface_Alias; 9387 Error_Msg_NE 9388 ("type & must implement abstract subprogram & with an entry", 9389 Subp_Alias, Contr_Typ); 9390 9391 elsif Impl_Kind = Name_By_Protected_Procedure then 9392 9393 -- An interface subprogram whose implementation kind is By_ 9394 -- Protected_Procedure cannot be implemented by a primitive 9395 -- procedure of a task type. 9396 9397 if Ekind (Contr_Typ) /= E_Protected_Type then 9398 Error_Msg_Node_2 := Contr_Typ; 9399 Error_Msg_NE 9400 ("interface subprogram & cannot be implemented by a " & 9401 "primitive procedure of task type &", Subp_Alias, 9402 Iface_Alias); 9403 9404 -- An interface subprogram whose implementation kind is By_ 9405 -- Protected_Procedure must be implemented by a procedure. 9406 9407 elsif Ekind (Impl_Subp) /= E_Procedure then 9408 Error_Msg_Node_2 := Iface_Alias; 9409 Error_Msg_NE 9410 ("type & must implement abstract subprogram & with a " & 9411 "procedure", Subp_Alias, Contr_Typ); 9412 9413 elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented)) 9414 and then Implementation_Kind (Impl_Subp) /= Impl_Kind 9415 then 9416 Error_Msg_Name_1 := Impl_Kind; 9417 Error_Msg_N 9418 ("overriding operation& must have synchronization%", 9419 Subp_Alias); 9420 end if; 9421 9422 -- If primitive has Optional synchronization, overriding operation 9423 -- must match if it has an explicit synchronization.. 9424 9425 elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented)) 9426 and then Implementation_Kind (Impl_Subp) /= Impl_Kind 9427 then 9428 Error_Msg_Name_1 := Impl_Kind; 9429 Error_Msg_N 9430 ("overriding operation& must have syncrhonization%", 9431 Subp_Alias); 9432 end if; 9433 end Check_Pragma_Implemented; 9434 9435 ------------------------------ 9436 -- Check_Pragma_Implemented -- 9437 ------------------------------ 9438 9439 procedure Check_Pragma_Implemented 9440 (Subp : Entity_Id; 9441 Iface_Subp : Entity_Id) 9442 is 9443 Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); 9444 Subp_Kind : constant Name_Id := Implementation_Kind (Subp); 9445 9446 begin 9447 -- Ada 2012 (AI05-0030): The implementation kinds of an overridden 9448 -- and overriding subprogram are different. In general this is an 9449 -- error except when the implementation kind of the overridden 9450 -- subprograms is By_Any or Optional. 9451 9452 if Iface_Kind /= Subp_Kind 9453 and then Iface_Kind /= Name_By_Any 9454 and then Iface_Kind /= Name_Optional 9455 then 9456 if Iface_Kind = Name_By_Entry then 9457 Error_Msg_N 9458 ("incompatible implementation kind, overridden subprogram " & 9459 "is marked By_Entry", Subp); 9460 else 9461 Error_Msg_N 9462 ("incompatible implementation kind, overridden subprogram " & 9463 "is marked By_Protected_Procedure", Subp); 9464 end if; 9465 end if; 9466 end Check_Pragma_Implemented; 9467 9468 -------------------------------- 9469 -- Inherit_Pragma_Implemented -- 9470 -------------------------------- 9471 9472 procedure Inherit_Pragma_Implemented 9473 (Subp : Entity_Id; 9474 Iface_Subp : Entity_Id) 9475 is 9476 Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); 9477 Loc : constant Source_Ptr := Sloc (Subp); 9478 Impl_Prag : Node_Id; 9479 9480 begin 9481 -- Since the implementation kind is stored as a representation item 9482 -- rather than a flag, create a pragma node. 9483 9484 Impl_Prag := 9485 Make_Pragma (Loc, 9486 Chars => Name_Implemented, 9487 Pragma_Argument_Associations => New_List ( 9488 Make_Pragma_Argument_Association (Loc, 9489 Expression => New_Occurrence_Of (Subp, Loc)), 9490 9491 Make_Pragma_Argument_Association (Loc, 9492 Expression => Make_Identifier (Loc, Iface_Kind)))); 9493 9494 -- The pragma doesn't need to be analyzed because it is internally 9495 -- built. It is safe to directly register it as a rep item since we 9496 -- are only interested in the characters of the implementation kind. 9497 9498 Record_Rep_Item (Subp, Impl_Prag); 9499 end Inherit_Pragma_Implemented; 9500 9501 -- Start of processing for Check_Abstract_Overriding 9502 9503 begin 9504 Op_List := Primitive_Operations (T); 9505 9506 -- Loop to check primitive operations 9507 9508 Elmt := First_Elmt (Op_List); 9509 while Present (Elmt) loop 9510 Subp := Node (Elmt); 9511 Alias_Subp := Alias (Subp); 9512 9513 -- Inherited subprograms are identified by the fact that they do not 9514 -- come from source, and the associated source location is the 9515 -- location of the first subtype of the derived type. 9516 9517 -- Ada 2005 (AI-228): Apply the rules of RM-3.9.3(6/2) for 9518 -- subprograms that "require overriding". 9519 9520 -- Special exception, do not complain about failure to override the 9521 -- stream routines _Input and _Output, as well as the primitive 9522 -- operations used in dispatching selects since we always provide 9523 -- automatic overridings for these subprograms. 9524 9525 -- Also ignore this rule for convention CIL since .NET libraries 9526 -- do bizarre things with interfaces??? 9527 9528 -- The partial view of T may have been a private extension, for 9529 -- which inherited functions dispatching on result are abstract. 9530 -- If the full view is a null extension, there is no need for 9531 -- overriding in Ada 2005, but wrappers need to be built for them 9532 -- (see exp_ch3, Build_Controlling_Function_Wrappers). 9533 9534 if Is_Null_Extension (T) 9535 and then Has_Controlling_Result (Subp) 9536 and then Ada_Version >= Ada_2005 9537 and then Present (Alias_Subp) 9538 and then not Comes_From_Source (Subp) 9539 and then not Is_Abstract_Subprogram (Alias_Subp) 9540 and then not Is_Access_Type (Etype (Subp)) 9541 then 9542 null; 9543 9544 -- Ada 2005 (AI-251): Internal entities of interfaces need no 9545 -- processing because this check is done with the aliased 9546 -- entity 9547 9548 elsif Present (Interface_Alias (Subp)) then 9549 null; 9550 9551 elsif (Is_Abstract_Subprogram (Subp) 9552 or else Requires_Overriding (Subp) 9553 or else 9554 (Has_Controlling_Result (Subp) 9555 and then Present (Alias_Subp) 9556 and then not Comes_From_Source (Subp) 9557 and then Sloc (Subp) = Sloc (First_Subtype (T)))) 9558 and then not Is_TSS (Subp, TSS_Stream_Input) 9559 and then not Is_TSS (Subp, TSS_Stream_Output) 9560 and then not Is_Abstract_Type (T) 9561 and then Convention (T) /= Convention_CIL 9562 and then not Is_Predefined_Interface_Primitive (Subp) 9563 9564 -- Ada 2005 (AI-251): Do not consider hidden entities associated 9565 -- with abstract interface types because the check will be done 9566 -- with the aliased entity (otherwise we generate a duplicated 9567 -- error message). 9568 9569 and then not Present (Interface_Alias (Subp)) 9570 then 9571 if Present (Alias_Subp) then 9572 9573 -- Only perform the check for a derived subprogram when the 9574 -- type has an explicit record extension. This avoids incorrect 9575 -- flagging of abstract subprograms for the case of a type 9576 -- without an extension that is derived from a formal type 9577 -- with a tagged actual (can occur within a private part). 9578 9579 -- Ada 2005 (AI-391): In the case of an inherited function with 9580 -- a controlling result of the type, the rule does not apply if 9581 -- the type is a null extension (unless the parent function 9582 -- itself is abstract, in which case the function must still be 9583 -- be overridden). The expander will generate an overriding 9584 -- wrapper function calling the parent subprogram (see 9585 -- Exp_Ch3.Make_Controlling_Wrapper_Functions). 9586 9587 Type_Def := Type_Definition (Parent (T)); 9588 9589 if Nkind (Type_Def) = N_Derived_Type_Definition 9590 and then Present (Record_Extension_Part (Type_Def)) 9591 and then 9592 (Ada_Version < Ada_2005 9593 or else not Is_Null_Extension (T) 9594 or else Ekind (Subp) = E_Procedure 9595 or else not Has_Controlling_Result (Subp) 9596 or else Is_Abstract_Subprogram (Alias_Subp) 9597 or else Requires_Overriding (Subp) 9598 or else Is_Access_Type (Etype (Subp))) 9599 then 9600 -- Avoid reporting error in case of abstract predefined 9601 -- primitive inherited from interface type because the 9602 -- body of internally generated predefined primitives 9603 -- of tagged types are generated later by Freeze_Type 9604 9605 if Is_Interface (Root_Type (T)) 9606 and then Is_Abstract_Subprogram (Subp) 9607 and then Is_Predefined_Dispatching_Operation (Subp) 9608 and then not Comes_From_Source (Ultimate_Alias (Subp)) 9609 then 9610 null; 9611 9612 else 9613 Error_Msg_NE 9614 ("type must be declared abstract or & overridden", 9615 T, Subp); 9616 9617 -- Traverse the whole chain of aliased subprograms to 9618 -- complete the error notification. This is especially 9619 -- useful for traceability of the chain of entities when 9620 -- the subprogram corresponds with an interface 9621 -- subprogram (which may be defined in another package). 9622 9623 if Present (Alias_Subp) then 9624 declare 9625 E : Entity_Id; 9626 9627 begin 9628 E := Subp; 9629 while Present (Alias (E)) loop 9630 9631 -- Avoid reporting redundant errors on entities 9632 -- inherited from interfaces 9633 9634 if Sloc (E) /= Sloc (T) then 9635 Error_Msg_Sloc := Sloc (E); 9636 Error_Msg_NE 9637 ("\& has been inherited #", T, Subp); 9638 end if; 9639 9640 E := Alias (E); 9641 end loop; 9642 9643 Error_Msg_Sloc := Sloc (E); 9644 9645 -- AI05-0068: report if there is an overriding 9646 -- non-abstract subprogram that is invisible. 9647 9648 if Is_Hidden (E) 9649 and then not Is_Abstract_Subprogram (E) 9650 then 9651 Error_Msg_NE 9652 ("\& subprogram# is not visible", 9653 T, Subp); 9654 9655 else 9656 Error_Msg_NE 9657 ("\& has been inherited from subprogram #", 9658 T, Subp); 9659 end if; 9660 end; 9661 end if; 9662 end if; 9663 9664 -- Ada 2005 (AI-345): Protected or task type implementing 9665 -- abstract interfaces. 9666 9667 elsif Is_Concurrent_Record_Type (T) 9668 and then Present (Interfaces (T)) 9669 then 9670 -- If an inherited subprogram is implemented by a protected 9671 -- procedure or an entry, then the first parameter of the 9672 -- inherited subprogram shall be of mode OUT or IN OUT, or 9673 -- an access-to-variable parameter (RM 9.4(11.9/3)) 9674 9675 if Is_Protected_Type (Corresponding_Concurrent_Type (T)) 9676 and then Ekind (First_Formal (Subp)) = E_In_Parameter 9677 and then Ekind (Subp) /= E_Function 9678 and then not Is_Predefined_Dispatching_Operation (Subp) 9679 then 9680 Error_Msg_PT (T, Subp); 9681 9682 -- Some other kind of overriding failure 9683 9684 else 9685 Error_Msg_NE 9686 ("interface subprogram & must be overridden", 9687 T, Subp); 9688 9689 -- Examine primitive operations of synchronized type, 9690 -- to find homonyms that have the wrong profile. 9691 9692 declare 9693 Prim : Entity_Id; 9694 9695 begin 9696 Prim := 9697 First_Entity (Corresponding_Concurrent_Type (T)); 9698 while Present (Prim) loop 9699 if Chars (Prim) = Chars (Subp) then 9700 Error_Msg_NE 9701 ("profile is not type conformant with " 9702 & "prefixed view profile of " 9703 & "inherited operation&", Prim, Subp); 9704 end if; 9705 9706 Next_Entity (Prim); 9707 end loop; 9708 end; 9709 end if; 9710 end if; 9711 9712 else 9713 Error_Msg_Node_2 := T; 9714 Error_Msg_N 9715 ("abstract subprogram& not allowed for type&", Subp); 9716 9717 -- Also post unconditional warning on the type (unconditional 9718 -- so that if there are more than one of these cases, we get 9719 -- them all, and not just the first one). 9720 9721 Error_Msg_Node_2 := Subp; 9722 Error_Msg_N ("nonabstract type& has abstract subprogram&!", T); 9723 end if; 9724 end if; 9725 9726 -- Ada 2012 (AI05-0030): Perform checks related to pragma Implemented 9727 9728 -- Subp is an expander-generated procedure which maps an interface 9729 -- alias to a protected wrapper. The interface alias is flagged by 9730 -- pragma Implemented. Ensure that Subp is a procedure when the 9731 -- implementation kind is By_Protected_Procedure or an entry when 9732 -- By_Entry. 9733 9734 if Ada_Version >= Ada_2012 9735 and then Is_Hidden (Subp) 9736 and then Present (Interface_Alias (Subp)) 9737 and then Has_Rep_Pragma (Interface_Alias (Subp), Name_Implemented) 9738 then 9739 Check_Pragma_Implemented (Subp); 9740 end if; 9741 9742 -- Subp is an interface primitive which overrides another interface 9743 -- primitive marked with pragma Implemented. 9744 9745 if Ada_Version >= Ada_2012 9746 and then Present (Overridden_Operation (Subp)) 9747 and then Has_Rep_Pragma 9748 (Overridden_Operation (Subp), Name_Implemented) 9749 then 9750 -- If the overriding routine is also marked by Implemented, check 9751 -- that the two implementation kinds are conforming. 9752 9753 if Has_Rep_Pragma (Subp, Name_Implemented) then 9754 Check_Pragma_Implemented 9755 (Subp => Subp, 9756 Iface_Subp => Overridden_Operation (Subp)); 9757 9758 -- Otherwise the overriding routine inherits the implementation 9759 -- kind from the overridden subprogram. 9760 9761 else 9762 Inherit_Pragma_Implemented 9763 (Subp => Subp, 9764 Iface_Subp => Overridden_Operation (Subp)); 9765 end if; 9766 end if; 9767 9768 -- If the operation is a wrapper for a synchronized primitive, it 9769 -- may be called indirectly through a dispatching select. We assume 9770 -- that it will be referenced elsewhere indirectly, and suppress 9771 -- warnings about an unused entity. 9772 9773 if Is_Primitive_Wrapper (Subp) 9774 and then Present (Wrapped_Entity (Subp)) 9775 then 9776 Set_Referenced (Wrapped_Entity (Subp)); 9777 end if; 9778 9779 Next_Elmt (Elmt); 9780 end loop; 9781 end Check_Abstract_Overriding; 9782 9783 ------------------------------------------------ 9784 -- Check_Access_Discriminant_Requires_Limited -- 9785 ------------------------------------------------ 9786 9787 procedure Check_Access_Discriminant_Requires_Limited 9788 (D : Node_Id; 9789 Loc : Node_Id) 9790 is 9791 begin 9792 -- A discriminant_specification for an access discriminant shall appear 9793 -- only in the declaration for a task or protected type, or for a type 9794 -- with the reserved word 'limited' in its definition or in one of its 9795 -- ancestors (RM 3.7(10)). 9796 9797 -- AI-0063: The proper condition is that type must be immutably limited, 9798 -- or else be a partial view. 9799 9800 if Nkind (Discriminant_Type (D)) = N_Access_Definition then 9801 if Is_Limited_View (Current_Scope) 9802 or else 9803 (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration 9804 and then Limited_Present (Parent (Current_Scope))) 9805 then 9806 null; 9807 9808 else 9809 Error_Msg_N 9810 ("access discriminants allowed only for limited types", Loc); 9811 end if; 9812 end if; 9813 end Check_Access_Discriminant_Requires_Limited; 9814 9815 ----------------------------------- 9816 -- Check_Aliased_Component_Types -- 9817 ----------------------------------- 9818 9819 procedure Check_Aliased_Component_Types (T : Entity_Id) is 9820 C : Entity_Id; 9821 9822 begin 9823 -- ??? Also need to check components of record extensions, but not 9824 -- components of protected types (which are always limited). 9825 9826 -- Ada 2005: AI-363 relaxes this rule, to allow heap objects of such 9827 -- types to be unconstrained. This is safe because it is illegal to 9828 -- create access subtypes to such types with explicit discriminant 9829 -- constraints. 9830 9831 if not Is_Limited_Type (T) then 9832 if Ekind (T) = E_Record_Type then 9833 C := First_Component (T); 9834 while Present (C) loop 9835 if Is_Aliased (C) 9836 and then Has_Discriminants (Etype (C)) 9837 and then not Is_Constrained (Etype (C)) 9838 and then not In_Instance_Body 9839 and then Ada_Version < Ada_2005 9840 then 9841 Error_Msg_N 9842 ("aliased component must be constrained (RM 3.6(11))", 9843 C); 9844 end if; 9845 9846 Next_Component (C); 9847 end loop; 9848 9849 elsif Ekind (T) = E_Array_Type then 9850 if Has_Aliased_Components (T) 9851 and then Has_Discriminants (Component_Type (T)) 9852 and then not Is_Constrained (Component_Type (T)) 9853 and then not In_Instance_Body 9854 and then Ada_Version < Ada_2005 9855 then 9856 Error_Msg_N 9857 ("aliased component type must be constrained (RM 3.6(11))", 9858 T); 9859 end if; 9860 end if; 9861 end if; 9862 end Check_Aliased_Component_Types; 9863 9864 ---------------------- 9865 -- Check_Completion -- 9866 ---------------------- 9867 9868 procedure Check_Completion (Body_Id : Node_Id := Empty) is 9869 E : Entity_Id; 9870 9871 procedure Post_Error; 9872 -- Post error message for lack of completion for entity E 9873 9874 ---------------- 9875 -- Post_Error -- 9876 ---------------- 9877 9878 procedure Post_Error is 9879 9880 procedure Missing_Body; 9881 -- Output missing body message 9882 9883 ------------------ 9884 -- Missing_Body -- 9885 ------------------ 9886 9887 procedure Missing_Body is 9888 begin 9889 -- Spec is in same unit, so we can post on spec 9890 9891 if In_Same_Source_Unit (Body_Id, E) then 9892 Error_Msg_N ("missing body for &", E); 9893 9894 -- Spec is in a separate unit, so we have to post on the body 9895 9896 else 9897 Error_Msg_NE ("missing body for & declared#!", Body_Id, E); 9898 end if; 9899 end Missing_Body; 9900 9901 -- Start of processing for Post_Error 9902 9903 begin 9904 if not Comes_From_Source (E) then 9905 9906 if Ekind_In (E, E_Task_Type, E_Protected_Type) then 9907 -- It may be an anonymous protected type created for a 9908 -- single variable. Post error on variable, if present. 9909 9910 declare 9911 Var : Entity_Id; 9912 9913 begin 9914 Var := First_Entity (Current_Scope); 9915 while Present (Var) loop 9916 exit when Etype (Var) = E 9917 and then Comes_From_Source (Var); 9918 9919 Next_Entity (Var); 9920 end loop; 9921 9922 if Present (Var) then 9923 E := Var; 9924 end if; 9925 end; 9926 end if; 9927 end if; 9928 9929 -- If a generated entity has no completion, then either previous 9930 -- semantic errors have disabled the expansion phase, or else we had 9931 -- missing subunits, or else we are compiling without expansion, 9932 -- or else something is very wrong. 9933 9934 if not Comes_From_Source (E) then 9935 pragma Assert 9936 (Serious_Errors_Detected > 0 9937 or else Configurable_Run_Time_Violations > 0 9938 or else Subunits_Missing 9939 or else not Expander_Active); 9940 return; 9941 9942 -- Here for source entity 9943 9944 else 9945 -- Here if no body to post the error message, so we post the error 9946 -- on the declaration that has no completion. This is not really 9947 -- the right place to post it, think about this later ??? 9948 9949 if No (Body_Id) then 9950 if Is_Type (E) then 9951 Error_Msg_NE 9952 ("missing full declaration for }", Parent (E), E); 9953 else 9954 Error_Msg_NE ("missing body for &", Parent (E), E); 9955 end if; 9956 9957 -- Package body has no completion for a declaration that appears 9958 -- in the corresponding spec. Post error on the body, with a 9959 -- reference to the non-completed declaration. 9960 9961 else 9962 Error_Msg_Sloc := Sloc (E); 9963 9964 if Is_Type (E) then 9965 Error_Msg_NE ("missing full declaration for }!", Body_Id, E); 9966 9967 elsif Is_Overloadable (E) 9968 and then Current_Entity_In_Scope (E) /= E 9969 then 9970 -- It may be that the completion is mistyped and appears as 9971 -- a distinct overloading of the entity. 9972 9973 declare 9974 Candidate : constant Entity_Id := 9975 Current_Entity_In_Scope (E); 9976 Decl : constant Node_Id := 9977 Unit_Declaration_Node (Candidate); 9978 9979 begin 9980 if Is_Overloadable (Candidate) 9981 and then Ekind (Candidate) = Ekind (E) 9982 and then Nkind (Decl) = N_Subprogram_Body 9983 and then Acts_As_Spec (Decl) 9984 then 9985 Check_Type_Conformant (Candidate, E); 9986 9987 else 9988 Missing_Body; 9989 end if; 9990 end; 9991 9992 else 9993 Missing_Body; 9994 end if; 9995 end if; 9996 end if; 9997 end Post_Error; 9998 9999 -- Start of processing for Check_Completion 10000 10001 begin 10002 E := First_Entity (Current_Scope); 10003 while Present (E) loop 10004 if Is_Intrinsic_Subprogram (E) then 10005 null; 10006 10007 -- The following situation requires special handling: a child unit 10008 -- that appears in the context clause of the body of its parent: 10009 10010 -- procedure Parent.Child (...); 10011 10012 -- with Parent.Child; 10013 -- package body Parent is 10014 10015 -- Here Parent.Child appears as a local entity, but should not be 10016 -- flagged as requiring completion, because it is a compilation 10017 -- unit. 10018 10019 -- Ignore missing completion for a subprogram that does not come from 10020 -- source (including the _Call primitive operation of RAS types, 10021 -- which has to have the flag Comes_From_Source for other purposes): 10022 -- we assume that the expander will provide the missing completion. 10023 -- In case of previous errors, other expansion actions that provide 10024 -- bodies for null procedures with not be invoked, so inhibit message 10025 -- in those cases. 10026 10027 -- Note that E_Operator is not in the list that follows, because 10028 -- this kind is reserved for predefined operators, that are 10029 -- intrinsic and do not need completion. 10030 10031 elsif Ekind (E) = E_Function 10032 or else Ekind (E) = E_Procedure 10033 or else Ekind (E) = E_Generic_Function 10034 or else Ekind (E) = E_Generic_Procedure 10035 then 10036 if Has_Completion (E) then 10037 null; 10038 10039 elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then 10040 null; 10041 10042 elsif Is_Subprogram (E) 10043 and then (not Comes_From_Source (E) 10044 or else Chars (E) = Name_uCall) 10045 then 10046 null; 10047 10048 elsif 10049 Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit 10050 then 10051 null; 10052 10053 elsif Nkind (Parent (E)) = N_Procedure_Specification 10054 and then Null_Present (Parent (E)) 10055 and then Serious_Errors_Detected > 0 10056 then 10057 null; 10058 10059 else 10060 Post_Error; 10061 end if; 10062 10063 elsif Is_Entry (E) then 10064 if not Has_Completion (E) and then 10065 (Ekind (Scope (E)) = E_Protected_Object 10066 or else Ekind (Scope (E)) = E_Protected_Type) 10067 then 10068 Post_Error; 10069 end if; 10070 10071 elsif Is_Package_Or_Generic_Package (E) then 10072 if Unit_Requires_Body (E) then 10073 if not Has_Completion (E) 10074 and then Nkind (Parent (Unit_Declaration_Node (E))) /= 10075 N_Compilation_Unit 10076 then 10077 Post_Error; 10078 end if; 10079 10080 elsif not Is_Child_Unit (E) then 10081 May_Need_Implicit_Body (E); 10082 end if; 10083 10084 -- A formal incomplete type (Ada 2012) does not require a completion; 10085 -- other incomplete type declarations do. 10086 10087 elsif Ekind (E) = E_Incomplete_Type 10088 and then No (Underlying_Type (E)) 10089 and then not Is_Generic_Type (E) 10090 then 10091 Post_Error; 10092 10093 elsif (Ekind (E) = E_Task_Type or else 10094 Ekind (E) = E_Protected_Type) 10095 and then not Has_Completion (E) 10096 then 10097 Post_Error; 10098 10099 -- A single task declared in the current scope is a constant, verify 10100 -- that the body of its anonymous type is in the same scope. If the 10101 -- task is defined elsewhere, this may be a renaming declaration for 10102 -- which no completion is needed. 10103 10104 elsif Ekind (E) = E_Constant 10105 and then Ekind (Etype (E)) = E_Task_Type 10106 and then not Has_Completion (Etype (E)) 10107 and then Scope (Etype (E)) = Current_Scope 10108 then 10109 Post_Error; 10110 10111 elsif Ekind (E) = E_Protected_Object 10112 and then not Has_Completion (Etype (E)) 10113 then 10114 Post_Error; 10115 10116 elsif Ekind (E) = E_Record_Type then 10117 if Is_Tagged_Type (E) then 10118 Check_Abstract_Overriding (E); 10119 Check_Conventions (E); 10120 end if; 10121 10122 Check_Aliased_Component_Types (E); 10123 10124 elsif Ekind (E) = E_Array_Type then 10125 Check_Aliased_Component_Types (E); 10126 10127 end if; 10128 10129 Next_Entity (E); 10130 end loop; 10131 end Check_Completion; 10132 10133 ------------------------------------ 10134 -- Check_CPP_Type_Has_No_Defaults -- 10135 ------------------------------------ 10136 10137 procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is 10138 Tdef : constant Node_Id := Type_Definition (Declaration_Node (T)); 10139 Clist : Node_Id; 10140 Comp : Node_Id; 10141 10142 begin 10143 -- Obtain the component list 10144 10145 if Nkind (Tdef) = N_Record_Definition then 10146 Clist := Component_List (Tdef); 10147 else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); 10148 Clist := Component_List (Record_Extension_Part (Tdef)); 10149 end if; 10150 10151 -- Check all components to ensure no default expressions 10152 10153 if Present (Clist) then 10154 Comp := First (Component_Items (Clist)); 10155 while Present (Comp) loop 10156 if Present (Expression (Comp)) then 10157 Error_Msg_N 10158 ("component of imported 'C'P'P type cannot have " 10159 & "default expression", Expression (Comp)); 10160 end if; 10161 10162 Next (Comp); 10163 end loop; 10164 end if; 10165 end Check_CPP_Type_Has_No_Defaults; 10166 10167 ---------------------------- 10168 -- Check_Delta_Expression -- 10169 ---------------------------- 10170 10171 procedure Check_Delta_Expression (E : Node_Id) is 10172 begin 10173 if not (Is_Real_Type (Etype (E))) then 10174 Wrong_Type (E, Any_Real); 10175 10176 elsif not Is_OK_Static_Expression (E) then 10177 Flag_Non_Static_Expr 10178 ("non-static expression used for delta value!", E); 10179 10180 elsif not UR_Is_Positive (Expr_Value_R (E)) then 10181 Error_Msg_N ("delta expression must be positive", E); 10182 10183 else 10184 return; 10185 end if; 10186 10187 -- If any of above errors occurred, then replace the incorrect 10188 -- expression by the real 0.1, which should prevent further errors. 10189 10190 Rewrite (E, 10191 Make_Real_Literal (Sloc (E), Ureal_Tenth)); 10192 Analyze_And_Resolve (E, Standard_Float); 10193 end Check_Delta_Expression; 10194 10195 ----------------------------- 10196 -- Check_Digits_Expression -- 10197 ----------------------------- 10198 10199 procedure Check_Digits_Expression (E : Node_Id) is 10200 begin 10201 if not (Is_Integer_Type (Etype (E))) then 10202 Wrong_Type (E, Any_Integer); 10203 10204 elsif not Is_OK_Static_Expression (E) then 10205 Flag_Non_Static_Expr 10206 ("non-static expression used for digits value!", E); 10207 10208 elsif Expr_Value (E) <= 0 then 10209 Error_Msg_N ("digits value must be greater than zero", E); 10210 10211 else 10212 return; 10213 end if; 10214 10215 -- If any of above errors occurred, then replace the incorrect 10216 -- expression by the integer 1, which should prevent further errors. 10217 10218 Rewrite (E, Make_Integer_Literal (Sloc (E), 1)); 10219 Analyze_And_Resolve (E, Standard_Integer); 10220 10221 end Check_Digits_Expression; 10222 10223 -------------------------- 10224 -- Check_Initialization -- 10225 -------------------------- 10226 10227 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is 10228 begin 10229 if Is_Limited_Type (T) 10230 and then not In_Instance 10231 and then not In_Inlined_Body 10232 then 10233 if not OK_For_Limited_Init (T, Exp) then 10234 10235 -- In GNAT mode, this is just a warning, to allow it to be evilly 10236 -- turned off. Otherwise it is a real error. 10237 10238 if GNAT_Mode then 10239 Error_Msg_N 10240 ("?cannot initialize entities of limited type!", Exp); 10241 10242 elsif Ada_Version < Ada_2005 then 10243 10244 -- The side effect removal machinery may generate illegal Ada 10245 -- code to avoid the usage of access types and 'reference in 10246 -- SPARK mode. Since this is legal code with respect to theorem 10247 -- proving, do not emit the error. 10248 10249 if GNATprove_Mode 10250 and then Nkind (Exp) = N_Function_Call 10251 and then Nkind (Parent (Exp)) = N_Object_Declaration 10252 and then not Comes_From_Source 10253 (Defining_Identifier (Parent (Exp))) 10254 then 10255 null; 10256 10257 else 10258 Error_Msg_N 10259 ("cannot initialize entities of limited type", Exp); 10260 Explain_Limited_Type (T, Exp); 10261 end if; 10262 10263 else 10264 -- Specialize error message according to kind of illegal 10265 -- initial expression. 10266 10267 if Nkind (Exp) = N_Type_Conversion 10268 and then Nkind (Expression (Exp)) = N_Function_Call 10269 then 10270 Error_Msg_N 10271 ("illegal context for call" 10272 & " to function with limited result", Exp); 10273 10274 else 10275 Error_Msg_N 10276 ("initialization of limited object requires aggregate " 10277 & "or function call", Exp); 10278 end if; 10279 end if; 10280 end if; 10281 end if; 10282 end Check_Initialization; 10283 10284 ---------------------- 10285 -- Check_Interfaces -- 10286 ---------------------- 10287 10288 procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is 10289 Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); 10290 10291 Iface : Node_Id; 10292 Iface_Def : Node_Id; 10293 Iface_Typ : Entity_Id; 10294 Parent_Node : Node_Id; 10295 10296 Is_Task : Boolean := False; 10297 -- Set True if parent type or any progenitor is a task interface 10298 10299 Is_Protected : Boolean := False; 10300 -- Set True if parent type or any progenitor is a protected interface 10301 10302 procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); 10303 -- Check that a progenitor is compatible with declaration. 10304 -- Error is posted on Error_Node. 10305 10306 ------------------ 10307 -- Check_Ifaces -- 10308 ------------------ 10309 10310 procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is 10311 Iface_Id : constant Entity_Id := 10312 Defining_Identifier (Parent (Iface_Def)); 10313 Type_Def : Node_Id; 10314 10315 begin 10316 if Nkind (N) = N_Private_Extension_Declaration then 10317 Type_Def := N; 10318 else 10319 Type_Def := Type_Definition (N); 10320 end if; 10321 10322 if Is_Task_Interface (Iface_Id) then 10323 Is_Task := True; 10324 10325 elsif Is_Protected_Interface (Iface_Id) then 10326 Is_Protected := True; 10327 end if; 10328 10329 if Is_Synchronized_Interface (Iface_Id) then 10330 10331 -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private 10332 -- extension derived from a synchronized interface must explicitly 10333 -- be declared synchronized, because the full view will be a 10334 -- synchronized type. 10335 10336 if Nkind (N) = N_Private_Extension_Declaration then 10337 if not Synchronized_Present (N) then 10338 Error_Msg_NE 10339 ("private extension of& must be explicitly synchronized", 10340 N, Iface_Id); 10341 end if; 10342 10343 -- However, by 3.9.4(16/2), a full type that is a record extension 10344 -- is never allowed to derive from a synchronized interface (note 10345 -- that interfaces must be excluded from this check, because those 10346 -- are represented by derived type definitions in some cases). 10347 10348 elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition 10349 and then not Interface_Present (Type_Definition (N)) 10350 then 10351 Error_Msg_N ("record extension cannot derive from synchronized" 10352 & " interface", Error_Node); 10353 end if; 10354 end if; 10355 10356 -- Check that the characteristics of the progenitor are compatible 10357 -- with the explicit qualifier in the declaration. 10358 -- The check only applies to qualifiers that come from source. 10359 -- Limited_Present also appears in the declaration of corresponding 10360 -- records, and the check does not apply to them. 10361 10362 if Limited_Present (Type_Def) 10363 and then not 10364 Is_Concurrent_Record_Type (Defining_Identifier (N)) 10365 then 10366 if Is_Limited_Interface (Parent_Type) 10367 and then not Is_Limited_Interface (Iface_Id) 10368 then 10369 Error_Msg_NE 10370 ("progenitor& must be limited interface", 10371 Error_Node, Iface_Id); 10372 10373 elsif 10374 (Task_Present (Iface_Def) 10375 or else Protected_Present (Iface_Def) 10376 or else Synchronized_Present (Iface_Def)) 10377 and then Nkind (N) /= N_Private_Extension_Declaration 10378 and then not Error_Posted (N) 10379 then 10380 Error_Msg_NE 10381 ("progenitor& must be limited interface", 10382 Error_Node, Iface_Id); 10383 end if; 10384 10385 -- Protected interfaces can only inherit from limited, synchronized 10386 -- or protected interfaces. 10387 10388 elsif Nkind (N) = N_Full_Type_Declaration 10389 and then Protected_Present (Type_Def) 10390 then 10391 if Limited_Present (Iface_Def) 10392 or else Synchronized_Present (Iface_Def) 10393 or else Protected_Present (Iface_Def) 10394 then 10395 null; 10396 10397 elsif Task_Present (Iface_Def) then 10398 Error_Msg_N ("(Ada 2005) protected interface cannot inherit" 10399 & " from task interface", Error_Node); 10400 10401 else 10402 Error_Msg_N ("(Ada 2005) protected interface cannot inherit" 10403 & " from non-limited interface", Error_Node); 10404 end if; 10405 10406 -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from 10407 -- limited and synchronized. 10408 10409 elsif Synchronized_Present (Type_Def) then 10410 if Limited_Present (Iface_Def) 10411 or else Synchronized_Present (Iface_Def) 10412 then 10413 null; 10414 10415 elsif Protected_Present (Iface_Def) 10416 and then Nkind (N) /= N_Private_Extension_Declaration 10417 then 10418 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" 10419 & " from protected interface", Error_Node); 10420 10421 elsif Task_Present (Iface_Def) 10422 and then Nkind (N) /= N_Private_Extension_Declaration 10423 then 10424 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" 10425 & " from task interface", Error_Node); 10426 10427 elsif not Is_Limited_Interface (Iface_Id) then 10428 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" 10429 & " from non-limited interface", Error_Node); 10430 end if; 10431 10432 -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, 10433 -- synchronized or task interfaces. 10434 10435 elsif Nkind (N) = N_Full_Type_Declaration 10436 and then Task_Present (Type_Def) 10437 then 10438 if Limited_Present (Iface_Def) 10439 or else Synchronized_Present (Iface_Def) 10440 or else Task_Present (Iface_Def) 10441 then 10442 null; 10443 10444 elsif Protected_Present (Iface_Def) then 10445 Error_Msg_N ("(Ada 2005) task interface cannot inherit from" 10446 & " protected interface", Error_Node); 10447 10448 else 10449 Error_Msg_N ("(Ada 2005) task interface cannot inherit from" 10450 & " non-limited interface", Error_Node); 10451 end if; 10452 end if; 10453 end Check_Ifaces; 10454 10455 -- Start of processing for Check_Interfaces 10456 10457 begin 10458 if Is_Interface (Parent_Type) then 10459 if Is_Task_Interface (Parent_Type) then 10460 Is_Task := True; 10461 10462 elsif Is_Protected_Interface (Parent_Type) then 10463 Is_Protected := True; 10464 end if; 10465 end if; 10466 10467 if Nkind (N) = N_Private_Extension_Declaration then 10468 10469 -- Check that progenitors are compatible with declaration 10470 10471 Iface := First (Interface_List (Def)); 10472 while Present (Iface) loop 10473 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 10474 10475 Parent_Node := Parent (Base_Type (Iface_Typ)); 10476 Iface_Def := Type_Definition (Parent_Node); 10477 10478 if not Is_Interface (Iface_Typ) then 10479 Diagnose_Interface (Iface, Iface_Typ); 10480 10481 else 10482 Check_Ifaces (Iface_Def, Iface); 10483 end if; 10484 10485 Next (Iface); 10486 end loop; 10487 10488 if Is_Task and Is_Protected then 10489 Error_Msg_N 10490 ("type cannot derive from task and protected interface", N); 10491 end if; 10492 10493 return; 10494 end if; 10495 10496 -- Full type declaration of derived type. 10497 -- Check compatibility with parent if it is interface type 10498 10499 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition 10500 and then Is_Interface (Parent_Type) 10501 then 10502 Parent_Node := Parent (Parent_Type); 10503 10504 -- More detailed checks for interface varieties 10505 10506 Check_Ifaces 10507 (Iface_Def => Type_Definition (Parent_Node), 10508 Error_Node => Subtype_Indication (Type_Definition (N))); 10509 end if; 10510 10511 Iface := First (Interface_List (Def)); 10512 while Present (Iface) loop 10513 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 10514 10515 Parent_Node := Parent (Base_Type (Iface_Typ)); 10516 Iface_Def := Type_Definition (Parent_Node); 10517 10518 if not Is_Interface (Iface_Typ) then 10519 Diagnose_Interface (Iface, Iface_Typ); 10520 10521 else 10522 -- "The declaration of a specific descendant of an interface 10523 -- type freezes the interface type" RM 13.14 10524 10525 Freeze_Before (N, Iface_Typ); 10526 Check_Ifaces (Iface_Def, Error_Node => Iface); 10527 end if; 10528 10529 Next (Iface); 10530 end loop; 10531 10532 if Is_Task and Is_Protected then 10533 Error_Msg_N 10534 ("type cannot derive from task and protected interface", N); 10535 end if; 10536 end Check_Interfaces; 10537 10538 ------------------------------------ 10539 -- Check_Or_Process_Discriminants -- 10540 ------------------------------------ 10541 10542 -- If an incomplete or private type declaration was already given for the 10543 -- type, the discriminants may have already been processed if they were 10544 -- present on the incomplete declaration. In this case a full conformance 10545 -- check has been performed in Find_Type_Name, and we then recheck here 10546 -- some properties that can't be checked on the partial view alone. 10547 -- Otherwise we call Process_Discriminants. 10548 10549 procedure Check_Or_Process_Discriminants 10550 (N : Node_Id; 10551 T : Entity_Id; 10552 Prev : Entity_Id := Empty) 10553 is 10554 begin 10555 if Has_Discriminants (T) then 10556 10557 -- Discriminants are already set on T if they were already present 10558 -- on the partial view. Make them visible to component declarations. 10559 10560 declare 10561 D : Entity_Id; 10562 -- Discriminant on T (full view) referencing expr on partial view 10563 10564 Prev_D : Entity_Id; 10565 -- Entity of corresponding discriminant on partial view 10566 10567 New_D : Node_Id; 10568 -- Discriminant specification for full view, expression is the 10569 -- syntactic copy on full view (which has been checked for 10570 -- conformance with partial view), only used here to post error 10571 -- message. 10572 10573 begin 10574 D := First_Discriminant (T); 10575 New_D := First (Discriminant_Specifications (N)); 10576 while Present (D) loop 10577 Prev_D := Current_Entity (D); 10578 Set_Current_Entity (D); 10579 Set_Is_Immediately_Visible (D); 10580 Set_Homonym (D, Prev_D); 10581 10582 -- Handle the case where there is an untagged partial view and 10583 -- the full view is tagged: must disallow discriminants with 10584 -- defaults, unless compiling for Ada 2012, which allows a 10585 -- limited tagged type to have defaulted discriminants (see 10586 -- AI05-0214). However, suppress error here if it was already 10587 -- reported on the default expression of the partial view. 10588 10589 if Is_Tagged_Type (T) 10590 and then Present (Expression (Parent (D))) 10591 and then (not Is_Limited_Type (Current_Scope) 10592 or else Ada_Version < Ada_2012) 10593 and then not Error_Posted (Expression (Parent (D))) 10594 then 10595 if Ada_Version >= Ada_2012 then 10596 Error_Msg_N 10597 ("discriminants of nonlimited tagged type cannot have" 10598 & " defaults", 10599 Expression (New_D)); 10600 else 10601 Error_Msg_N 10602 ("discriminants of tagged type cannot have defaults", 10603 Expression (New_D)); 10604 end if; 10605 end if; 10606 10607 -- Ada 2005 (AI-230): Access discriminant allowed in 10608 -- non-limited record types. 10609 10610 if Ada_Version < Ada_2005 then 10611 10612 -- This restriction gets applied to the full type here. It 10613 -- has already been applied earlier to the partial view. 10614 10615 Check_Access_Discriminant_Requires_Limited (Parent (D), N); 10616 end if; 10617 10618 Next_Discriminant (D); 10619 Next (New_D); 10620 end loop; 10621 end; 10622 10623 elsif Present (Discriminant_Specifications (N)) then 10624 Process_Discriminants (N, Prev); 10625 end if; 10626 end Check_Or_Process_Discriminants; 10627 10628 ---------------------- 10629 -- Check_Real_Bound -- 10630 ---------------------- 10631 10632 procedure Check_Real_Bound (Bound : Node_Id) is 10633 begin 10634 if not Is_Real_Type (Etype (Bound)) then 10635 Error_Msg_N 10636 ("bound in real type definition must be of real type", Bound); 10637 10638 elsif not Is_OK_Static_Expression (Bound) then 10639 Flag_Non_Static_Expr 10640 ("non-static expression used for real type bound!", Bound); 10641 10642 else 10643 return; 10644 end if; 10645 10646 Rewrite 10647 (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0)); 10648 Analyze (Bound); 10649 Resolve (Bound, Standard_Float); 10650 end Check_Real_Bound; 10651 10652 ------------------------------ 10653 -- Complete_Private_Subtype -- 10654 ------------------------------ 10655 10656 procedure Complete_Private_Subtype 10657 (Priv : Entity_Id; 10658 Full : Entity_Id; 10659 Full_Base : Entity_Id; 10660 Related_Nod : Node_Id) 10661 is 10662 Save_Next_Entity : Entity_Id; 10663 Save_Homonym : Entity_Id; 10664 10665 begin 10666 -- Set semantic attributes for (implicit) private subtype completion. 10667 -- If the full type has no discriminants, then it is a copy of the full 10668 -- view of the base. Otherwise, it is a subtype of the base with a 10669 -- possible discriminant constraint. Save and restore the original 10670 -- Next_Entity field of full to ensure that the calls to Copy_Node 10671 -- do not corrupt the entity chain. 10672 10673 -- Note that the type of the full view is the same entity as the type of 10674 -- the partial view. In this fashion, the subtype has access to the 10675 -- correct view of the parent. 10676 10677 Save_Next_Entity := Next_Entity (Full); 10678 Save_Homonym := Homonym (Priv); 10679 10680 case Ekind (Full_Base) is 10681 when E_Record_Type | 10682 E_Record_Subtype | 10683 Class_Wide_Kind | 10684 Private_Kind | 10685 Task_Kind | 10686 Protected_Kind => 10687 Copy_Node (Priv, Full); 10688 10689 Set_Has_Discriminants 10690 (Full, Has_Discriminants (Full_Base)); 10691 Set_Has_Unknown_Discriminants 10692 (Full, Has_Unknown_Discriminants (Full_Base)); 10693 Set_First_Entity (Full, First_Entity (Full_Base)); 10694 Set_Last_Entity (Full, Last_Entity (Full_Base)); 10695 10696 -- If the underlying base type is constrained, we know that the 10697 -- full view of the subtype is constrained as well (the converse 10698 -- is not necessarily true). 10699 10700 if Is_Constrained (Full_Base) then 10701 Set_Is_Constrained (Full); 10702 end if; 10703 10704 when others => 10705 Copy_Node (Full_Base, Full); 10706 10707 Set_Chars (Full, Chars (Priv)); 10708 Conditional_Delay (Full, Priv); 10709 Set_Sloc (Full, Sloc (Priv)); 10710 end case; 10711 10712 Set_Next_Entity (Full, Save_Next_Entity); 10713 Set_Homonym (Full, Save_Homonym); 10714 Set_Associated_Node_For_Itype (Full, Related_Nod); 10715 10716 -- Set common attributes for all subtypes: kind, convention, etc. 10717 10718 Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); 10719 Set_Convention (Full, Convention (Full_Base)); 10720 10721 -- The Etype of the full view is inconsistent. Gigi needs to see the 10722 -- structural full view, which is what the current scheme gives: 10723 -- the Etype of the full view is the etype of the full base. However, 10724 -- if the full base is a derived type, the full view then looks like 10725 -- a subtype of the parent, not a subtype of the full base. If instead 10726 -- we write: 10727 10728 -- Set_Etype (Full, Full_Base); 10729 10730 -- then we get inconsistencies in the front-end (confusion between 10731 -- views). Several outstanding bugs are related to this ??? 10732 10733 Set_Is_First_Subtype (Full, False); 10734 Set_Scope (Full, Scope (Priv)); 10735 Set_Size_Info (Full, Full_Base); 10736 Set_RM_Size (Full, RM_Size (Full_Base)); 10737 Set_Is_Itype (Full); 10738 10739 -- A subtype of a private-type-without-discriminants, whose full-view 10740 -- has discriminants with default expressions, is not constrained. 10741 10742 if not Has_Discriminants (Priv) then 10743 Set_Is_Constrained (Full, Is_Constrained (Full_Base)); 10744 10745 if Has_Discriminants (Full_Base) then 10746 Set_Discriminant_Constraint 10747 (Full, Discriminant_Constraint (Full_Base)); 10748 10749 -- The partial view may have been indefinite, the full view 10750 -- might not be. 10751 10752 Set_Has_Unknown_Discriminants 10753 (Full, Has_Unknown_Discriminants (Full_Base)); 10754 end if; 10755 end if; 10756 10757 Set_First_Rep_Item (Full, First_Rep_Item (Full_Base)); 10758 Set_Depends_On_Private (Full, Has_Private_Component (Full)); 10759 10760 -- Freeze the private subtype entity if its parent is delayed, and not 10761 -- already frozen. We skip this processing if the type is an anonymous 10762 -- subtype of a record component, or is the corresponding record of a 10763 -- protected type, since ??? 10764 10765 if not Is_Type (Scope (Full)) then 10766 Set_Has_Delayed_Freeze (Full, 10767 Has_Delayed_Freeze (Full_Base) 10768 and then (not Is_Frozen (Full_Base))); 10769 end if; 10770 10771 Set_Freeze_Node (Full, Empty); 10772 Set_Is_Frozen (Full, False); 10773 Set_Full_View (Priv, Full); 10774 10775 if Has_Discriminants (Full) then 10776 Set_Stored_Constraint_From_Discriminant_Constraint (Full); 10777 Set_Stored_Constraint (Priv, Stored_Constraint (Full)); 10778 10779 if Has_Unknown_Discriminants (Full) then 10780 Set_Discriminant_Constraint (Full, No_Elist); 10781 end if; 10782 end if; 10783 10784 if Ekind (Full_Base) = E_Record_Type 10785 and then Has_Discriminants (Full_Base) 10786 and then Has_Discriminants (Priv) -- might not, if errors 10787 and then not Has_Unknown_Discriminants (Priv) 10788 and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv)) 10789 then 10790 Create_Constrained_Components 10791 (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv)); 10792 10793 -- If the full base is itself derived from private, build a congruent 10794 -- subtype of its underlying type, for use by the back end. For a 10795 -- constrained record component, the declaration cannot be placed on 10796 -- the component list, but it must nevertheless be built an analyzed, to 10797 -- supply enough information for Gigi to compute the size of component. 10798 10799 elsif Ekind (Full_Base) in Private_Kind 10800 and then Is_Derived_Type (Full_Base) 10801 and then Has_Discriminants (Full_Base) 10802 and then (Ekind (Current_Scope) /= E_Record_Subtype) 10803 then 10804 if not Is_Itype (Priv) 10805 and then 10806 Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication 10807 then 10808 Build_Underlying_Full_View 10809 (Parent (Priv), Full, Etype (Full_Base)); 10810 10811 elsif Nkind (Related_Nod) = N_Component_Declaration then 10812 Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base)); 10813 end if; 10814 10815 elsif Is_Record_Type (Full_Base) then 10816 10817 -- Show Full is simply a renaming of Full_Base 10818 10819 Set_Cloned_Subtype (Full, Full_Base); 10820 end if; 10821 10822 -- It is unsafe to share the bounds of a scalar type, because the Itype 10823 -- is elaborated on demand, and if a bound is non-static then different 10824 -- orders of elaboration in different units will lead to different 10825 -- external symbols. 10826 10827 if Is_Scalar_Type (Full_Base) then 10828 Set_Scalar_Range (Full, 10829 Make_Range (Sloc (Related_Nod), 10830 Low_Bound => 10831 Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)), 10832 High_Bound => 10833 Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base)))); 10834 10835 -- This completion inherits the bounds of the full parent, but if 10836 -- the parent is an unconstrained floating point type, so is the 10837 -- completion. 10838 10839 if Is_Floating_Point_Type (Full_Base) then 10840 Set_Includes_Infinities 10841 (Scalar_Range (Full), Has_Infinities (Full_Base)); 10842 end if; 10843 end if; 10844 10845 -- ??? It seems that a lot of fields are missing that should be copied 10846 -- from Full_Base to Full. Here are some that are introduced in a 10847 -- non-disruptive way but a cleanup is necessary. 10848 10849 if Is_Tagged_Type (Full_Base) then 10850 Set_Is_Tagged_Type (Full); 10851 Set_Direct_Primitive_Operations (Full, 10852 Direct_Primitive_Operations (Full_Base)); 10853 10854 -- Inherit class_wide type of full_base in case the partial view was 10855 -- not tagged. Otherwise it has already been created when the private 10856 -- subtype was analyzed. 10857 10858 if No (Class_Wide_Type (Full)) then 10859 Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); 10860 end if; 10861 10862 -- If this is a subtype of a protected or task type, constrain its 10863 -- corresponding record, unless this is a subtype without constraints, 10864 -- i.e. a simple renaming as with an actual subtype in an instance. 10865 10866 elsif Is_Concurrent_Type (Full_Base) then 10867 if Has_Discriminants (Full) 10868 and then Present (Corresponding_Record_Type (Full_Base)) 10869 and then 10870 not Is_Empty_Elmt_List (Discriminant_Constraint (Full)) 10871 then 10872 Set_Corresponding_Record_Type (Full, 10873 Constrain_Corresponding_Record 10874 (Full, Corresponding_Record_Type (Full_Base), 10875 Related_Nod, Full_Base)); 10876 10877 else 10878 Set_Corresponding_Record_Type (Full, 10879 Corresponding_Record_Type (Full_Base)); 10880 end if; 10881 end if; 10882 10883 -- Link rep item chain, and also setting of Has_Predicates from private 10884 -- subtype to full subtype, since we will need these on the full subtype 10885 -- to create the predicate function. Note that the full subtype may 10886 -- already have rep items, inherited from the full view of the base 10887 -- type, so we must be sure not to overwrite these entries. 10888 10889 declare 10890 Append : Boolean; 10891 Item : Node_Id; 10892 Next_Item : Node_Id; 10893 10894 begin 10895 Item := First_Rep_Item (Full); 10896 10897 -- If no existing rep items on full type, we can just link directly 10898 -- to the list of items on the private type. 10899 10900 if No (Item) then 10901 Set_First_Rep_Item (Full, First_Rep_Item (Priv)); 10902 10903 -- Otherwise, search to the end of items currently linked to the full 10904 -- subtype and append the private items to the end. However, if Priv 10905 -- and Full already have the same list of rep items, then the append 10906 -- is not done, as that would create a circularity. 10907 10908 elsif Item /= First_Rep_Item (Priv) then 10909 Append := True; 10910 10911 loop 10912 Next_Item := Next_Rep_Item (Item); 10913 exit when No (Next_Item); 10914 Item := Next_Item; 10915 10916 -- If the private view has aspect specifications, the full view 10917 -- inherits them. Since these aspects may already have been 10918 -- attached to the full view during derivation, do not append 10919 -- them if already present. 10920 10921 if Item = First_Rep_Item (Priv) then 10922 Append := False; 10923 exit; 10924 end if; 10925 end loop; 10926 10927 -- And link the private type items at the end of the chain 10928 10929 if Append then 10930 Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); 10931 end if; 10932 end if; 10933 end; 10934 10935 -- Make sure Has_Predicates is set on full type if it is set on the 10936 -- private type. Note that it may already be set on the full type and 10937 -- if so, we don't want to unset it. 10938 10939 if Has_Predicates (Priv) then 10940 Set_Has_Predicates (Full); 10941 end if; 10942 end Complete_Private_Subtype; 10943 10944 ---------------------------- 10945 -- Constant_Redeclaration -- 10946 ---------------------------- 10947 10948 procedure Constant_Redeclaration 10949 (Id : Entity_Id; 10950 N : Node_Id; 10951 T : out Entity_Id) 10952 is 10953 Prev : constant Entity_Id := Current_Entity_In_Scope (Id); 10954 Obj_Def : constant Node_Id := Object_Definition (N); 10955 New_T : Entity_Id; 10956 10957 procedure Check_Possible_Deferred_Completion 10958 (Prev_Id : Entity_Id; 10959 Prev_Obj_Def : Node_Id; 10960 Curr_Obj_Def : Node_Id); 10961 -- Determine whether the two object definitions describe the partial 10962 -- and the full view of a constrained deferred constant. Generate 10963 -- a subtype for the full view and verify that it statically matches 10964 -- the subtype of the partial view. 10965 10966 procedure Check_Recursive_Declaration (Typ : Entity_Id); 10967 -- If deferred constant is an access type initialized with an allocator, 10968 -- check whether there is an illegal recursion in the definition, 10969 -- through a default value of some record subcomponent. This is normally 10970 -- detected when generating init procs, but requires this additional 10971 -- mechanism when expansion is disabled. 10972 10973 ---------------------------------------- 10974 -- Check_Possible_Deferred_Completion -- 10975 ---------------------------------------- 10976 10977 procedure Check_Possible_Deferred_Completion 10978 (Prev_Id : Entity_Id; 10979 Prev_Obj_Def : Node_Id; 10980 Curr_Obj_Def : Node_Id) 10981 is 10982 begin 10983 if Nkind (Prev_Obj_Def) = N_Subtype_Indication 10984 and then Present (Constraint (Prev_Obj_Def)) 10985 and then Nkind (Curr_Obj_Def) = N_Subtype_Indication 10986 and then Present (Constraint (Curr_Obj_Def)) 10987 then 10988 declare 10989 Loc : constant Source_Ptr := Sloc (N); 10990 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); 10991 Decl : constant Node_Id := 10992 Make_Subtype_Declaration (Loc, 10993 Defining_Identifier => Def_Id, 10994 Subtype_Indication => 10995 Relocate_Node (Curr_Obj_Def)); 10996 10997 begin 10998 Insert_Before_And_Analyze (N, Decl); 10999 Set_Etype (Id, Def_Id); 11000 11001 if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then 11002 Error_Msg_Sloc := Sloc (Prev_Id); 11003 Error_Msg_N ("subtype does not statically match deferred " & 11004 "declaration#", N); 11005 end if; 11006 end; 11007 end if; 11008 end Check_Possible_Deferred_Completion; 11009 11010 --------------------------------- 11011 -- Check_Recursive_Declaration -- 11012 --------------------------------- 11013 11014 procedure Check_Recursive_Declaration (Typ : Entity_Id) is 11015 Comp : Entity_Id; 11016 11017 begin 11018 if Is_Record_Type (Typ) then 11019 Comp := First_Component (Typ); 11020 while Present (Comp) loop 11021 if Comes_From_Source (Comp) then 11022 if Present (Expression (Parent (Comp))) 11023 and then Is_Entity_Name (Expression (Parent (Comp))) 11024 and then Entity (Expression (Parent (Comp))) = Prev 11025 then 11026 Error_Msg_Sloc := Sloc (Parent (Comp)); 11027 Error_Msg_NE 11028 ("illegal circularity with declaration for&#", 11029 N, Comp); 11030 return; 11031 11032 elsif Is_Record_Type (Etype (Comp)) then 11033 Check_Recursive_Declaration (Etype (Comp)); 11034 end if; 11035 end if; 11036 11037 Next_Component (Comp); 11038 end loop; 11039 end if; 11040 end Check_Recursive_Declaration; 11041 11042 -- Start of processing for Constant_Redeclaration 11043 11044 begin 11045 if Nkind (Parent (Prev)) = N_Object_Declaration then 11046 if Nkind (Object_Definition 11047 (Parent (Prev))) = N_Subtype_Indication 11048 then 11049 -- Find type of new declaration. The constraints of the two 11050 -- views must match statically, but there is no point in 11051 -- creating an itype for the full view. 11052 11053 if Nkind (Obj_Def) = N_Subtype_Indication then 11054 Find_Type (Subtype_Mark (Obj_Def)); 11055 New_T := Entity (Subtype_Mark (Obj_Def)); 11056 11057 else 11058 Find_Type (Obj_Def); 11059 New_T := Entity (Obj_Def); 11060 end if; 11061 11062 T := Etype (Prev); 11063 11064 else 11065 -- The full view may impose a constraint, even if the partial 11066 -- view does not, so construct the subtype. 11067 11068 New_T := Find_Type_Of_Object (Obj_Def, N); 11069 T := New_T; 11070 end if; 11071 11072 else 11073 -- Current declaration is illegal, diagnosed below in Enter_Name 11074 11075 T := Empty; 11076 New_T := Any_Type; 11077 end if; 11078 11079 -- If previous full declaration or a renaming declaration exists, or if 11080 -- a homograph is present, let Enter_Name handle it, either with an 11081 -- error or with the removal of an overridden implicit subprogram. 11082 -- The previous one is a full declaration if it has an expression 11083 -- (which in the case of an aggregate is indicated by the Init flag). 11084 11085 if Ekind (Prev) /= E_Constant 11086 or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration 11087 or else Present (Expression (Parent (Prev))) 11088 or else Has_Init_Expression (Parent (Prev)) 11089 or else Present (Full_View (Prev)) 11090 then 11091 Enter_Name (Id); 11092 11093 -- Verify that types of both declarations match, or else that both types 11094 -- are anonymous access types whose designated subtypes statically match 11095 -- (as allowed in Ada 2005 by AI-385). 11096 11097 elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) 11098 and then 11099 (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type 11100 or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type 11101 or else Is_Access_Constant (Etype (New_T)) /= 11102 Is_Access_Constant (Etype (Prev)) 11103 or else Can_Never_Be_Null (Etype (New_T)) /= 11104 Can_Never_Be_Null (Etype (Prev)) 11105 or else Null_Exclusion_Present (Parent (Prev)) /= 11106 Null_Exclusion_Present (Parent (Id)) 11107 or else not Subtypes_Statically_Match 11108 (Designated_Type (Etype (Prev)), 11109 Designated_Type (Etype (New_T)))) 11110 then 11111 Error_Msg_Sloc := Sloc (Prev); 11112 Error_Msg_N ("type does not match declaration#", N); 11113 Set_Full_View (Prev, Id); 11114 Set_Etype (Id, Any_Type); 11115 11116 elsif 11117 Null_Exclusion_Present (Parent (Prev)) 11118 and then not Null_Exclusion_Present (N) 11119 then 11120 Error_Msg_Sloc := Sloc (Prev); 11121 Error_Msg_N ("null-exclusion does not match declaration#", N); 11122 Set_Full_View (Prev, Id); 11123 Set_Etype (Id, Any_Type); 11124 11125 -- If so, process the full constant declaration 11126 11127 else 11128 -- RM 7.4 (6): If the subtype defined by the subtype_indication in 11129 -- the deferred declaration is constrained, then the subtype defined 11130 -- by the subtype_indication in the full declaration shall match it 11131 -- statically. 11132 11133 Check_Possible_Deferred_Completion 11134 (Prev_Id => Prev, 11135 Prev_Obj_Def => Object_Definition (Parent (Prev)), 11136 Curr_Obj_Def => Obj_Def); 11137 11138 Set_Full_View (Prev, Id); 11139 Set_Is_Public (Id, Is_Public (Prev)); 11140 Set_Is_Internal (Id); 11141 Append_Entity (Id, Current_Scope); 11142 11143 -- Check ALIASED present if present before (RM 7.4(7)) 11144 11145 if Is_Aliased (Prev) 11146 and then not Aliased_Present (N) 11147 then 11148 Error_Msg_Sloc := Sloc (Prev); 11149 Error_Msg_N ("ALIASED required (see declaration#)", N); 11150 end if; 11151 11152 -- Check that placement is in private part and that the incomplete 11153 -- declaration appeared in the visible part. 11154 11155 if Ekind (Current_Scope) = E_Package 11156 and then not In_Private_Part (Current_Scope) 11157 then 11158 Error_Msg_Sloc := Sloc (Prev); 11159 Error_Msg_N 11160 ("full constant for declaration#" 11161 & " must be in private part", N); 11162 11163 elsif Ekind (Current_Scope) = E_Package 11164 and then 11165 List_Containing (Parent (Prev)) /= 11166 Visible_Declarations (Package_Specification (Current_Scope)) 11167 then 11168 Error_Msg_N 11169 ("deferred constant must be declared in visible part", 11170 Parent (Prev)); 11171 end if; 11172 11173 if Is_Access_Type (T) 11174 and then Nkind (Expression (N)) = N_Allocator 11175 then 11176 Check_Recursive_Declaration (Designated_Type (T)); 11177 end if; 11178 11179 -- A deferred constant is a visible entity. If type has invariants, 11180 -- verify that the initial value satisfies them. 11181 11182 if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then 11183 Insert_After (N, 11184 Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N)))); 11185 end if; 11186 end if; 11187 end Constant_Redeclaration; 11188 11189 ---------------------- 11190 -- Constrain_Access -- 11191 ---------------------- 11192 11193 procedure Constrain_Access 11194 (Def_Id : in out Entity_Id; 11195 S : Node_Id; 11196 Related_Nod : Node_Id) 11197 is 11198 T : constant Entity_Id := Entity (Subtype_Mark (S)); 11199 Desig_Type : constant Entity_Id := Designated_Type (T); 11200 Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); 11201 Constraint_OK : Boolean := True; 11202 11203 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; 11204 -- Simple predicate to test for defaulted discriminants 11205 -- Shouldn't this be in sem_util??? 11206 11207 --------------------------------- 11208 -- Has_Defaulted_Discriminants -- 11209 --------------------------------- 11210 11211 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is 11212 begin 11213 return Has_Discriminants (Typ) 11214 and then Present (First_Discriminant (Typ)) 11215 and then Present 11216 (Discriminant_Default_Value (First_Discriminant (Typ))); 11217 end Has_Defaulted_Discriminants; 11218 11219 -- Start of processing for Constrain_Access 11220 11221 begin 11222 if Is_Array_Type (Desig_Type) then 11223 Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); 11224 11225 elsif (Is_Record_Type (Desig_Type) 11226 or else Is_Incomplete_Or_Private_Type (Desig_Type)) 11227 and then not Is_Constrained (Desig_Type) 11228 then 11229 -- ??? The following code is a temporary kludge to ignore a 11230 -- discriminant constraint on access type if it is constraining 11231 -- the current record. Avoid creating the implicit subtype of the 11232 -- record we are currently compiling since right now, we cannot 11233 -- handle these. For now, just return the access type itself. 11234 11235 if Desig_Type = Current_Scope 11236 and then No (Def_Id) 11237 then 11238 Set_Ekind (Desig_Subtype, E_Record_Subtype); 11239 Def_Id := Entity (Subtype_Mark (S)); 11240 11241 -- This call added to ensure that the constraint is analyzed 11242 -- (needed for a B test). Note that we still return early from 11243 -- this procedure to avoid recursive processing. ??? 11244 11245 Constrain_Discriminated_Type 11246 (Desig_Subtype, S, Related_Nod, For_Access => True); 11247 return; 11248 end if; 11249 11250 -- Enforce rule that the constraint is illegal if there is an 11251 -- unconstrained view of the designated type. This means that the 11252 -- partial view (either a private type declaration or a derivation 11253 -- from a private type) has no discriminants. (Defect Report 11254 -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001). 11255 11256 -- Rule updated for Ada 2005: The private type is said to have 11257 -- a constrained partial view, given that objects of the type 11258 -- can be declared. Furthermore, the rule applies to all access 11259 -- types, unlike the rule concerning default discriminants (see 11260 -- RM 3.7.1(7/3)) 11261 11262 if (Ekind (T) = E_General_Access_Type 11263 or else Ada_Version >= Ada_2005) 11264 and then Has_Private_Declaration (Desig_Type) 11265 and then In_Open_Scopes (Scope (Desig_Type)) 11266 and then Has_Discriminants (Desig_Type) 11267 then 11268 declare 11269 Pack : constant Node_Id := 11270 Unit_Declaration_Node (Scope (Desig_Type)); 11271 Decls : List_Id; 11272 Decl : Node_Id; 11273 11274 begin 11275 if Nkind (Pack) = N_Package_Declaration then 11276 Decls := Visible_Declarations (Specification (Pack)); 11277 Decl := First (Decls); 11278 while Present (Decl) loop 11279 if (Nkind (Decl) = N_Private_Type_Declaration 11280 and then 11281 Chars (Defining_Identifier (Decl)) = 11282 Chars (Desig_Type)) 11283 11284 or else 11285 (Nkind (Decl) = N_Full_Type_Declaration 11286 and then 11287 Chars (Defining_Identifier (Decl)) = 11288 Chars (Desig_Type) 11289 and then Is_Derived_Type (Desig_Type) 11290 and then 11291 Has_Private_Declaration (Etype (Desig_Type))) 11292 then 11293 if No (Discriminant_Specifications (Decl)) then 11294 Error_Msg_N 11295 ("cannot constrain access type if designated " & 11296 "type has constrained partial view", S); 11297 end if; 11298 11299 exit; 11300 end if; 11301 11302 Next (Decl); 11303 end loop; 11304 end if; 11305 end; 11306 end if; 11307 11308 Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, 11309 For_Access => True); 11310 11311 elsif (Is_Task_Type (Desig_Type) 11312 or else Is_Protected_Type (Desig_Type)) 11313 and then not Is_Constrained (Desig_Type) 11314 then 11315 Constrain_Concurrent 11316 (Desig_Subtype, S, Related_Nod, Desig_Type, ' '); 11317 11318 else 11319 Error_Msg_N ("invalid constraint on access type", S); 11320 Desig_Subtype := Desig_Type; -- Ignore invalid constraint. 11321 Constraint_OK := False; 11322 end if; 11323 11324 if No (Def_Id) then 11325 Def_Id := Create_Itype (E_Access_Subtype, Related_Nod); 11326 else 11327 Set_Ekind (Def_Id, E_Access_Subtype); 11328 end if; 11329 11330 if Constraint_OK then 11331 Set_Etype (Def_Id, Base_Type (T)); 11332 11333 if Is_Private_Type (Desig_Type) then 11334 Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod); 11335 end if; 11336 else 11337 Set_Etype (Def_Id, Any_Type); 11338 end if; 11339 11340 Set_Size_Info (Def_Id, T); 11341 Set_Is_Constrained (Def_Id, Constraint_OK); 11342 Set_Directly_Designated_Type (Def_Id, Desig_Subtype); 11343 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 11344 Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T)); 11345 11346 Conditional_Delay (Def_Id, T); 11347 11348 -- AI-363 : Subtypes of general access types whose designated types have 11349 -- default discriminants are disallowed. In instances, the rule has to 11350 -- be checked against the actual, of which T is the subtype. In a 11351 -- generic body, the rule is checked assuming that the actual type has 11352 -- defaulted discriminants. 11353 11354 if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then 11355 if Ekind (Base_Type (T)) = E_General_Access_Type 11356 and then Has_Defaulted_Discriminants (Desig_Type) 11357 then 11358 if Ada_Version < Ada_2005 then 11359 Error_Msg_N 11360 ("access subtype of general access type would not " & 11361 "be allowed in Ada 2005?y?", S); 11362 else 11363 Error_Msg_N 11364 ("access subtype of general access type not allowed", S); 11365 end if; 11366 11367 Error_Msg_N ("\discriminants have defaults", S); 11368 11369 elsif Is_Access_Type (T) 11370 and then Is_Generic_Type (Desig_Type) 11371 and then Has_Discriminants (Desig_Type) 11372 and then In_Package_Body (Current_Scope) 11373 then 11374 if Ada_Version < Ada_2005 then 11375 Error_Msg_N 11376 ("access subtype would not be allowed in generic body " & 11377 "in Ada 2005?y?", S); 11378 else 11379 Error_Msg_N 11380 ("access subtype not allowed in generic body", S); 11381 end if; 11382 11383 Error_Msg_N 11384 ("\designated type is a discriminated formal", S); 11385 end if; 11386 end if; 11387 end Constrain_Access; 11388 11389 --------------------- 11390 -- Constrain_Array -- 11391 --------------------- 11392 11393 procedure Constrain_Array 11394 (Def_Id : in out Entity_Id; 11395 SI : Node_Id; 11396 Related_Nod : Node_Id; 11397 Related_Id : Entity_Id; 11398 Suffix : Character) 11399 is 11400 C : constant Node_Id := Constraint (SI); 11401 Number_Of_Constraints : Nat := 0; 11402 Index : Node_Id; 11403 S, T : Entity_Id; 11404 Constraint_OK : Boolean := True; 11405 11406 begin 11407 T := Entity (Subtype_Mark (SI)); 11408 11409 if Ekind (T) in Access_Kind then 11410 T := Designated_Type (T); 11411 end if; 11412 11413 -- If an index constraint follows a subtype mark in a subtype indication 11414 -- then the type or subtype denoted by the subtype mark must not already 11415 -- impose an index constraint. The subtype mark must denote either an 11416 -- unconstrained array type or an access type whose designated type 11417 -- is such an array type... (RM 3.6.1) 11418 11419 if Is_Constrained (T) then 11420 Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); 11421 Constraint_OK := False; 11422 11423 else 11424 S := First (Constraints (C)); 11425 while Present (S) loop 11426 Number_Of_Constraints := Number_Of_Constraints + 1; 11427 Next (S); 11428 end loop; 11429 11430 -- In either case, the index constraint must provide a discrete 11431 -- range for each index of the array type and the type of each 11432 -- discrete range must be the same as that of the corresponding 11433 -- index. (RM 3.6.1) 11434 11435 if Number_Of_Constraints /= Number_Dimensions (T) then 11436 Error_Msg_NE ("incorrect number of index constraints for }", C, T); 11437 Constraint_OK := False; 11438 11439 else 11440 S := First (Constraints (C)); 11441 Index := First_Index (T); 11442 Analyze (Index); 11443 11444 -- Apply constraints to each index type 11445 11446 for J in 1 .. Number_Of_Constraints loop 11447 Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J); 11448 Next (Index); 11449 Next (S); 11450 end loop; 11451 11452 end if; 11453 end if; 11454 11455 if No (Def_Id) then 11456 Def_Id := 11457 Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix); 11458 Set_Parent (Def_Id, Related_Nod); 11459 11460 else 11461 Set_Ekind (Def_Id, E_Array_Subtype); 11462 end if; 11463 11464 Set_Size_Info (Def_Id, (T)); 11465 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 11466 Set_Etype (Def_Id, Base_Type (T)); 11467 11468 if Constraint_OK then 11469 Set_First_Index (Def_Id, First (Constraints (C))); 11470 else 11471 Set_First_Index (Def_Id, First_Index (T)); 11472 end if; 11473 11474 Set_Is_Constrained (Def_Id, True); 11475 Set_Is_Aliased (Def_Id, Is_Aliased (T)); 11476 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 11477 11478 Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T)); 11479 Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T)); 11480 11481 -- A subtype does not inherit the packed_array_type of is parent. We 11482 -- need to initialize the attribute because if Def_Id is previously 11483 -- analyzed through a limited_with clause, it will have the attributes 11484 -- of an incomplete type, one of which is an Elist that overlaps the 11485 -- Packed_Array_Type field. 11486 11487 Set_Packed_Array_Type (Def_Id, Empty); 11488 11489 -- Build a freeze node if parent still needs one. Also make sure that 11490 -- the Depends_On_Private status is set because the subtype will need 11491 -- reprocessing at the time the base type does, and also we must set a 11492 -- conditional delay. 11493 11494 Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); 11495 Conditional_Delay (Def_Id, T); 11496 end Constrain_Array; 11497 11498 ------------------------------ 11499 -- Constrain_Component_Type -- 11500 ------------------------------ 11501 11502 function Constrain_Component_Type 11503 (Comp : Entity_Id; 11504 Constrained_Typ : Entity_Id; 11505 Related_Node : Node_Id; 11506 Typ : Entity_Id; 11507 Constraints : Elist_Id) return Entity_Id 11508 is 11509 Loc : constant Source_Ptr := Sloc (Constrained_Typ); 11510 Compon_Type : constant Entity_Id := Etype (Comp); 11511 Array_Comp : Node_Id; 11512 11513 function Build_Constrained_Array_Type 11514 (Old_Type : Entity_Id) return Entity_Id; 11515 -- If Old_Type is an array type, one of whose indexes is constrained 11516 -- by a discriminant, build an Itype whose constraint replaces the 11517 -- discriminant with its value in the constraint. 11518 11519 function Build_Constrained_Discriminated_Type 11520 (Old_Type : Entity_Id) return Entity_Id; 11521 -- Ditto for record components 11522 11523 function Build_Constrained_Access_Type 11524 (Old_Type : Entity_Id) return Entity_Id; 11525 -- Ditto for access types. Makes use of previous two functions, to 11526 -- constrain designated type. 11527 11528 function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id; 11529 -- T is an array or discriminated type, C is a list of constraints 11530 -- that apply to T. This routine builds the constrained subtype. 11531 11532 function Is_Discriminant (Expr : Node_Id) return Boolean; 11533 -- Returns True if Expr is a discriminant 11534 11535 function Get_Discr_Value (Discrim : Entity_Id) return Node_Id; 11536 -- Find the value of discriminant Discrim in Constraint 11537 11538 ----------------------------------- 11539 -- Build_Constrained_Access_Type -- 11540 ----------------------------------- 11541 11542 function Build_Constrained_Access_Type 11543 (Old_Type : Entity_Id) return Entity_Id 11544 is 11545 Desig_Type : constant Entity_Id := Designated_Type (Old_Type); 11546 Itype : Entity_Id; 11547 Desig_Subtype : Entity_Id; 11548 Scop : Entity_Id; 11549 11550 begin 11551 -- if the original access type was not embedded in the enclosing 11552 -- type definition, there is no need to produce a new access 11553 -- subtype. In fact every access type with an explicit constraint 11554 -- generates an itype whose scope is the enclosing record. 11555 11556 if not Is_Type (Scope (Old_Type)) then 11557 return Old_Type; 11558 11559 elsif Is_Array_Type (Desig_Type) then 11560 Desig_Subtype := Build_Constrained_Array_Type (Desig_Type); 11561 11562 elsif Has_Discriminants (Desig_Type) then 11563 11564 -- This may be an access type to an enclosing record type for 11565 -- which we are constructing the constrained components. Return 11566 -- the enclosing record subtype. This is not always correct, 11567 -- but avoids infinite recursion. ??? 11568 11569 Desig_Subtype := Any_Type; 11570 11571 for J in reverse 0 .. Scope_Stack.Last loop 11572 Scop := Scope_Stack.Table (J).Entity; 11573 11574 if Is_Type (Scop) 11575 and then Base_Type (Scop) = Base_Type (Desig_Type) 11576 then 11577 Desig_Subtype := Scop; 11578 end if; 11579 11580 exit when not Is_Type (Scop); 11581 end loop; 11582 11583 if Desig_Subtype = Any_Type then 11584 Desig_Subtype := 11585 Build_Constrained_Discriminated_Type (Desig_Type); 11586 end if; 11587 11588 else 11589 return Old_Type; 11590 end if; 11591 11592 if Desig_Subtype /= Desig_Type then 11593 11594 -- The Related_Node better be here or else we won't be able 11595 -- to attach new itypes to a node in the tree. 11596 11597 pragma Assert (Present (Related_Node)); 11598 11599 Itype := Create_Itype (E_Access_Subtype, Related_Node); 11600 11601 Set_Etype (Itype, Base_Type (Old_Type)); 11602 Set_Size_Info (Itype, (Old_Type)); 11603 Set_Directly_Designated_Type (Itype, Desig_Subtype); 11604 Set_Depends_On_Private (Itype, Has_Private_Component 11605 (Old_Type)); 11606 Set_Is_Access_Constant (Itype, Is_Access_Constant 11607 (Old_Type)); 11608 11609 -- The new itype needs freezing when it depends on a not frozen 11610 -- type and the enclosing subtype needs freezing. 11611 11612 if Has_Delayed_Freeze (Constrained_Typ) 11613 and then not Is_Frozen (Constrained_Typ) 11614 then 11615 Conditional_Delay (Itype, Base_Type (Old_Type)); 11616 end if; 11617 11618 return Itype; 11619 11620 else 11621 return Old_Type; 11622 end if; 11623 end Build_Constrained_Access_Type; 11624 11625 ---------------------------------- 11626 -- Build_Constrained_Array_Type -- 11627 ---------------------------------- 11628 11629 function Build_Constrained_Array_Type 11630 (Old_Type : Entity_Id) return Entity_Id 11631 is 11632 Lo_Expr : Node_Id; 11633 Hi_Expr : Node_Id; 11634 Old_Index : Node_Id; 11635 Range_Node : Node_Id; 11636 Constr_List : List_Id; 11637 11638 Need_To_Create_Itype : Boolean := False; 11639 11640 begin 11641 Old_Index := First_Index (Old_Type); 11642 while Present (Old_Index) loop 11643 Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); 11644 11645 if Is_Discriminant (Lo_Expr) 11646 or else Is_Discriminant (Hi_Expr) 11647 then 11648 Need_To_Create_Itype := True; 11649 end if; 11650 11651 Next_Index (Old_Index); 11652 end loop; 11653 11654 if Need_To_Create_Itype then 11655 Constr_List := New_List; 11656 11657 Old_Index := First_Index (Old_Type); 11658 while Present (Old_Index) loop 11659 Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); 11660 11661 if Is_Discriminant (Lo_Expr) then 11662 Lo_Expr := Get_Discr_Value (Lo_Expr); 11663 end if; 11664 11665 if Is_Discriminant (Hi_Expr) then 11666 Hi_Expr := Get_Discr_Value (Hi_Expr); 11667 end if; 11668 11669 Range_Node := 11670 Make_Range 11671 (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr)); 11672 11673 Append (Range_Node, To => Constr_List); 11674 11675 Next_Index (Old_Index); 11676 end loop; 11677 11678 return Build_Subtype (Old_Type, Constr_List); 11679 11680 else 11681 return Old_Type; 11682 end if; 11683 end Build_Constrained_Array_Type; 11684 11685 ------------------------------------------ 11686 -- Build_Constrained_Discriminated_Type -- 11687 ------------------------------------------ 11688 11689 function Build_Constrained_Discriminated_Type 11690 (Old_Type : Entity_Id) return Entity_Id 11691 is 11692 Expr : Node_Id; 11693 Constr_List : List_Id; 11694 Old_Constraint : Elmt_Id; 11695 11696 Need_To_Create_Itype : Boolean := False; 11697 11698 begin 11699 Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); 11700 while Present (Old_Constraint) loop 11701 Expr := Node (Old_Constraint); 11702 11703 if Is_Discriminant (Expr) then 11704 Need_To_Create_Itype := True; 11705 end if; 11706 11707 Next_Elmt (Old_Constraint); 11708 end loop; 11709 11710 if Need_To_Create_Itype then 11711 Constr_List := New_List; 11712 11713 Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); 11714 while Present (Old_Constraint) loop 11715 Expr := Node (Old_Constraint); 11716 11717 if Is_Discriminant (Expr) then 11718 Expr := Get_Discr_Value (Expr); 11719 end if; 11720 11721 Append (New_Copy_Tree (Expr), To => Constr_List); 11722 11723 Next_Elmt (Old_Constraint); 11724 end loop; 11725 11726 return Build_Subtype (Old_Type, Constr_List); 11727 11728 else 11729 return Old_Type; 11730 end if; 11731 end Build_Constrained_Discriminated_Type; 11732 11733 ------------------- 11734 -- Build_Subtype -- 11735 ------------------- 11736 11737 function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is 11738 Indic : Node_Id; 11739 Subtyp_Decl : Node_Id; 11740 Def_Id : Entity_Id; 11741 Btyp : Entity_Id := Base_Type (T); 11742 11743 begin 11744 -- The Related_Node better be here or else we won't be able to 11745 -- attach new itypes to a node in the tree. 11746 11747 pragma Assert (Present (Related_Node)); 11748 11749 -- If the view of the component's type is incomplete or private 11750 -- with unknown discriminants, then the constraint must be applied 11751 -- to the full type. 11752 11753 if Has_Unknown_Discriminants (Btyp) 11754 and then Present (Underlying_Type (Btyp)) 11755 then 11756 Btyp := Underlying_Type (Btyp); 11757 end if; 11758 11759 Indic := 11760 Make_Subtype_Indication (Loc, 11761 Subtype_Mark => New_Occurrence_Of (Btyp, Loc), 11762 Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C)); 11763 11764 Def_Id := Create_Itype (Ekind (T), Related_Node); 11765 11766 Subtyp_Decl := 11767 Make_Subtype_Declaration (Loc, 11768 Defining_Identifier => Def_Id, 11769 Subtype_Indication => Indic); 11770 11771 Set_Parent (Subtyp_Decl, Parent (Related_Node)); 11772 11773 -- Itypes must be analyzed with checks off (see package Itypes) 11774 11775 Analyze (Subtyp_Decl, Suppress => All_Checks); 11776 11777 return Def_Id; 11778 end Build_Subtype; 11779 11780 --------------------- 11781 -- Get_Discr_Value -- 11782 --------------------- 11783 11784 function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is 11785 D : Entity_Id; 11786 E : Elmt_Id; 11787 11788 begin 11789 -- The discriminant may be declared for the type, in which case we 11790 -- find it by iterating over the list of discriminants. If the 11791 -- discriminant is inherited from a parent type, it appears as the 11792 -- corresponding discriminant of the current type. This will be the 11793 -- case when constraining an inherited component whose constraint is 11794 -- given by a discriminant of the parent. 11795 11796 D := First_Discriminant (Typ); 11797 E := First_Elmt (Constraints); 11798 11799 while Present (D) loop 11800 if D = Entity (Discrim) 11801 or else D = CR_Discriminant (Entity (Discrim)) 11802 or else Corresponding_Discriminant (D) = Entity (Discrim) 11803 then 11804 return Node (E); 11805 end if; 11806 11807 Next_Discriminant (D); 11808 Next_Elmt (E); 11809 end loop; 11810 11811 -- The Corresponding_Discriminant mechanism is incomplete, because 11812 -- the correspondence between new and old discriminants is not one 11813 -- to one: one new discriminant can constrain several old ones. In 11814 -- that case, scan sequentially the stored_constraint, the list of 11815 -- discriminants of the parents, and the constraints. 11816 11817 -- Previous code checked for the present of the Stored_Constraint 11818 -- list for the derived type, but did not use it at all. Should it 11819 -- be present when the component is a discriminated task type? 11820 11821 if Is_Derived_Type (Typ) 11822 and then Scope (Entity (Discrim)) = Etype (Typ) 11823 then 11824 D := First_Discriminant (Etype (Typ)); 11825 E := First_Elmt (Constraints); 11826 while Present (D) loop 11827 if D = Entity (Discrim) then 11828 return Node (E); 11829 end if; 11830 11831 Next_Discriminant (D); 11832 Next_Elmt (E); 11833 end loop; 11834 end if; 11835 11836 -- Something is wrong if we did not find the value 11837 11838 raise Program_Error; 11839 end Get_Discr_Value; 11840 11841 --------------------- 11842 -- Is_Discriminant -- 11843 --------------------- 11844 11845 function Is_Discriminant (Expr : Node_Id) return Boolean is 11846 Discrim_Scope : Entity_Id; 11847 11848 begin 11849 if Denotes_Discriminant (Expr) then 11850 Discrim_Scope := Scope (Entity (Expr)); 11851 11852 -- Either we have a reference to one of Typ's discriminants, 11853 11854 pragma Assert (Discrim_Scope = Typ 11855 11856 -- or to the discriminants of the parent type, in the case 11857 -- of a derivation of a tagged type with variants. 11858 11859 or else Discrim_Scope = Etype (Typ) 11860 or else Full_View (Discrim_Scope) = Etype (Typ) 11861 11862 -- or same as above for the case where the discriminants 11863 -- were declared in Typ's private view. 11864 11865 or else (Is_Private_Type (Discrim_Scope) 11866 and then Chars (Discrim_Scope) = Chars (Typ)) 11867 11868 -- or else we are deriving from the full view and the 11869 -- discriminant is declared in the private entity. 11870 11871 or else (Is_Private_Type (Typ) 11872 and then Chars (Discrim_Scope) = Chars (Typ)) 11873 11874 -- Or we are constrained the corresponding record of a 11875 -- synchronized type that completes a private declaration. 11876 11877 or else (Is_Concurrent_Record_Type (Typ) 11878 and then 11879 Corresponding_Concurrent_Type (Typ) = Discrim_Scope) 11880 11881 -- or we have a class-wide type, in which case make sure the 11882 -- discriminant found belongs to the root type. 11883 11884 or else (Is_Class_Wide_Type (Typ) 11885 and then Etype (Typ) = Discrim_Scope)); 11886 11887 return True; 11888 end if; 11889 11890 -- In all other cases we have something wrong 11891 11892 return False; 11893 end Is_Discriminant; 11894 11895 -- Start of processing for Constrain_Component_Type 11896 11897 begin 11898 if Nkind (Parent (Comp)) = N_Component_Declaration 11899 and then Comes_From_Source (Parent (Comp)) 11900 and then Comes_From_Source 11901 (Subtype_Indication (Component_Definition (Parent (Comp)))) 11902 and then 11903 Is_Entity_Name 11904 (Subtype_Indication (Component_Definition (Parent (Comp)))) 11905 then 11906 return Compon_Type; 11907 11908 elsif Is_Array_Type (Compon_Type) then 11909 Array_Comp := Build_Constrained_Array_Type (Compon_Type); 11910 11911 -- If the component of the parent is packed, and the record type is 11912 -- already frozen, as is the case for an itype, the component type 11913 -- itself will not be frozen, and the packed array type for it must 11914 -- be constructed explicitly. Since the creation of packed types is 11915 -- an expansion activity, we only do this if expansion is active. 11916 11917 if Expander_Active 11918 and then Is_Packed (Compon_Type) 11919 and then Is_Frozen (Current_Scope) 11920 then 11921 Create_Packed_Array_Type (Array_Comp); 11922 end if; 11923 11924 return Array_Comp; 11925 11926 elsif Has_Discriminants (Compon_Type) then 11927 return Build_Constrained_Discriminated_Type (Compon_Type); 11928 11929 elsif Is_Access_Type (Compon_Type) then 11930 return Build_Constrained_Access_Type (Compon_Type); 11931 11932 else 11933 return Compon_Type; 11934 end if; 11935 end Constrain_Component_Type; 11936 11937 -------------------------- 11938 -- Constrain_Concurrent -- 11939 -------------------------- 11940 11941 -- For concurrent types, the associated record value type carries the same 11942 -- discriminants, so when we constrain a concurrent type, we must constrain 11943 -- the corresponding record type as well. 11944 11945 procedure Constrain_Concurrent 11946 (Def_Id : in out Entity_Id; 11947 SI : Node_Id; 11948 Related_Nod : Node_Id; 11949 Related_Id : Entity_Id; 11950 Suffix : Character) 11951 is 11952 -- Retrieve Base_Type to ensure getting to the concurrent type in the 11953 -- case of a private subtype (needed when only doing semantic analysis). 11954 11955 T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI))); 11956 T_Val : Entity_Id; 11957 11958 begin 11959 if Ekind (T_Ent) in Access_Kind then 11960 T_Ent := Designated_Type (T_Ent); 11961 end if; 11962 11963 T_Val := Corresponding_Record_Type (T_Ent); 11964 11965 if Present (T_Val) then 11966 11967 if No (Def_Id) then 11968 Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 11969 end if; 11970 11971 Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); 11972 11973 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 11974 Set_Corresponding_Record_Type (Def_Id, 11975 Constrain_Corresponding_Record 11976 (Def_Id, T_Val, Related_Nod, Related_Id)); 11977 11978 else 11979 -- If there is no associated record, expansion is disabled and this 11980 -- is a generic context. Create a subtype in any case, so that 11981 -- semantic analysis can proceed. 11982 11983 if No (Def_Id) then 11984 Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 11985 end if; 11986 11987 Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); 11988 end if; 11989 end Constrain_Concurrent; 11990 11991 ------------------------------------ 11992 -- Constrain_Corresponding_Record -- 11993 ------------------------------------ 11994 11995 function Constrain_Corresponding_Record 11996 (Prot_Subt : Entity_Id; 11997 Corr_Rec : Entity_Id; 11998 Related_Nod : Node_Id; 11999 Related_Id : Entity_Id) return Entity_Id 12000 is 12001 T_Sub : constant Entity_Id := 12002 Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V'); 12003 12004 begin 12005 Set_Etype (T_Sub, Corr_Rec); 12006 Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt)); 12007 Set_Is_Constrained (T_Sub, True); 12008 Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); 12009 Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec)); 12010 12011 -- As elsewhere, we do not want to create a freeze node for this itype 12012 -- if it is created for a constrained component of an enclosing record 12013 -- because references to outer discriminants will appear out of scope. 12014 12015 if Ekind (Scope (Prot_Subt)) /= E_Record_Type then 12016 Conditional_Delay (T_Sub, Corr_Rec); 12017 else 12018 Set_Is_Frozen (T_Sub); 12019 end if; 12020 12021 if Has_Discriminants (Prot_Subt) then -- False only if errors. 12022 Set_Discriminant_Constraint 12023 (T_Sub, Discriminant_Constraint (Prot_Subt)); 12024 Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub); 12025 Create_Constrained_Components 12026 (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub)); 12027 end if; 12028 12029 Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub)); 12030 12031 return T_Sub; 12032 end Constrain_Corresponding_Record; 12033 12034 ----------------------- 12035 -- Constrain_Decimal -- 12036 ----------------------- 12037 12038 procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is 12039 T : constant Entity_Id := Entity (Subtype_Mark (S)); 12040 C : constant Node_Id := Constraint (S); 12041 Loc : constant Source_Ptr := Sloc (C); 12042 Range_Expr : Node_Id; 12043 Digits_Expr : Node_Id; 12044 Digits_Val : Uint; 12045 Bound_Val : Ureal; 12046 12047 begin 12048 Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype); 12049 12050 if Nkind (C) = N_Range_Constraint then 12051 Range_Expr := Range_Expression (C); 12052 Digits_Val := Digits_Value (T); 12053 12054 else 12055 pragma Assert (Nkind (C) = N_Digits_Constraint); 12056 12057 Check_SPARK_Restriction ("digits constraint is not allowed", S); 12058 12059 Digits_Expr := Digits_Expression (C); 12060 Analyze_And_Resolve (Digits_Expr, Any_Integer); 12061 12062 Check_Digits_Expression (Digits_Expr); 12063 Digits_Val := Expr_Value (Digits_Expr); 12064 12065 if Digits_Val > Digits_Value (T) then 12066 Error_Msg_N 12067 ("digits expression is incompatible with subtype", C); 12068 Digits_Val := Digits_Value (T); 12069 end if; 12070 12071 if Present (Range_Constraint (C)) then 12072 Range_Expr := Range_Expression (Range_Constraint (C)); 12073 else 12074 Range_Expr := Empty; 12075 end if; 12076 end if; 12077 12078 Set_Etype (Def_Id, Base_Type (T)); 12079 Set_Size_Info (Def_Id, (T)); 12080 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 12081 Set_Delta_Value (Def_Id, Delta_Value (T)); 12082 Set_Scale_Value (Def_Id, Scale_Value (T)); 12083 Set_Small_Value (Def_Id, Small_Value (T)); 12084 Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T)); 12085 Set_Digits_Value (Def_Id, Digits_Val); 12086 12087 -- Manufacture range from given digits value if no range present 12088 12089 if No (Range_Expr) then 12090 Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T); 12091 Range_Expr := 12092 Make_Range (Loc, 12093 Low_Bound => 12094 Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))), 12095 High_Bound => 12096 Convert_To (T, Make_Real_Literal (Loc, Bound_Val))); 12097 end if; 12098 12099 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T); 12100 Set_Discrete_RM_Size (Def_Id); 12101 12102 -- Unconditionally delay the freeze, since we cannot set size 12103 -- information in all cases correctly until the freeze point. 12104 12105 Set_Has_Delayed_Freeze (Def_Id); 12106 end Constrain_Decimal; 12107 12108 ---------------------------------- 12109 -- Constrain_Discriminated_Type -- 12110 ---------------------------------- 12111 12112 procedure Constrain_Discriminated_Type 12113 (Def_Id : Entity_Id; 12114 S : Node_Id; 12115 Related_Nod : Node_Id; 12116 For_Access : Boolean := False) 12117 is 12118 E : constant Entity_Id := Entity (Subtype_Mark (S)); 12119 T : Entity_Id; 12120 C : Node_Id; 12121 Elist : Elist_Id := New_Elmt_List; 12122 12123 procedure Fixup_Bad_Constraint; 12124 -- This is called after finding a bad constraint, and after having 12125 -- posted an appropriate error message. The mission is to leave the 12126 -- entity T in as reasonable state as possible. 12127 12128 -------------------------- 12129 -- Fixup_Bad_Constraint -- 12130 -------------------------- 12131 12132 procedure Fixup_Bad_Constraint is 12133 begin 12134 -- Set a reasonable Ekind for the entity. For an incomplete type, 12135 -- we can't do much, but for other types, we can set the proper 12136 -- corresponding subtype kind. 12137 12138 if Ekind (T) = E_Incomplete_Type then 12139 Set_Ekind (Def_Id, Ekind (T)); 12140 else 12141 Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); 12142 end if; 12143 12144 -- Set Etype to the known type, to reduce chances of cascaded errors 12145 12146 Set_Etype (Def_Id, E); 12147 Set_Error_Posted (Def_Id); 12148 end Fixup_Bad_Constraint; 12149 12150 -- Start of processing for Constrain_Discriminated_Type 12151 12152 begin 12153 C := Constraint (S); 12154 12155 -- A discriminant constraint is only allowed in a subtype indication, 12156 -- after a subtype mark. This subtype mark must denote either a type 12157 -- with discriminants, or an access type whose designated type is a 12158 -- type with discriminants. A discriminant constraint specifies the 12159 -- values of these discriminants (RM 3.7.2(5)). 12160 12161 T := Base_Type (Entity (Subtype_Mark (S))); 12162 12163 if Ekind (T) in Access_Kind then 12164 T := Designated_Type (T); 12165 end if; 12166 12167 -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. 12168 -- Avoid generating an error for access-to-incomplete subtypes. 12169 12170 if Ada_Version >= Ada_2005 12171 and then Ekind (T) = E_Incomplete_Type 12172 and then Nkind (Parent (S)) = N_Subtype_Declaration 12173 and then not Is_Itype (Def_Id) 12174 then 12175 -- A little sanity check, emit an error message if the type 12176 -- has discriminants to begin with. Type T may be a regular 12177 -- incomplete type or imported via a limited with clause. 12178 12179 if Has_Discriminants (T) 12180 or else (From_Limited_With (T) 12181 and then Present (Non_Limited_View (T)) 12182 and then Nkind (Parent (Non_Limited_View (T))) = 12183 N_Full_Type_Declaration 12184 and then Present (Discriminant_Specifications 12185 (Parent (Non_Limited_View (T))))) 12186 then 12187 Error_Msg_N 12188 ("(Ada 2005) incomplete subtype may not be constrained", C); 12189 else 12190 Error_Msg_N ("invalid constraint: type has no discriminant", C); 12191 end if; 12192 12193 Fixup_Bad_Constraint; 12194 return; 12195 12196 -- Check that the type has visible discriminants. The type may be 12197 -- a private type with unknown discriminants whose full view has 12198 -- discriminants which are invisible. 12199 12200 elsif not Has_Discriminants (T) 12201 or else 12202 (Has_Unknown_Discriminants (T) 12203 and then Is_Private_Type (T)) 12204 then 12205 Error_Msg_N ("invalid constraint: type has no discriminant", C); 12206 Fixup_Bad_Constraint; 12207 return; 12208 12209 elsif Is_Constrained (E) 12210 or else (Ekind (E) = E_Class_Wide_Subtype 12211 and then Present (Discriminant_Constraint (E))) 12212 then 12213 Error_Msg_N ("type is already constrained", Subtype_Mark (S)); 12214 Fixup_Bad_Constraint; 12215 return; 12216 end if; 12217 12218 -- T may be an unconstrained subtype (e.g. a generic actual). 12219 -- Constraint applies to the base type. 12220 12221 T := Base_Type (T); 12222 12223 Elist := Build_Discriminant_Constraints (T, S); 12224 12225 -- If the list returned was empty we had an error in building the 12226 -- discriminant constraint. We have also already signalled an error 12227 -- in the incomplete type case 12228 12229 if Is_Empty_Elmt_List (Elist) then 12230 Fixup_Bad_Constraint; 12231 return; 12232 end if; 12233 12234 Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access); 12235 end Constrain_Discriminated_Type; 12236 12237 --------------------------- 12238 -- Constrain_Enumeration -- 12239 --------------------------- 12240 12241 procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is 12242 T : constant Entity_Id := Entity (Subtype_Mark (S)); 12243 C : constant Node_Id := Constraint (S); 12244 12245 begin 12246 Set_Ekind (Def_Id, E_Enumeration_Subtype); 12247 12248 Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); 12249 12250 Set_Etype (Def_Id, Base_Type (T)); 12251 Set_Size_Info (Def_Id, (T)); 12252 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 12253 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 12254 12255 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 12256 12257 Set_Discrete_RM_Size (Def_Id); 12258 end Constrain_Enumeration; 12259 12260 ---------------------- 12261 -- Constrain_Float -- 12262 ---------------------- 12263 12264 procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is 12265 T : constant Entity_Id := Entity (Subtype_Mark (S)); 12266 C : Node_Id; 12267 D : Node_Id; 12268 Rais : Node_Id; 12269 12270 begin 12271 Set_Ekind (Def_Id, E_Floating_Point_Subtype); 12272 12273 Set_Etype (Def_Id, Base_Type (T)); 12274 Set_Size_Info (Def_Id, (T)); 12275 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 12276 12277 -- Process the constraint 12278 12279 C := Constraint (S); 12280 12281 -- Digits constraint present 12282 12283 if Nkind (C) = N_Digits_Constraint then 12284 12285 Check_SPARK_Restriction ("digits constraint is not allowed", S); 12286 Check_Restriction (No_Obsolescent_Features, C); 12287 12288 if Warn_On_Obsolescent_Feature then 12289 Error_Msg_N 12290 ("subtype digits constraint is an " & 12291 "obsolescent feature (RM J.3(8))?j?", C); 12292 end if; 12293 12294 D := Digits_Expression (C); 12295 Analyze_And_Resolve (D, Any_Integer); 12296 Check_Digits_Expression (D); 12297 Set_Digits_Value (Def_Id, Expr_Value (D)); 12298 12299 -- Check that digits value is in range. Obviously we can do this 12300 -- at compile time, but it is strictly a runtime check, and of 12301 -- course there is an ACVC test that checks this. 12302 12303 if Digits_Value (Def_Id) > Digits_Value (T) then 12304 Error_Msg_Uint_1 := Digits_Value (T); 12305 Error_Msg_N ("??digits value is too large, maximum is ^", D); 12306 Rais := 12307 Make_Raise_Constraint_Error (Sloc (D), 12308 Reason => CE_Range_Check_Failed); 12309 Insert_Action (Declaration_Node (Def_Id), Rais); 12310 end if; 12311 12312 C := Range_Constraint (C); 12313 12314 -- No digits constraint present 12315 12316 else 12317 Set_Digits_Value (Def_Id, Digits_Value (T)); 12318 end if; 12319 12320 -- Range constraint present 12321 12322 if Nkind (C) = N_Range_Constraint then 12323 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 12324 12325 -- No range constraint present 12326 12327 else 12328 pragma Assert (No (C)); 12329 Set_Scalar_Range (Def_Id, Scalar_Range (T)); 12330 end if; 12331 12332 Set_Is_Constrained (Def_Id); 12333 end Constrain_Float; 12334 12335 --------------------- 12336 -- Constrain_Index -- 12337 --------------------- 12338 12339 procedure Constrain_Index 12340 (Index : Node_Id; 12341 S : Node_Id; 12342 Related_Nod : Node_Id; 12343 Related_Id : Entity_Id; 12344 Suffix : Character; 12345 Suffix_Index : Nat) 12346 is 12347 Def_Id : Entity_Id; 12348 R : Node_Id := Empty; 12349 T : constant Entity_Id := Etype (Index); 12350 12351 begin 12352 if Nkind (S) = N_Range 12353 or else 12354 (Nkind (S) = N_Attribute_Reference 12355 and then Attribute_Name (S) = Name_Range) 12356 then 12357 -- A Range attribute will be transformed into N_Range by Resolve 12358 12359 Analyze (S); 12360 Set_Etype (S, T); 12361 R := S; 12362 12363 Process_Range_Expr_In_Decl (R, T, Empty_List); 12364 12365 if not Error_Posted (S) 12366 and then 12367 (Nkind (S) /= N_Range 12368 or else not Covers (T, (Etype (Low_Bound (S)))) 12369 or else not Covers (T, (Etype (High_Bound (S))))) 12370 then 12371 if Base_Type (T) /= Any_Type 12372 and then Etype (Low_Bound (S)) /= Any_Type 12373 and then Etype (High_Bound (S)) /= Any_Type 12374 then 12375 Error_Msg_N ("range expected", S); 12376 end if; 12377 end if; 12378 12379 elsif Nkind (S) = N_Subtype_Indication then 12380 12381 -- The parser has verified that this is a discrete indication 12382 12383 Resolve_Discrete_Subtype_Indication (S, T); 12384 R := Range_Expression (Constraint (S)); 12385 12386 -- Capture values of bounds and generate temporaries for them if 12387 -- needed, since checks may cause duplication of the expressions 12388 -- which must not be reevaluated. 12389 12390 -- The forced evaluation removes side effects from expressions, which 12391 -- should occur also in GNATprove mode. Otherwise, we end up with 12392 -- unexpected insertions of actions at places where this is not 12393 -- supposed to occur, e.g. on default parameters of a call. 12394 12395 if Expander_Active or GNATprove_Mode then 12396 Force_Evaluation (Low_Bound (R)); 12397 Force_Evaluation (High_Bound (R)); 12398 end if; 12399 12400 elsif Nkind (S) = N_Discriminant_Association then 12401 12402 -- Syntactically valid in subtype indication 12403 12404 Error_Msg_N ("invalid index constraint", S); 12405 Rewrite (S, New_Occurrence_Of (T, Sloc (S))); 12406 return; 12407 12408 -- Subtype_Mark case, no anonymous subtypes to construct 12409 12410 else 12411 Analyze (S); 12412 12413 if Is_Entity_Name (S) then 12414 if not Is_Type (Entity (S)) then 12415 Error_Msg_N ("expect subtype mark for index constraint", S); 12416 12417 elsif Base_Type (Entity (S)) /= Base_Type (T) then 12418 Wrong_Type (S, Base_Type (T)); 12419 12420 -- Check error of subtype with predicate in index constraint 12421 12422 else 12423 Bad_Predicated_Subtype_Use 12424 ("subtype& has predicate, not allowed in index constraint", 12425 S, Entity (S)); 12426 end if; 12427 12428 return; 12429 12430 else 12431 Error_Msg_N ("invalid index constraint", S); 12432 Rewrite (S, New_Occurrence_Of (T, Sloc (S))); 12433 return; 12434 end if; 12435 end if; 12436 12437 Def_Id := 12438 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index); 12439 12440 Set_Etype (Def_Id, Base_Type (T)); 12441 12442 if Is_Modular_Integer_Type (T) then 12443 Set_Ekind (Def_Id, E_Modular_Integer_Subtype); 12444 12445 elsif Is_Integer_Type (T) then 12446 Set_Ekind (Def_Id, E_Signed_Integer_Subtype); 12447 12448 else 12449 Set_Ekind (Def_Id, E_Enumeration_Subtype); 12450 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 12451 Set_First_Literal (Def_Id, First_Literal (T)); 12452 end if; 12453 12454 Set_Size_Info (Def_Id, (T)); 12455 Set_RM_Size (Def_Id, RM_Size (T)); 12456 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 12457 12458 Set_Scalar_Range (Def_Id, R); 12459 12460 Set_Etype (S, Def_Id); 12461 Set_Discrete_RM_Size (Def_Id); 12462 end Constrain_Index; 12463 12464 ----------------------- 12465 -- Constrain_Integer -- 12466 ----------------------- 12467 12468 procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is 12469 T : constant Entity_Id := Entity (Subtype_Mark (S)); 12470 C : constant Node_Id := Constraint (S); 12471 12472 begin 12473 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 12474 12475 if Is_Modular_Integer_Type (T) then 12476 Set_Ekind (Def_Id, E_Modular_Integer_Subtype); 12477 else 12478 Set_Ekind (Def_Id, E_Signed_Integer_Subtype); 12479 end if; 12480 12481 Set_Etype (Def_Id, Base_Type (T)); 12482 Set_Size_Info (Def_Id, (T)); 12483 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 12484 Set_Discrete_RM_Size (Def_Id); 12485 end Constrain_Integer; 12486 12487 ------------------------------ 12488 -- Constrain_Ordinary_Fixed -- 12489 ------------------------------ 12490 12491 procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is 12492 T : constant Entity_Id := Entity (Subtype_Mark (S)); 12493 C : Node_Id; 12494 D : Node_Id; 12495 Rais : Node_Id; 12496 12497 begin 12498 Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); 12499 Set_Etype (Def_Id, Base_Type (T)); 12500 Set_Size_Info (Def_Id, (T)); 12501 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 12502 Set_Small_Value (Def_Id, Small_Value (T)); 12503 12504 -- Process the constraint 12505 12506 C := Constraint (S); 12507 12508 -- Delta constraint present 12509 12510 if Nkind (C) = N_Delta_Constraint then 12511 12512 Check_SPARK_Restriction ("delta constraint is not allowed", S); 12513 Check_Restriction (No_Obsolescent_Features, C); 12514 12515 if Warn_On_Obsolescent_Feature then 12516 Error_Msg_S 12517 ("subtype delta constraint is an " & 12518 "obsolescent feature (RM J.3(7))?j?"); 12519 end if; 12520 12521 D := Delta_Expression (C); 12522 Analyze_And_Resolve (D, Any_Real); 12523 Check_Delta_Expression (D); 12524 Set_Delta_Value (Def_Id, Expr_Value_R (D)); 12525 12526 -- Check that delta value is in range. Obviously we can do this 12527 -- at compile time, but it is strictly a runtime check, and of 12528 -- course there is an ACVC test that checks this. 12529 12530 if Delta_Value (Def_Id) < Delta_Value (T) then 12531 Error_Msg_N ("??delta value is too small", D); 12532 Rais := 12533 Make_Raise_Constraint_Error (Sloc (D), 12534 Reason => CE_Range_Check_Failed); 12535 Insert_Action (Declaration_Node (Def_Id), Rais); 12536 end if; 12537 12538 C := Range_Constraint (C); 12539 12540 -- No delta constraint present 12541 12542 else 12543 Set_Delta_Value (Def_Id, Delta_Value (T)); 12544 end if; 12545 12546 -- Range constraint present 12547 12548 if Nkind (C) = N_Range_Constraint then 12549 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 12550 12551 -- No range constraint present 12552 12553 else 12554 pragma Assert (No (C)); 12555 Set_Scalar_Range (Def_Id, Scalar_Range (T)); 12556 12557 end if; 12558 12559 Set_Discrete_RM_Size (Def_Id); 12560 12561 -- Unconditionally delay the freeze, since we cannot set size 12562 -- information in all cases correctly until the freeze point. 12563 12564 Set_Has_Delayed_Freeze (Def_Id); 12565 end Constrain_Ordinary_Fixed; 12566 12567 ----------------------- 12568 -- Contain_Interface -- 12569 ----------------------- 12570 12571 function Contain_Interface 12572 (Iface : Entity_Id; 12573 Ifaces : Elist_Id) return Boolean 12574 is 12575 Iface_Elmt : Elmt_Id; 12576 12577 begin 12578 if Present (Ifaces) then 12579 Iface_Elmt := First_Elmt (Ifaces); 12580 while Present (Iface_Elmt) loop 12581 if Node (Iface_Elmt) = Iface then 12582 return True; 12583 end if; 12584 12585 Next_Elmt (Iface_Elmt); 12586 end loop; 12587 end if; 12588 12589 return False; 12590 end Contain_Interface; 12591 12592 --------------------------- 12593 -- Convert_Scalar_Bounds -- 12594 --------------------------- 12595 12596 procedure Convert_Scalar_Bounds 12597 (N : Node_Id; 12598 Parent_Type : Entity_Id; 12599 Derived_Type : Entity_Id; 12600 Loc : Source_Ptr) 12601 is 12602 Implicit_Base : constant Entity_Id := Base_Type (Derived_Type); 12603 12604 Lo : Node_Id; 12605 Hi : Node_Id; 12606 Rng : Node_Id; 12607 12608 begin 12609 -- Defend against previous errors 12610 12611 if No (Scalar_Range (Derived_Type)) then 12612 Check_Error_Detected; 12613 return; 12614 end if; 12615 12616 Lo := Build_Scalar_Bound 12617 (Type_Low_Bound (Derived_Type), 12618 Parent_Type, Implicit_Base); 12619 12620 Hi := Build_Scalar_Bound 12621 (Type_High_Bound (Derived_Type), 12622 Parent_Type, Implicit_Base); 12623 12624 Rng := 12625 Make_Range (Loc, 12626 Low_Bound => Lo, 12627 High_Bound => Hi); 12628 12629 Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type)); 12630 12631 Set_Parent (Rng, N); 12632 Set_Scalar_Range (Derived_Type, Rng); 12633 12634 -- Analyze the bounds 12635 12636 Analyze_And_Resolve (Lo, Implicit_Base); 12637 Analyze_And_Resolve (Hi, Implicit_Base); 12638 12639 -- Analyze the range itself, except that we do not analyze it if 12640 -- the bounds are real literals, and we have a fixed-point type. 12641 -- The reason for this is that we delay setting the bounds in this 12642 -- case till we know the final Small and Size values (see circuit 12643 -- in Freeze.Freeze_Fixed_Point_Type for further details). 12644 12645 if Is_Fixed_Point_Type (Parent_Type) 12646 and then Nkind (Lo) = N_Real_Literal 12647 and then Nkind (Hi) = N_Real_Literal 12648 then 12649 return; 12650 12651 -- Here we do the analysis of the range 12652 12653 -- Note: we do this manually, since if we do a normal Analyze and 12654 -- Resolve call, there are problems with the conversions used for 12655 -- the derived type range. 12656 12657 else 12658 Set_Etype (Rng, Implicit_Base); 12659 Set_Analyzed (Rng, True); 12660 end if; 12661 end Convert_Scalar_Bounds; 12662 12663 ------------------- 12664 -- Copy_And_Swap -- 12665 ------------------- 12666 12667 procedure Copy_And_Swap (Priv, Full : Entity_Id) is 12668 begin 12669 -- Initialize new full declaration entity by copying the pertinent 12670 -- fields of the corresponding private declaration entity. 12671 12672 -- We temporarily set Ekind to a value appropriate for a type to 12673 -- avoid assert failures in Einfo from checking for setting type 12674 -- attributes on something that is not a type. Ekind (Priv) is an 12675 -- appropriate choice, since it allowed the attributes to be set 12676 -- in the first place. This Ekind value will be modified later. 12677 12678 Set_Ekind (Full, Ekind (Priv)); 12679 12680 -- Also set Etype temporarily to Any_Type, again, in the absence 12681 -- of errors, it will be properly reset, and if there are errors, 12682 -- then we want a value of Any_Type to remain. 12683 12684 Set_Etype (Full, Any_Type); 12685 12686 -- Now start copying attributes 12687 12688 Set_Has_Discriminants (Full, Has_Discriminants (Priv)); 12689 12690 if Has_Discriminants (Full) then 12691 Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv)); 12692 Set_Stored_Constraint (Full, Stored_Constraint (Priv)); 12693 end if; 12694 12695 Set_First_Rep_Item (Full, First_Rep_Item (Priv)); 12696 Set_Homonym (Full, Homonym (Priv)); 12697 Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv)); 12698 Set_Is_Public (Full, Is_Public (Priv)); 12699 Set_Is_Pure (Full, Is_Pure (Priv)); 12700 Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); 12701 Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv)); 12702 Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); 12703 Set_Has_Pragma_Unreferenced_Objects 12704 (Full, Has_Pragma_Unreferenced_Objects 12705 (Priv)); 12706 12707 Conditional_Delay (Full, Priv); 12708 12709 if Is_Tagged_Type (Full) then 12710 Set_Direct_Primitive_Operations (Full, 12711 Direct_Primitive_Operations (Priv)); 12712 12713 if Is_Base_Type (Priv) then 12714 Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); 12715 end if; 12716 end if; 12717 12718 Set_Is_Volatile (Full, Is_Volatile (Priv)); 12719 Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv)); 12720 Set_Scope (Full, Scope (Priv)); 12721 Set_Next_Entity (Full, Next_Entity (Priv)); 12722 Set_First_Entity (Full, First_Entity (Priv)); 12723 Set_Last_Entity (Full, Last_Entity (Priv)); 12724 12725 -- If access types have been recorded for later handling, keep them in 12726 -- the full view so that they get handled when the full view freeze 12727 -- node is expanded. 12728 12729 if Present (Freeze_Node (Priv)) 12730 and then Present (Access_Types_To_Process (Freeze_Node (Priv))) 12731 then 12732 Ensure_Freeze_Node (Full); 12733 Set_Access_Types_To_Process 12734 (Freeze_Node (Full), 12735 Access_Types_To_Process (Freeze_Node (Priv))); 12736 end if; 12737 12738 -- Swap the two entities. Now Private is the full type entity and Full 12739 -- is the private one. They will be swapped back at the end of the 12740 -- private part. This swapping ensures that the entity that is visible 12741 -- in the private part is the full declaration. 12742 12743 Exchange_Entities (Priv, Full); 12744 Append_Entity (Full, Scope (Full)); 12745 end Copy_And_Swap; 12746 12747 ------------------------------------- 12748 -- Copy_Array_Base_Type_Attributes -- 12749 ------------------------------------- 12750 12751 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is 12752 begin 12753 Set_Component_Alignment (T1, Component_Alignment (T2)); 12754 Set_Component_Type (T1, Component_Type (T2)); 12755 Set_Component_Size (T1, Component_Size (T2)); 12756 Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); 12757 Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); 12758 Set_Has_Task (T1, Has_Task (T2)); 12759 Set_Is_Packed (T1, Is_Packed (T2)); 12760 Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); 12761 Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2)); 12762 Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2)); 12763 end Copy_Array_Base_Type_Attributes; 12764 12765 ----------------------------------- 12766 -- Copy_Array_Subtype_Attributes -- 12767 ----------------------------------- 12768 12769 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is 12770 begin 12771 Set_Size_Info (T1, T2); 12772 12773 Set_First_Index (T1, First_Index (T2)); 12774 Set_Is_Aliased (T1, Is_Aliased (T2)); 12775 Set_Is_Volatile (T1, Is_Volatile (T2)); 12776 Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); 12777 Set_Is_Constrained (T1, Is_Constrained (T2)); 12778 Set_Depends_On_Private (T1, Has_Private_Component (T2)); 12779 Set_First_Rep_Item (T1, First_Rep_Item (T2)); 12780 Set_Convention (T1, Convention (T2)); 12781 Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2)); 12782 Set_Is_Private_Composite (T1, Is_Private_Composite (T2)); 12783 Set_Packed_Array_Type (T1, Packed_Array_Type (T2)); 12784 end Copy_Array_Subtype_Attributes; 12785 12786 ----------------------------------- 12787 -- Create_Constrained_Components -- 12788 ----------------------------------- 12789 12790 procedure Create_Constrained_Components 12791 (Subt : Entity_Id; 12792 Decl_Node : Node_Id; 12793 Typ : Entity_Id; 12794 Constraints : Elist_Id) 12795 is 12796 Loc : constant Source_Ptr := Sloc (Subt); 12797 Comp_List : constant Elist_Id := New_Elmt_List; 12798 Parent_Type : constant Entity_Id := Etype (Typ); 12799 Assoc_List : constant List_Id := New_List; 12800 Discr_Val : Elmt_Id; 12801 Errors : Boolean; 12802 New_C : Entity_Id; 12803 Old_C : Entity_Id; 12804 Is_Static : Boolean := True; 12805 12806 procedure Collect_Fixed_Components (Typ : Entity_Id); 12807 -- Collect parent type components that do not appear in a variant part 12808 12809 procedure Create_All_Components; 12810 -- Iterate over Comp_List to create the components of the subtype 12811 12812 function Create_Component (Old_Compon : Entity_Id) return Entity_Id; 12813 -- Creates a new component from Old_Compon, copying all the fields from 12814 -- it, including its Etype, inserts the new component in the Subt entity 12815 -- chain and returns the new component. 12816 12817 function Is_Variant_Record (T : Entity_Id) return Boolean; 12818 -- If true, and discriminants are static, collect only components from 12819 -- variants selected by discriminant values. 12820 12821 ------------------------------ 12822 -- Collect_Fixed_Components -- 12823 ------------------------------ 12824 12825 procedure Collect_Fixed_Components (Typ : Entity_Id) is 12826 begin 12827 -- Build association list for discriminants, and find components of the 12828 -- variant part selected by the values of the discriminants. 12829 12830 Old_C := First_Discriminant (Typ); 12831 Discr_Val := First_Elmt (Constraints); 12832 while Present (Old_C) loop 12833 Append_To (Assoc_List, 12834 Make_Component_Association (Loc, 12835 Choices => New_List (New_Occurrence_Of (Old_C, Loc)), 12836 Expression => New_Copy (Node (Discr_Val)))); 12837 12838 Next_Elmt (Discr_Val); 12839 Next_Discriminant (Old_C); 12840 end loop; 12841 12842 -- The tag and the possible parent component are unconditionally in 12843 -- the subtype. 12844 12845 if Is_Tagged_Type (Typ) 12846 or else Has_Controlled_Component (Typ) 12847 then 12848 Old_C := First_Component (Typ); 12849 while Present (Old_C) loop 12850 if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then 12851 Append_Elmt (Old_C, Comp_List); 12852 end if; 12853 12854 Next_Component (Old_C); 12855 end loop; 12856 end if; 12857 end Collect_Fixed_Components; 12858 12859 --------------------------- 12860 -- Create_All_Components -- 12861 --------------------------- 12862 12863 procedure Create_All_Components is 12864 Comp : Elmt_Id; 12865 12866 begin 12867 Comp := First_Elmt (Comp_List); 12868 while Present (Comp) loop 12869 Old_C := Node (Comp); 12870 New_C := Create_Component (Old_C); 12871 12872 Set_Etype 12873 (New_C, 12874 Constrain_Component_Type 12875 (Old_C, Subt, Decl_Node, Typ, Constraints)); 12876 Set_Is_Public (New_C, Is_Public (Subt)); 12877 12878 Next_Elmt (Comp); 12879 end loop; 12880 end Create_All_Components; 12881 12882 ---------------------- 12883 -- Create_Component -- 12884 ---------------------- 12885 12886 function Create_Component (Old_Compon : Entity_Id) return Entity_Id is 12887 New_Compon : constant Entity_Id := New_Copy (Old_Compon); 12888 12889 begin 12890 if Ekind (Old_Compon) = E_Discriminant 12891 and then Is_Completely_Hidden (Old_Compon) 12892 then 12893 -- This is a shadow discriminant created for a discriminant of 12894 -- the parent type, which needs to be present in the subtype. 12895 -- Give the shadow discriminant an internal name that cannot 12896 -- conflict with that of visible components. 12897 12898 Set_Chars (New_Compon, New_Internal_Name ('C')); 12899 end if; 12900 12901 -- Set the parent so we have a proper link for freezing etc. This is 12902 -- not a real parent pointer, since of course our parent does not own 12903 -- up to us and reference us, we are an illegitimate child of the 12904 -- original parent. 12905 12906 Set_Parent (New_Compon, Parent (Old_Compon)); 12907 12908 -- If the old component's Esize was already determined and is a 12909 -- static value, then the new component simply inherits it. Otherwise 12910 -- the old component's size may require run-time determination, but 12911 -- the new component's size still might be statically determinable 12912 -- (if, for example it has a static constraint). In that case we want 12913 -- Layout_Type to recompute the component's size, so we reset its 12914 -- size and positional fields. 12915 12916 if Frontend_Layout_On_Target 12917 and then not Known_Static_Esize (Old_Compon) 12918 then 12919 Set_Esize (New_Compon, Uint_0); 12920 Init_Normalized_First_Bit (New_Compon); 12921 Init_Normalized_Position (New_Compon); 12922 Init_Normalized_Position_Max (New_Compon); 12923 end if; 12924 12925 -- We do not want this node marked as Comes_From_Source, since 12926 -- otherwise it would get first class status and a separate cross- 12927 -- reference line would be generated. Illegitimate children do not 12928 -- rate such recognition. 12929 12930 Set_Comes_From_Source (New_Compon, False); 12931 12932 -- But it is a real entity, and a birth certificate must be properly 12933 -- registered by entering it into the entity list. 12934 12935 Enter_Name (New_Compon); 12936 12937 return New_Compon; 12938 end Create_Component; 12939 12940 ----------------------- 12941 -- Is_Variant_Record -- 12942 ----------------------- 12943 12944 function Is_Variant_Record (T : Entity_Id) return Boolean is 12945 begin 12946 return Nkind (Parent (T)) = N_Full_Type_Declaration 12947 and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition 12948 and then Present (Component_List (Type_Definition (Parent (T)))) 12949 and then 12950 Present 12951 (Variant_Part (Component_List (Type_Definition (Parent (T))))); 12952 end Is_Variant_Record; 12953 12954 -- Start of processing for Create_Constrained_Components 12955 12956 begin 12957 pragma Assert (Subt /= Base_Type (Subt)); 12958 pragma Assert (Typ = Base_Type (Typ)); 12959 12960 Set_First_Entity (Subt, Empty); 12961 Set_Last_Entity (Subt, Empty); 12962 12963 -- Check whether constraint is fully static, in which case we can 12964 -- optimize the list of components. 12965 12966 Discr_Val := First_Elmt (Constraints); 12967 while Present (Discr_Val) loop 12968 if not Is_OK_Static_Expression (Node (Discr_Val)) then 12969 Is_Static := False; 12970 exit; 12971 end if; 12972 12973 Next_Elmt (Discr_Val); 12974 end loop; 12975 12976 Set_Has_Static_Discriminants (Subt, Is_Static); 12977 12978 Push_Scope (Subt); 12979 12980 -- Inherit the discriminants of the parent type 12981 12982 Add_Discriminants : declare 12983 Num_Disc : Int; 12984 Num_Gird : Int; 12985 12986 begin 12987 Num_Disc := 0; 12988 Old_C := First_Discriminant (Typ); 12989 12990 while Present (Old_C) loop 12991 Num_Disc := Num_Disc + 1; 12992 New_C := Create_Component (Old_C); 12993 Set_Is_Public (New_C, Is_Public (Subt)); 12994 Next_Discriminant (Old_C); 12995 end loop; 12996 12997 -- For an untagged derived subtype, the number of discriminants may 12998 -- be smaller than the number of inherited discriminants, because 12999 -- several of them may be renamed by a single new discriminant or 13000 -- constrained. In this case, add the hidden discriminants back into 13001 -- the subtype, because they need to be present if the optimizer of 13002 -- the GCC 4.x back-end decides to break apart assignments between 13003 -- objects using the parent view into member-wise assignments. 13004 13005 Num_Gird := 0; 13006 13007 if Is_Derived_Type (Typ) 13008 and then not Is_Tagged_Type (Typ) 13009 then 13010 Old_C := First_Stored_Discriminant (Typ); 13011 13012 while Present (Old_C) loop 13013 Num_Gird := Num_Gird + 1; 13014 Next_Stored_Discriminant (Old_C); 13015 end loop; 13016 end if; 13017 13018 if Num_Gird > Num_Disc then 13019 13020 -- Find out multiple uses of new discriminants, and add hidden 13021 -- components for the extra renamed discriminants. We recognize 13022 -- multiple uses through the Corresponding_Discriminant of a 13023 -- new discriminant: if it constrains several old discriminants, 13024 -- this field points to the last one in the parent type. The 13025 -- stored discriminants of the derived type have the same name 13026 -- as those of the parent. 13027 13028 declare 13029 Constr : Elmt_Id; 13030 New_Discr : Entity_Id; 13031 Old_Discr : Entity_Id; 13032 13033 begin 13034 Constr := First_Elmt (Stored_Constraint (Typ)); 13035 Old_Discr := First_Stored_Discriminant (Typ); 13036 while Present (Constr) loop 13037 if Is_Entity_Name (Node (Constr)) 13038 and then Ekind (Entity (Node (Constr))) = E_Discriminant 13039 then 13040 New_Discr := Entity (Node (Constr)); 13041 13042 if Chars (Corresponding_Discriminant (New_Discr)) /= 13043 Chars (Old_Discr) 13044 then 13045 -- The new discriminant has been used to rename a 13046 -- subsequent old discriminant. Introduce a shadow 13047 -- component for the current old discriminant. 13048 13049 New_C := Create_Component (Old_Discr); 13050 Set_Original_Record_Component (New_C, Old_Discr); 13051 end if; 13052 13053 else 13054 -- The constraint has eliminated the old discriminant. 13055 -- Introduce a shadow component. 13056 13057 New_C := Create_Component (Old_Discr); 13058 Set_Original_Record_Component (New_C, Old_Discr); 13059 end if; 13060 13061 Next_Elmt (Constr); 13062 Next_Stored_Discriminant (Old_Discr); 13063 end loop; 13064 end; 13065 end if; 13066 end Add_Discriminants; 13067 13068 if Is_Static 13069 and then Is_Variant_Record (Typ) 13070 then 13071 Collect_Fixed_Components (Typ); 13072 13073 Gather_Components ( 13074 Typ, 13075 Component_List (Type_Definition (Parent (Typ))), 13076 Governed_By => Assoc_List, 13077 Into => Comp_List, 13078 Report_Errors => Errors); 13079 pragma Assert (not Errors); 13080 13081 Create_All_Components; 13082 13083 -- If the subtype declaration is created for a tagged type derivation 13084 -- with constraints, we retrieve the record definition of the parent 13085 -- type to select the components of the proper variant. 13086 13087 elsif Is_Static 13088 and then Is_Tagged_Type (Typ) 13089 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 13090 and then 13091 Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition 13092 and then Is_Variant_Record (Parent_Type) 13093 then 13094 Collect_Fixed_Components (Typ); 13095 13096 Gather_Components ( 13097 Typ, 13098 Component_List (Type_Definition (Parent (Parent_Type))), 13099 Governed_By => Assoc_List, 13100 Into => Comp_List, 13101 Report_Errors => Errors); 13102 pragma Assert (not Errors); 13103 13104 -- If the tagged derivation has a type extension, collect all the 13105 -- new components therein. 13106 13107 if Present 13108 (Record_Extension_Part (Type_Definition (Parent (Typ)))) 13109 then 13110 Old_C := First_Component (Typ); 13111 while Present (Old_C) loop 13112 if Original_Record_Component (Old_C) = Old_C 13113 and then Chars (Old_C) /= Name_uTag 13114 and then Chars (Old_C) /= Name_uParent 13115 then 13116 Append_Elmt (Old_C, Comp_List); 13117 end if; 13118 13119 Next_Component (Old_C); 13120 end loop; 13121 end if; 13122 13123 Create_All_Components; 13124 13125 else 13126 -- If discriminants are not static, or if this is a multi-level type 13127 -- extension, we have to include all components of the parent type. 13128 13129 Old_C := First_Component (Typ); 13130 while Present (Old_C) loop 13131 New_C := Create_Component (Old_C); 13132 13133 Set_Etype 13134 (New_C, 13135 Constrain_Component_Type 13136 (Old_C, Subt, Decl_Node, Typ, Constraints)); 13137 Set_Is_Public (New_C, Is_Public (Subt)); 13138 13139 Next_Component (Old_C); 13140 end loop; 13141 end if; 13142 13143 End_Scope; 13144 end Create_Constrained_Components; 13145 13146 ------------------------------------------ 13147 -- Decimal_Fixed_Point_Type_Declaration -- 13148 ------------------------------------------ 13149 13150 procedure Decimal_Fixed_Point_Type_Declaration 13151 (T : Entity_Id; 13152 Def : Node_Id) 13153 is 13154 Loc : constant Source_Ptr := Sloc (Def); 13155 Digs_Expr : constant Node_Id := Digits_Expression (Def); 13156 Delta_Expr : constant Node_Id := Delta_Expression (Def); 13157 Implicit_Base : Entity_Id; 13158 Digs_Val : Uint; 13159 Delta_Val : Ureal; 13160 Scale_Val : Uint; 13161 Bound_Val : Ureal; 13162 13163 begin 13164 Check_SPARK_Restriction 13165 ("decimal fixed point type is not allowed", Def); 13166 Check_Restriction (No_Fixed_Point, Def); 13167 13168 -- Create implicit base type 13169 13170 Implicit_Base := 13171 Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B'); 13172 Set_Etype (Implicit_Base, Implicit_Base); 13173 13174 -- Analyze and process delta expression 13175 13176 Analyze_And_Resolve (Delta_Expr, Universal_Real); 13177 13178 Check_Delta_Expression (Delta_Expr); 13179 Delta_Val := Expr_Value_R (Delta_Expr); 13180 13181 -- Check delta is power of 10, and determine scale value from it 13182 13183 declare 13184 Val : Ureal; 13185 13186 begin 13187 Scale_Val := Uint_0; 13188 Val := Delta_Val; 13189 13190 if Val < Ureal_1 then 13191 while Val < Ureal_1 loop 13192 Val := Val * Ureal_10; 13193 Scale_Val := Scale_Val + 1; 13194 end loop; 13195 13196 if Scale_Val > 18 then 13197 Error_Msg_N ("scale exceeds maximum value of 18", Def); 13198 Scale_Val := UI_From_Int (+18); 13199 end if; 13200 13201 else 13202 while Val > Ureal_1 loop 13203 Val := Val / Ureal_10; 13204 Scale_Val := Scale_Val - 1; 13205 end loop; 13206 13207 if Scale_Val < -18 then 13208 Error_Msg_N ("scale is less than minimum value of -18", Def); 13209 Scale_Val := UI_From_Int (-18); 13210 end if; 13211 end if; 13212 13213 if Val /= Ureal_1 then 13214 Error_Msg_N ("delta expression must be a power of 10", Def); 13215 Delta_Val := Ureal_10 ** (-Scale_Val); 13216 end if; 13217 end; 13218 13219 -- Set delta, scale and small (small = delta for decimal type) 13220 13221 Set_Delta_Value (Implicit_Base, Delta_Val); 13222 Set_Scale_Value (Implicit_Base, Scale_Val); 13223 Set_Small_Value (Implicit_Base, Delta_Val); 13224 13225 -- Analyze and process digits expression 13226 13227 Analyze_And_Resolve (Digs_Expr, Any_Integer); 13228 Check_Digits_Expression (Digs_Expr); 13229 Digs_Val := Expr_Value (Digs_Expr); 13230 13231 if Digs_Val > 18 then 13232 Digs_Val := UI_From_Int (+18); 13233 Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr); 13234 end if; 13235 13236 Set_Digits_Value (Implicit_Base, Digs_Val); 13237 Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val; 13238 13239 -- Set range of base type from digits value for now. This will be 13240 -- expanded to represent the true underlying base range by Freeze. 13241 13242 Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); 13243 13244 -- Note: We leave size as zero for now, size will be set at freeze 13245 -- time. We have to do this for ordinary fixed-point, because the size 13246 -- depends on the specified small, and we might as well do the same for 13247 -- decimal fixed-point. 13248 13249 pragma Assert (Esize (Implicit_Base) = Uint_0); 13250 13251 -- If there are bounds given in the declaration use them as the 13252 -- bounds of the first named subtype. 13253 13254 if Present (Real_Range_Specification (Def)) then 13255 declare 13256 RRS : constant Node_Id := Real_Range_Specification (Def); 13257 Low : constant Node_Id := Low_Bound (RRS); 13258 High : constant Node_Id := High_Bound (RRS); 13259 Low_Val : Ureal; 13260 High_Val : Ureal; 13261 13262 begin 13263 Analyze_And_Resolve (Low, Any_Real); 13264 Analyze_And_Resolve (High, Any_Real); 13265 Check_Real_Bound (Low); 13266 Check_Real_Bound (High); 13267 Low_Val := Expr_Value_R (Low); 13268 High_Val := Expr_Value_R (High); 13269 13270 if Low_Val < (-Bound_Val) then 13271 Error_Msg_N 13272 ("range low bound too small for digits value", Low); 13273 Low_Val := -Bound_Val; 13274 end if; 13275 13276 if High_Val > Bound_Val then 13277 Error_Msg_N 13278 ("range high bound too large for digits value", High); 13279 High_Val := Bound_Val; 13280 end if; 13281 13282 Set_Fixed_Range (T, Loc, Low_Val, High_Val); 13283 end; 13284 13285 -- If no explicit range, use range that corresponds to given 13286 -- digits value. This will end up as the final range for the 13287 -- first subtype. 13288 13289 else 13290 Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val); 13291 end if; 13292 13293 -- Complete entity for first subtype 13294 13295 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); 13296 Set_Etype (T, Implicit_Base); 13297 Set_Size_Info (T, Implicit_Base); 13298 Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); 13299 Set_Digits_Value (T, Digs_Val); 13300 Set_Delta_Value (T, Delta_Val); 13301 Set_Small_Value (T, Delta_Val); 13302 Set_Scale_Value (T, Scale_Val); 13303 Set_Is_Constrained (T); 13304 end Decimal_Fixed_Point_Type_Declaration; 13305 13306 ----------------------------------- 13307 -- Derive_Progenitor_Subprograms -- 13308 ----------------------------------- 13309 13310 procedure Derive_Progenitor_Subprograms 13311 (Parent_Type : Entity_Id; 13312 Tagged_Type : Entity_Id) 13313 is 13314 E : Entity_Id; 13315 Elmt : Elmt_Id; 13316 Iface : Entity_Id; 13317 Iface_Elmt : Elmt_Id; 13318 Iface_Subp : Entity_Id; 13319 New_Subp : Entity_Id := Empty; 13320 Prim_Elmt : Elmt_Id; 13321 Subp : Entity_Id; 13322 Typ : Entity_Id; 13323 13324 begin 13325 pragma Assert (Ada_Version >= Ada_2005 13326 and then Is_Record_Type (Tagged_Type) 13327 and then Is_Tagged_Type (Tagged_Type) 13328 and then Has_Interfaces (Tagged_Type)); 13329 13330 -- Step 1: Transfer to the full-view primitives associated with the 13331 -- partial-view that cover interface primitives. Conceptually this 13332 -- work should be done later by Process_Full_View; done here to 13333 -- simplify its implementation at later stages. It can be safely 13334 -- done here because interfaces must be visible in the partial and 13335 -- private view (RM 7.3(7.3/2)). 13336 13337 -- Small optimization: This work is only required if the parent may 13338 -- have entities whose Alias attribute reference an interface primitive. 13339 -- Such a situation may occur if the parent is an abstract type and the 13340 -- primitive has not been yet overridden or if the parent is a generic 13341 -- formal type covering interfaces. 13342 13343 -- If the tagged type is not abstract, it cannot have abstract 13344 -- primitives (the only entities in the list of primitives of 13345 -- non-abstract tagged types that can reference abstract primitives 13346 -- through its Alias attribute are the internal entities that have 13347 -- attribute Interface_Alias, and these entities are generated later 13348 -- by Add_Internal_Interface_Entities). 13349 13350 if In_Private_Part (Current_Scope) 13351 and then (Is_Abstract_Type (Parent_Type) 13352 or else 13353 Is_Generic_Type (Parent_Type)) 13354 then 13355 Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); 13356 while Present (Elmt) loop 13357 Subp := Node (Elmt); 13358 13359 -- At this stage it is not possible to have entities in the list 13360 -- of primitives that have attribute Interface_Alias. 13361 13362 pragma Assert (No (Interface_Alias (Subp))); 13363 13364 Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); 13365 13366 if Is_Interface (Typ) then 13367 E := Find_Primitive_Covering_Interface 13368 (Tagged_Type => Tagged_Type, 13369 Iface_Prim => Subp); 13370 13371 if Present (E) 13372 and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ 13373 then 13374 Replace_Elmt (Elmt, E); 13375 Remove_Homonym (Subp); 13376 end if; 13377 end if; 13378 13379 Next_Elmt (Elmt); 13380 end loop; 13381 end if; 13382 13383 -- Step 2: Add primitives of progenitors that are not implemented by 13384 -- parents of Tagged_Type. 13385 13386 if Present (Interfaces (Base_Type (Tagged_Type))) then 13387 Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type))); 13388 while Present (Iface_Elmt) loop 13389 Iface := Node (Iface_Elmt); 13390 13391 Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); 13392 while Present (Prim_Elmt) loop 13393 Iface_Subp := Node (Prim_Elmt); 13394 13395 -- Exclude derivation of predefined primitives except those 13396 -- that come from source, or are inherited from one that comes 13397 -- from source. Required to catch declarations of equality 13398 -- operators of interfaces. For example: 13399 13400 -- type Iface is interface; 13401 -- function "=" (Left, Right : Iface) return Boolean; 13402 13403 if not Is_Predefined_Dispatching_Operation (Iface_Subp) 13404 or else Comes_From_Source (Ultimate_Alias (Iface_Subp)) 13405 then 13406 E := Find_Primitive_Covering_Interface 13407 (Tagged_Type => Tagged_Type, 13408 Iface_Prim => Iface_Subp); 13409 13410 -- If not found we derive a new primitive leaving its alias 13411 -- attribute referencing the interface primitive. 13412 13413 if No (E) then 13414 Derive_Subprogram 13415 (New_Subp, Iface_Subp, Tagged_Type, Iface); 13416 13417 -- Ada 2012 (AI05-0197): If the covering primitive's name 13418 -- differs from the name of the interface primitive then it 13419 -- is a private primitive inherited from a parent type. In 13420 -- such case, given that Tagged_Type covers the interface, 13421 -- the inherited private primitive becomes visible. For such 13422 -- purpose we add a new entity that renames the inherited 13423 -- private primitive. 13424 13425 elsif Chars (E) /= Chars (Iface_Subp) then 13426 pragma Assert (Has_Suffix (E, 'P')); 13427 Derive_Subprogram 13428 (New_Subp, Iface_Subp, Tagged_Type, Iface); 13429 Set_Alias (New_Subp, E); 13430 Set_Is_Abstract_Subprogram (New_Subp, 13431 Is_Abstract_Subprogram (E)); 13432 13433 -- Propagate to the full view interface entities associated 13434 -- with the partial view. 13435 13436 elsif In_Private_Part (Current_Scope) 13437 and then Present (Alias (E)) 13438 and then Alias (E) = Iface_Subp 13439 and then 13440 List_Containing (Parent (E)) /= 13441 Private_Declarations 13442 (Specification 13443 (Unit_Declaration_Node (Current_Scope))) 13444 then 13445 Append_Elmt (E, Primitive_Operations (Tagged_Type)); 13446 end if; 13447 end if; 13448 13449 Next_Elmt (Prim_Elmt); 13450 end loop; 13451 13452 Next_Elmt (Iface_Elmt); 13453 end loop; 13454 end if; 13455 end Derive_Progenitor_Subprograms; 13456 13457 ----------------------- 13458 -- Derive_Subprogram -- 13459 ----------------------- 13460 13461 procedure Derive_Subprogram 13462 (New_Subp : in out Entity_Id; 13463 Parent_Subp : Entity_Id; 13464 Derived_Type : Entity_Id; 13465 Parent_Type : Entity_Id; 13466 Actual_Subp : Entity_Id := Empty) 13467 is 13468 Formal : Entity_Id; 13469 -- Formal parameter of parent primitive operation 13470 13471 Formal_Of_Actual : Entity_Id; 13472 -- Formal parameter of actual operation, when the derivation is to 13473 -- create a renaming for a primitive operation of an actual in an 13474 -- instantiation. 13475 13476 New_Formal : Entity_Id; 13477 -- Formal of inherited operation 13478 13479 Visible_Subp : Entity_Id := Parent_Subp; 13480 13481 function Is_Private_Overriding return Boolean; 13482 -- If Subp is a private overriding of a visible operation, the inherited 13483 -- operation derives from the overridden op (even though its body is the 13484 -- overriding one) and the inherited operation is visible now. See 13485 -- sem_disp to see the full details of the handling of the overridden 13486 -- subprogram, which is removed from the list of primitive operations of 13487 -- the type. The overridden subprogram is saved locally in Visible_Subp, 13488 -- and used to diagnose abstract operations that need overriding in the 13489 -- derived type. 13490 13491 procedure Replace_Type (Id, New_Id : Entity_Id); 13492 -- When the type is an anonymous access type, create a new access type 13493 -- designating the derived type. 13494 13495 procedure Set_Derived_Name; 13496 -- This procedure sets the appropriate Chars name for New_Subp. This 13497 -- is normally just a copy of the parent name. An exception arises for 13498 -- type support subprograms, where the name is changed to reflect the 13499 -- name of the derived type, e.g. if type foo is derived from type bar, 13500 -- then a procedure barDA is derived with a name fooDA. 13501 13502 --------------------------- 13503 -- Is_Private_Overriding -- 13504 --------------------------- 13505 13506 function Is_Private_Overriding return Boolean is 13507 Prev : Entity_Id; 13508 13509 begin 13510 -- If the parent is not a dispatching operation there is no 13511 -- need to investigate overridings 13512 13513 if not Is_Dispatching_Operation (Parent_Subp) then 13514 return False; 13515 end if; 13516 13517 -- The visible operation that is overridden is a homonym of the 13518 -- parent subprogram. We scan the homonym chain to find the one 13519 -- whose alias is the subprogram we are deriving. 13520 13521 Prev := Current_Entity (Parent_Subp); 13522 while Present (Prev) loop 13523 if Ekind (Prev) = Ekind (Parent_Subp) 13524 and then Alias (Prev) = Parent_Subp 13525 and then Scope (Parent_Subp) = Scope (Prev) 13526 and then not Is_Hidden (Prev) 13527 then 13528 Visible_Subp := Prev; 13529 return True; 13530 end if; 13531 13532 Prev := Homonym (Prev); 13533 end loop; 13534 13535 return False; 13536 end Is_Private_Overriding; 13537 13538 ------------------ 13539 -- Replace_Type -- 13540 ------------------ 13541 13542 procedure Replace_Type (Id, New_Id : Entity_Id) is 13543 Acc_Type : Entity_Id; 13544 Par : constant Node_Id := Parent (Derived_Type); 13545 13546 begin 13547 -- When the type is an anonymous access type, create a new access 13548 -- type designating the derived type. This itype must be elaborated 13549 -- at the point of the derivation, not on subsequent calls that may 13550 -- be out of the proper scope for Gigi, so we insert a reference to 13551 -- it after the derivation. 13552 13553 if Ekind (Etype (Id)) = E_Anonymous_Access_Type then 13554 declare 13555 Desig_Typ : Entity_Id := Designated_Type (Etype (Id)); 13556 13557 begin 13558 if Ekind (Desig_Typ) = E_Record_Type_With_Private 13559 and then Present (Full_View (Desig_Typ)) 13560 and then not Is_Private_Type (Parent_Type) 13561 then 13562 Desig_Typ := Full_View (Desig_Typ); 13563 end if; 13564 13565 if Base_Type (Desig_Typ) = Base_Type (Parent_Type) 13566 13567 -- Ada 2005 (AI-251): Handle also derivations of abstract 13568 -- interface primitives. 13569 13570 or else (Is_Interface (Desig_Typ) 13571 and then not Is_Class_Wide_Type (Desig_Typ)) 13572 then 13573 Acc_Type := New_Copy (Etype (Id)); 13574 Set_Etype (Acc_Type, Acc_Type); 13575 Set_Scope (Acc_Type, New_Subp); 13576 13577 -- Compute size of anonymous access type 13578 13579 if Is_Array_Type (Desig_Typ) 13580 and then not Is_Constrained (Desig_Typ) 13581 then 13582 Init_Size (Acc_Type, 2 * System_Address_Size); 13583 else 13584 Init_Size (Acc_Type, System_Address_Size); 13585 end if; 13586 13587 Init_Alignment (Acc_Type); 13588 Set_Directly_Designated_Type (Acc_Type, Derived_Type); 13589 13590 Set_Etype (New_Id, Acc_Type); 13591 Set_Scope (New_Id, New_Subp); 13592 13593 -- Create a reference to it 13594 Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); 13595 13596 else 13597 Set_Etype (New_Id, Etype (Id)); 13598 end if; 13599 end; 13600 13601 elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type) 13602 or else 13603 (Ekind (Etype (Id)) = E_Record_Type_With_Private 13604 and then Present (Full_View (Etype (Id))) 13605 and then 13606 Base_Type (Full_View (Etype (Id))) = Base_Type (Parent_Type)) 13607 then 13608 -- Constraint checks on formals are generated during expansion, 13609 -- based on the signature of the original subprogram. The bounds 13610 -- of the derived type are not relevant, and thus we can use 13611 -- the base type for the formals. However, the return type may be 13612 -- used in a context that requires that the proper static bounds 13613 -- be used (a case statement, for example) and for those cases 13614 -- we must use the derived type (first subtype), not its base. 13615 13616 -- If the derived_type_definition has no constraints, we know that 13617 -- the derived type has the same constraints as the first subtype 13618 -- of the parent, and we can also use it rather than its base, 13619 -- which can lead to more efficient code. 13620 13621 if Etype (Id) = Parent_Type then 13622 if Is_Scalar_Type (Parent_Type) 13623 and then 13624 Subtypes_Statically_Compatible (Parent_Type, Derived_Type) 13625 then 13626 Set_Etype (New_Id, Derived_Type); 13627 13628 elsif Nkind (Par) = N_Full_Type_Declaration 13629 and then 13630 Nkind (Type_Definition (Par)) = N_Derived_Type_Definition 13631 and then 13632 Is_Entity_Name 13633 (Subtype_Indication (Type_Definition (Par))) 13634 then 13635 Set_Etype (New_Id, Derived_Type); 13636 13637 else 13638 Set_Etype (New_Id, Base_Type (Derived_Type)); 13639 end if; 13640 13641 else 13642 Set_Etype (New_Id, Base_Type (Derived_Type)); 13643 end if; 13644 13645 else 13646 Set_Etype (New_Id, Etype (Id)); 13647 end if; 13648 end Replace_Type; 13649 13650 ---------------------- 13651 -- Set_Derived_Name -- 13652 ---------------------- 13653 13654 procedure Set_Derived_Name is 13655 Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp); 13656 begin 13657 if Nm = TSS_Null then 13658 Set_Chars (New_Subp, Chars (Parent_Subp)); 13659 else 13660 Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm)); 13661 end if; 13662 end Set_Derived_Name; 13663 13664 -- Start of processing for Derive_Subprogram 13665 13666 begin 13667 New_Subp := 13668 New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); 13669 Set_Ekind (New_Subp, Ekind (Parent_Subp)); 13670 Set_Contract (New_Subp, Make_Contract (Sloc (New_Subp))); 13671 13672 -- Check whether the inherited subprogram is a private operation that 13673 -- should be inherited but not yet made visible. Such subprograms can 13674 -- become visible at a later point (e.g., the private part of a public 13675 -- child unit) via Declare_Inherited_Private_Subprograms. If the 13676 -- following predicate is true, then this is not such a private 13677 -- operation and the subprogram simply inherits the name of the parent 13678 -- subprogram. Note the special check for the names of controlled 13679 -- operations, which are currently exempted from being inherited with 13680 -- a hidden name because they must be findable for generation of 13681 -- implicit run-time calls. 13682 13683 if not Is_Hidden (Parent_Subp) 13684 or else Is_Internal (Parent_Subp) 13685 or else Is_Private_Overriding 13686 or else Is_Internal_Name (Chars (Parent_Subp)) 13687 or else Nam_In (Chars (Parent_Subp), Name_Initialize, 13688 Name_Adjust, 13689 Name_Finalize) 13690 then 13691 Set_Derived_Name; 13692 13693 -- An inherited dispatching equality will be overridden by an internally 13694 -- generated one, or by an explicit one, so preserve its name and thus 13695 -- its entry in the dispatch table. Otherwise, if Parent_Subp is a 13696 -- private operation it may become invisible if the full view has 13697 -- progenitors, and the dispatch table will be malformed. 13698 -- We check that the type is limited to handle the anomalous declaration 13699 -- of Limited_Controlled, which is derived from a non-limited type, and 13700 -- which is handled specially elsewhere as well. 13701 13702 elsif Chars (Parent_Subp) = Name_Op_Eq 13703 and then Is_Dispatching_Operation (Parent_Subp) 13704 and then Etype (Parent_Subp) = Standard_Boolean 13705 and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp))) 13706 and then 13707 Etype (First_Formal (Parent_Subp)) = 13708 Etype (Next_Formal (First_Formal (Parent_Subp))) 13709 then 13710 Set_Derived_Name; 13711 13712 -- If parent is hidden, this can be a regular derivation if the 13713 -- parent is immediately visible in a non-instantiating context, 13714 -- or if we are in the private part of an instance. This test 13715 -- should still be refined ??? 13716 13717 -- The test for In_Instance_Not_Visible avoids inheriting the derived 13718 -- operation as a non-visible operation in cases where the parent 13719 -- subprogram might not be visible now, but was visible within the 13720 -- original generic, so it would be wrong to make the inherited 13721 -- subprogram non-visible now. (Not clear if this test is fully 13722 -- correct; are there any cases where we should declare the inherited 13723 -- operation as not visible to avoid it being overridden, e.g., when 13724 -- the parent type is a generic actual with private primitives ???) 13725 13726 -- (they should be treated the same as other private inherited 13727 -- subprograms, but it's not clear how to do this cleanly). ??? 13728 13729 elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type))) 13730 and then Is_Immediately_Visible (Parent_Subp) 13731 and then not In_Instance) 13732 or else In_Instance_Not_Visible 13733 then 13734 Set_Derived_Name; 13735 13736 -- Ada 2005 (AI-251): Regular derivation if the parent subprogram 13737 -- overrides an interface primitive because interface primitives 13738 -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) 13739 13740 elsif Ada_Version >= Ada_2005 13741 and then Is_Dispatching_Operation (Parent_Subp) 13742 and then Covers_Some_Interface (Parent_Subp) 13743 then 13744 Set_Derived_Name; 13745 13746 -- Otherwise, the type is inheriting a private operation, so enter 13747 -- it with a special name so it can't be overridden. 13748 13749 else 13750 Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P')); 13751 end if; 13752 13753 Set_Parent (New_Subp, Parent (Derived_Type)); 13754 13755 if Present (Actual_Subp) then 13756 Replace_Type (Actual_Subp, New_Subp); 13757 else 13758 Replace_Type (Parent_Subp, New_Subp); 13759 end if; 13760 13761 Conditional_Delay (New_Subp, Parent_Subp); 13762 13763 -- If we are creating a renaming for a primitive operation of an 13764 -- actual of a generic derived type, we must examine the signature 13765 -- of the actual primitive, not that of the generic formal, which for 13766 -- example may be an interface. However the name and initial value 13767 -- of the inherited operation are those of the formal primitive. 13768 13769 Formal := First_Formal (Parent_Subp); 13770 13771 if Present (Actual_Subp) then 13772 Formal_Of_Actual := First_Formal (Actual_Subp); 13773 else 13774 Formal_Of_Actual := Empty; 13775 end if; 13776 13777 while Present (Formal) loop 13778 New_Formal := New_Copy (Formal); 13779 13780 -- Normally we do not go copying parents, but in the case of 13781 -- formals, we need to link up to the declaration (which is the 13782 -- parameter specification), and it is fine to link up to the 13783 -- original formal's parameter specification in this case. 13784 13785 Set_Parent (New_Formal, Parent (Formal)); 13786 Append_Entity (New_Formal, New_Subp); 13787 13788 if Present (Formal_Of_Actual) then 13789 Replace_Type (Formal_Of_Actual, New_Formal); 13790 Next_Formal (Formal_Of_Actual); 13791 else 13792 Replace_Type (Formal, New_Formal); 13793 end if; 13794 13795 Next_Formal (Formal); 13796 end loop; 13797 13798 -- If this derivation corresponds to a tagged generic actual, then 13799 -- primitive operations rename those of the actual. Otherwise the 13800 -- primitive operations rename those of the parent type, If the parent 13801 -- renames an intrinsic operator, so does the new subprogram. We except 13802 -- concatenation, which is always properly typed, and does not get 13803 -- expanded as other intrinsic operations. 13804 13805 if No (Actual_Subp) then 13806 if Is_Intrinsic_Subprogram (Parent_Subp) then 13807 Set_Is_Intrinsic_Subprogram (New_Subp); 13808 13809 if Present (Alias (Parent_Subp)) 13810 and then Chars (Parent_Subp) /= Name_Op_Concat 13811 then 13812 Set_Alias (New_Subp, Alias (Parent_Subp)); 13813 else 13814 Set_Alias (New_Subp, Parent_Subp); 13815 end if; 13816 13817 else 13818 Set_Alias (New_Subp, Parent_Subp); 13819 end if; 13820 13821 else 13822 Set_Alias (New_Subp, Actual_Subp); 13823 end if; 13824 13825 -- Derived subprograms of a tagged type must inherit the convention 13826 -- of the parent subprogram (a requirement of AI-117). Derived 13827 -- subprograms of untagged types simply get convention Ada by default. 13828 13829 -- If the derived type is a tagged generic formal type with unknown 13830 -- discriminants, its convention is intrinsic (RM 6.3.1 (8)). 13831 13832 -- However, if the type is derived from a generic formal, the further 13833 -- inherited subprogram has the convention of the non-generic ancestor. 13834 -- Otherwise there would be no way to override the operation. 13835 -- (This is subject to forthcoming ARG discussions). 13836 13837 if Is_Tagged_Type (Derived_Type) then 13838 if Is_Generic_Type (Derived_Type) 13839 and then Has_Unknown_Discriminants (Derived_Type) 13840 then 13841 Set_Convention (New_Subp, Convention_Intrinsic); 13842 13843 else 13844 if Is_Generic_Type (Parent_Type) 13845 and then Has_Unknown_Discriminants (Parent_Type) 13846 then 13847 Set_Convention (New_Subp, Convention (Alias (Parent_Subp))); 13848 else 13849 Set_Convention (New_Subp, Convention (Parent_Subp)); 13850 end if; 13851 end if; 13852 end if; 13853 13854 -- Predefined controlled operations retain their name even if the parent 13855 -- is hidden (see above), but they are not primitive operations if the 13856 -- ancestor is not visible, for example if the parent is a private 13857 -- extension completed with a controlled extension. Note that a full 13858 -- type that is controlled can break privacy: the flag Is_Controlled is 13859 -- set on both views of the type. 13860 13861 if Is_Controlled (Parent_Type) 13862 and then Nam_In (Chars (Parent_Subp), Name_Initialize, 13863 Name_Adjust, 13864 Name_Finalize) 13865 and then Is_Hidden (Parent_Subp) 13866 and then not Is_Visibly_Controlled (Parent_Type) 13867 then 13868 Set_Is_Hidden (New_Subp); 13869 end if; 13870 13871 Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp)); 13872 Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp)); 13873 13874 if Ekind (Parent_Subp) = E_Procedure then 13875 Set_Is_Valued_Procedure 13876 (New_Subp, Is_Valued_Procedure (Parent_Subp)); 13877 else 13878 Set_Has_Controlling_Result 13879 (New_Subp, Has_Controlling_Result (Parent_Subp)); 13880 end if; 13881 13882 -- No_Return must be inherited properly. If this is overridden in the 13883 -- case of a dispatching operation, then a check is made in Sem_Disp 13884 -- that the overriding operation is also No_Return (no such check is 13885 -- required for the case of non-dispatching operation. 13886 13887 Set_No_Return (New_Subp, No_Return (Parent_Subp)); 13888 13889 -- A derived function with a controlling result is abstract. If the 13890 -- Derived_Type is a nonabstract formal generic derived type, then 13891 -- inherited operations are not abstract: the required check is done at 13892 -- instantiation time. If the derivation is for a generic actual, the 13893 -- function is not abstract unless the actual is. 13894 13895 if Is_Generic_Type (Derived_Type) 13896 and then not Is_Abstract_Type (Derived_Type) 13897 then 13898 null; 13899 13900 -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" 13901 -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). 13902 13903 elsif Ada_Version >= Ada_2005 13904 and then (Is_Abstract_Subprogram (Alias (New_Subp)) 13905 or else (Is_Tagged_Type (Derived_Type) 13906 and then Etype (New_Subp) = Derived_Type 13907 and then not Is_Null_Extension (Derived_Type)) 13908 or else (Is_Tagged_Type (Derived_Type) 13909 and then Ekind (Etype (New_Subp)) = 13910 E_Anonymous_Access_Type 13911 and then Designated_Type (Etype (New_Subp)) = 13912 Derived_Type 13913 and then not Is_Null_Extension (Derived_Type))) 13914 and then No (Actual_Subp) 13915 then 13916 if not Is_Tagged_Type (Derived_Type) 13917 or else Is_Abstract_Type (Derived_Type) 13918 or else Is_Abstract_Subprogram (Alias (New_Subp)) 13919 then 13920 Set_Is_Abstract_Subprogram (New_Subp); 13921 else 13922 Set_Requires_Overriding (New_Subp); 13923 end if; 13924 13925 elsif Ada_Version < Ada_2005 13926 and then (Is_Abstract_Subprogram (Alias (New_Subp)) 13927 or else (Is_Tagged_Type (Derived_Type) 13928 and then Etype (New_Subp) = Derived_Type 13929 and then No (Actual_Subp))) 13930 then 13931 Set_Is_Abstract_Subprogram (New_Subp); 13932 13933 -- AI05-0097 : an inherited operation that dispatches on result is 13934 -- abstract if the derived type is abstract, even if the parent type 13935 -- is concrete and the derived type is a null extension. 13936 13937 elsif Has_Controlling_Result (Alias (New_Subp)) 13938 and then Is_Abstract_Type (Etype (New_Subp)) 13939 then 13940 Set_Is_Abstract_Subprogram (New_Subp); 13941 13942 -- Finally, if the parent type is abstract we must verify that all 13943 -- inherited operations are either non-abstract or overridden, or that 13944 -- the derived type itself is abstract (this check is performed at the 13945 -- end of a package declaration, in Check_Abstract_Overriding). A 13946 -- private overriding in the parent type will not be visible in the 13947 -- derivation if we are not in an inner package or in a child unit of 13948 -- the parent type, in which case the abstractness of the inherited 13949 -- operation is carried to the new subprogram. 13950 13951 elsif Is_Abstract_Type (Parent_Type) 13952 and then not In_Open_Scopes (Scope (Parent_Type)) 13953 and then Is_Private_Overriding 13954 and then Is_Abstract_Subprogram (Visible_Subp) 13955 then 13956 if No (Actual_Subp) then 13957 Set_Alias (New_Subp, Visible_Subp); 13958 Set_Is_Abstract_Subprogram (New_Subp, True); 13959 13960 else 13961 -- If this is a derivation for an instance of a formal derived 13962 -- type, abstractness comes from the primitive operation of the 13963 -- actual, not from the operation inherited from the ancestor. 13964 13965 Set_Is_Abstract_Subprogram 13966 (New_Subp, Is_Abstract_Subprogram (Actual_Subp)); 13967 end if; 13968 end if; 13969 13970 New_Overloaded_Entity (New_Subp, Derived_Type); 13971 13972 -- Check for case of a derived subprogram for the instantiation of a 13973 -- formal derived tagged type, if so mark the subprogram as dispatching 13974 -- and inherit the dispatching attributes of the actual subprogram. The 13975 -- derived subprogram is effectively renaming of the actual subprogram, 13976 -- so it needs to have the same attributes as the actual. 13977 13978 if Present (Actual_Subp) 13979 and then Is_Dispatching_Operation (Actual_Subp) 13980 then 13981 Set_Is_Dispatching_Operation (New_Subp); 13982 13983 if Present (DTC_Entity (Actual_Subp)) then 13984 Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp)); 13985 Set_DT_Position (New_Subp, DT_Position (Actual_Subp)); 13986 end if; 13987 end if; 13988 13989 -- Indicate that a derived subprogram does not require a body and that 13990 -- it does not require processing of default expressions. 13991 13992 Set_Has_Completion (New_Subp); 13993 Set_Default_Expressions_Processed (New_Subp); 13994 13995 if Ekind (New_Subp) = E_Function then 13996 Set_Mechanism (New_Subp, Mechanism (Parent_Subp)); 13997 end if; 13998 end Derive_Subprogram; 13999 14000 ------------------------ 14001 -- Derive_Subprograms -- 14002 ------------------------ 14003 14004 procedure Derive_Subprograms 14005 (Parent_Type : Entity_Id; 14006 Derived_Type : Entity_Id; 14007 Generic_Actual : Entity_Id := Empty) 14008 is 14009 Op_List : constant Elist_Id := 14010 Collect_Primitive_Operations (Parent_Type); 14011 14012 function Check_Derived_Type return Boolean; 14013 -- Check that all the entities derived from Parent_Type are found in 14014 -- the list of primitives of Derived_Type exactly in the same order. 14015 14016 procedure Derive_Interface_Subprogram 14017 (New_Subp : in out Entity_Id; 14018 Subp : Entity_Id; 14019 Actual_Subp : Entity_Id); 14020 -- Derive New_Subp from the ultimate alias of the parent subprogram Subp 14021 -- (which is an interface primitive). If Generic_Actual is present then 14022 -- Actual_Subp is the actual subprogram corresponding with the generic 14023 -- subprogram Subp. 14024 14025 function Check_Derived_Type return Boolean is 14026 E : Entity_Id; 14027 Elmt : Elmt_Id; 14028 List : Elist_Id; 14029 New_Subp : Entity_Id; 14030 Op_Elmt : Elmt_Id; 14031 Subp : Entity_Id; 14032 14033 begin 14034 -- Traverse list of entities in the current scope searching for 14035 -- an incomplete type whose full-view is derived type 14036 14037 E := First_Entity (Scope (Derived_Type)); 14038 while Present (E) and then E /= Derived_Type loop 14039 if Ekind (E) = E_Incomplete_Type 14040 and then Present (Full_View (E)) 14041 and then Full_View (E) = Derived_Type 14042 then 14043 -- Disable this test if Derived_Type completes an incomplete 14044 -- type because in such case more primitives can be added 14045 -- later to the list of primitives of Derived_Type by routine 14046 -- Process_Incomplete_Dependents 14047 14048 return True; 14049 end if; 14050 14051 E := Next_Entity (E); 14052 end loop; 14053 14054 List := Collect_Primitive_Operations (Derived_Type); 14055 Elmt := First_Elmt (List); 14056 14057 Op_Elmt := First_Elmt (Op_List); 14058 while Present (Op_Elmt) loop 14059 Subp := Node (Op_Elmt); 14060 New_Subp := Node (Elmt); 14061 14062 -- At this early stage Derived_Type has no entities with attribute 14063 -- Interface_Alias. In addition, such primitives are always 14064 -- located at the end of the list of primitives of Parent_Type. 14065 -- Therefore, if found we can safely stop processing pending 14066 -- entities. 14067 14068 exit when Present (Interface_Alias (Subp)); 14069 14070 -- Handle hidden entities 14071 14072 if not Is_Predefined_Dispatching_Operation (Subp) 14073 and then Is_Hidden (Subp) 14074 then 14075 if Present (New_Subp) 14076 and then Primitive_Names_Match (Subp, New_Subp) 14077 then 14078 Next_Elmt (Elmt); 14079 end if; 14080 14081 else 14082 if not Present (New_Subp) 14083 or else Ekind (Subp) /= Ekind (New_Subp) 14084 or else not Primitive_Names_Match (Subp, New_Subp) 14085 then 14086 return False; 14087 end if; 14088 14089 Next_Elmt (Elmt); 14090 end if; 14091 14092 Next_Elmt (Op_Elmt); 14093 end loop; 14094 14095 return True; 14096 end Check_Derived_Type; 14097 14098 --------------------------------- 14099 -- Derive_Interface_Subprogram -- 14100 --------------------------------- 14101 14102 procedure Derive_Interface_Subprogram 14103 (New_Subp : in out Entity_Id; 14104 Subp : Entity_Id; 14105 Actual_Subp : Entity_Id) 14106 is 14107 Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp); 14108 Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp); 14109 14110 begin 14111 pragma Assert (Is_Interface (Iface_Type)); 14112 14113 Derive_Subprogram 14114 (New_Subp => New_Subp, 14115 Parent_Subp => Iface_Subp, 14116 Derived_Type => Derived_Type, 14117 Parent_Type => Iface_Type, 14118 Actual_Subp => Actual_Subp); 14119 14120 -- Given that this new interface entity corresponds with a primitive 14121 -- of the parent that was not overridden we must leave it associated 14122 -- with its parent primitive to ensure that it will share the same 14123 -- dispatch table slot when overridden. 14124 14125 if No (Actual_Subp) then 14126 Set_Alias (New_Subp, Subp); 14127 14128 -- For instantiations this is not needed since the previous call to 14129 -- Derive_Subprogram leaves the entity well decorated. 14130 14131 else 14132 pragma Assert (Alias (New_Subp) = Actual_Subp); 14133 null; 14134 end if; 14135 end Derive_Interface_Subprogram; 14136 14137 -- Local variables 14138 14139 Alias_Subp : Entity_Id; 14140 Act_List : Elist_Id; 14141 Act_Elmt : Elmt_Id; 14142 Act_Subp : Entity_Id := Empty; 14143 Elmt : Elmt_Id; 14144 Need_Search : Boolean := False; 14145 New_Subp : Entity_Id := Empty; 14146 Parent_Base : Entity_Id; 14147 Subp : Entity_Id; 14148 14149 -- Start of processing for Derive_Subprograms 14150 14151 begin 14152 if Ekind (Parent_Type) = E_Record_Type_With_Private 14153 and then Has_Discriminants (Parent_Type) 14154 and then Present (Full_View (Parent_Type)) 14155 then 14156 Parent_Base := Full_View (Parent_Type); 14157 else 14158 Parent_Base := Parent_Type; 14159 end if; 14160 14161 if Present (Generic_Actual) then 14162 Act_List := Collect_Primitive_Operations (Generic_Actual); 14163 Act_Elmt := First_Elmt (Act_List); 14164 else 14165 Act_List := No_Elist; 14166 Act_Elmt := No_Elmt; 14167 end if; 14168 14169 -- Derive primitives inherited from the parent. Note that if the generic 14170 -- actual is present, this is not really a type derivation, it is a 14171 -- completion within an instance. 14172 14173 -- Case 1: Derived_Type does not implement interfaces 14174 14175 if not Is_Tagged_Type (Derived_Type) 14176 or else (not Has_Interfaces (Derived_Type) 14177 and then not (Present (Generic_Actual) 14178 and then Has_Interfaces (Generic_Actual))) 14179 then 14180 Elmt := First_Elmt (Op_List); 14181 while Present (Elmt) loop 14182 Subp := Node (Elmt); 14183 14184 -- Literals are derived earlier in the process of building the 14185 -- derived type, and are skipped here. 14186 14187 if Ekind (Subp) = E_Enumeration_Literal then 14188 null; 14189 14190 -- The actual is a direct descendant and the common primitive 14191 -- operations appear in the same order. 14192 14193 -- If the generic parent type is present, the derived type is an 14194 -- instance of a formal derived type, and within the instance its 14195 -- operations are those of the actual. We derive from the formal 14196 -- type but make the inherited operations aliases of the 14197 -- corresponding operations of the actual. 14198 14199 else 14200 pragma Assert (No (Node (Act_Elmt)) 14201 or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) 14202 and then 14203 Type_Conformant 14204 (Subp, Node (Act_Elmt), 14205 Skip_Controlling_Formals => True))); 14206 14207 Derive_Subprogram 14208 (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); 14209 14210 if Present (Act_Elmt) then 14211 Next_Elmt (Act_Elmt); 14212 end if; 14213 end if; 14214 14215 Next_Elmt (Elmt); 14216 end loop; 14217 14218 -- Case 2: Derived_Type implements interfaces 14219 14220 else 14221 -- If the parent type has no predefined primitives we remove 14222 -- predefined primitives from the list of primitives of generic 14223 -- actual to simplify the complexity of this algorithm. 14224 14225 if Present (Generic_Actual) then 14226 declare 14227 Has_Predefined_Primitives : Boolean := False; 14228 14229 begin 14230 -- Check if the parent type has predefined primitives 14231 14232 Elmt := First_Elmt (Op_List); 14233 while Present (Elmt) loop 14234 Subp := Node (Elmt); 14235 14236 if Is_Predefined_Dispatching_Operation (Subp) 14237 and then not Comes_From_Source (Ultimate_Alias (Subp)) 14238 then 14239 Has_Predefined_Primitives := True; 14240 exit; 14241 end if; 14242 14243 Next_Elmt (Elmt); 14244 end loop; 14245 14246 -- Remove predefined primitives of Generic_Actual. We must use 14247 -- an auxiliary list because in case of tagged types the value 14248 -- returned by Collect_Primitive_Operations is the value stored 14249 -- in its Primitive_Operations attribute (and we don't want to 14250 -- modify its current contents). 14251 14252 if not Has_Predefined_Primitives then 14253 declare 14254 Aux_List : constant Elist_Id := New_Elmt_List; 14255 14256 begin 14257 Elmt := First_Elmt (Act_List); 14258 while Present (Elmt) loop 14259 Subp := Node (Elmt); 14260 14261 if not Is_Predefined_Dispatching_Operation (Subp) 14262 or else Comes_From_Source (Subp) 14263 then 14264 Append_Elmt (Subp, Aux_List); 14265 end if; 14266 14267 Next_Elmt (Elmt); 14268 end loop; 14269 14270 Act_List := Aux_List; 14271 end; 14272 end if; 14273 14274 Act_Elmt := First_Elmt (Act_List); 14275 Act_Subp := Node (Act_Elmt); 14276 end; 14277 end if; 14278 14279 -- Stage 1: If the generic actual is not present we derive the 14280 -- primitives inherited from the parent type. If the generic parent 14281 -- type is present, the derived type is an instance of a formal 14282 -- derived type, and within the instance its operations are those of 14283 -- the actual. We derive from the formal type but make the inherited 14284 -- operations aliases of the corresponding operations of the actual. 14285 14286 Elmt := First_Elmt (Op_List); 14287 while Present (Elmt) loop 14288 Subp := Node (Elmt); 14289 Alias_Subp := Ultimate_Alias (Subp); 14290 14291 -- Do not derive internal entities of the parent that link 14292 -- interface primitives with their covering primitive. These 14293 -- entities will be added to this type when frozen. 14294 14295 if Present (Interface_Alias (Subp)) then 14296 goto Continue; 14297 end if; 14298 14299 -- If the generic actual is present find the corresponding 14300 -- operation in the generic actual. If the parent type is a 14301 -- direct ancestor of the derived type then, even if it is an 14302 -- interface, the operations are inherited from the primary 14303 -- dispatch table and are in the proper order. If we detect here 14304 -- that primitives are not in the same order we traverse the list 14305 -- of primitive operations of the actual to find the one that 14306 -- implements the interface primitive. 14307 14308 if Need_Search 14309 or else 14310 (Present (Generic_Actual) 14311 and then Present (Act_Subp) 14312 and then not 14313 (Primitive_Names_Match (Subp, Act_Subp) 14314 and then 14315 Type_Conformant (Subp, Act_Subp, 14316 Skip_Controlling_Formals => True))) 14317 then 14318 pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual, 14319 Use_Full_View => True)); 14320 14321 -- Remember that we need searching for all pending primitives 14322 14323 Need_Search := True; 14324 14325 -- Handle entities associated with interface primitives 14326 14327 if Present (Alias_Subp) 14328 and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) 14329 and then not Is_Predefined_Dispatching_Operation (Subp) 14330 then 14331 -- Search for the primitive in the homonym chain 14332 14333 Act_Subp := 14334 Find_Primitive_Covering_Interface 14335 (Tagged_Type => Generic_Actual, 14336 Iface_Prim => Alias_Subp); 14337 14338 -- Previous search may not locate primitives covering 14339 -- interfaces defined in generics units or instantiations. 14340 -- (it fails if the covering primitive has formals whose 14341 -- type is also defined in generics or instantiations). 14342 -- In such case we search in the list of primitives of the 14343 -- generic actual for the internal entity that links the 14344 -- interface primitive and the covering primitive. 14345 14346 if No (Act_Subp) 14347 and then Is_Generic_Type (Parent_Type) 14348 then 14349 -- This code has been designed to handle only generic 14350 -- formals that implement interfaces that are defined 14351 -- in a generic unit or instantiation. If this code is 14352 -- needed for other cases we must review it because 14353 -- (given that it relies on Original_Location to locate 14354 -- the primitive of Generic_Actual that covers the 14355 -- interface) it could leave linked through attribute 14356 -- Alias entities of unrelated instantiations). 14357 14358 pragma Assert 14359 (Is_Generic_Unit 14360 (Scope (Find_Dispatching_Type (Alias_Subp))) 14361 or else 14362 Instantiation_Depth 14363 (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); 14364 14365 declare 14366 Iface_Prim_Loc : constant Source_Ptr := 14367 Original_Location (Sloc (Alias_Subp)); 14368 14369 Elmt : Elmt_Id; 14370 Prim : Entity_Id; 14371 14372 begin 14373 Elmt := 14374 First_Elmt (Primitive_Operations (Generic_Actual)); 14375 14376 Search : while Present (Elmt) loop 14377 Prim := Node (Elmt); 14378 14379 if Present (Interface_Alias (Prim)) 14380 and then Original_Location 14381 (Sloc (Interface_Alias (Prim))) = 14382 Iface_Prim_Loc 14383 then 14384 Act_Subp := Alias (Prim); 14385 exit Search; 14386 end if; 14387 14388 Next_Elmt (Elmt); 14389 end loop Search; 14390 end; 14391 end if; 14392 14393 pragma Assert (Present (Act_Subp) 14394 or else Is_Abstract_Type (Generic_Actual) 14395 or else Serious_Errors_Detected > 0); 14396 14397 -- Handle predefined primitives plus the rest of user-defined 14398 -- primitives 14399 14400 else 14401 Act_Elmt := First_Elmt (Act_List); 14402 while Present (Act_Elmt) loop 14403 Act_Subp := Node (Act_Elmt); 14404 14405 exit when Primitive_Names_Match (Subp, Act_Subp) 14406 and then Type_Conformant 14407 (Subp, Act_Subp, 14408 Skip_Controlling_Formals => True) 14409 and then No (Interface_Alias (Act_Subp)); 14410 14411 Next_Elmt (Act_Elmt); 14412 end loop; 14413 14414 if No (Act_Elmt) then 14415 Act_Subp := Empty; 14416 end if; 14417 end if; 14418 end if; 14419 14420 -- Case 1: If the parent is a limited interface then it has the 14421 -- predefined primitives of synchronized interfaces. However, the 14422 -- actual type may be a non-limited type and hence it does not 14423 -- have such primitives. 14424 14425 if Present (Generic_Actual) 14426 and then not Present (Act_Subp) 14427 and then Is_Limited_Interface (Parent_Base) 14428 and then Is_Predefined_Interface_Primitive (Subp) 14429 then 14430 null; 14431 14432 -- Case 2: Inherit entities associated with interfaces that were 14433 -- not covered by the parent type. We exclude here null interface 14434 -- primitives because they do not need special management. 14435 14436 -- We also exclude interface operations that are renamings. If the 14437 -- subprogram is an explicit renaming of an interface primitive, 14438 -- it is a regular primitive operation, and the presence of its 14439 -- alias is not relevant: it has to be derived like any other 14440 -- primitive. 14441 14442 elsif Present (Alias (Subp)) 14443 and then Nkind (Unit_Declaration_Node (Subp)) /= 14444 N_Subprogram_Renaming_Declaration 14445 and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) 14446 and then not 14447 (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification 14448 and then Null_Present (Parent (Alias_Subp))) 14449 then 14450 -- If this is an abstract private type then we transfer the 14451 -- derivation of the interface primitive from the partial view 14452 -- to the full view. This is safe because all the interfaces 14453 -- must be visible in the partial view. Done to avoid adding 14454 -- a new interface derivation to the private part of the 14455 -- enclosing package; otherwise this new derivation would be 14456 -- decorated as hidden when the analysis of the enclosing 14457 -- package completes. 14458 14459 if Is_Abstract_Type (Derived_Type) 14460 and then In_Private_Part (Current_Scope) 14461 and then Has_Private_Declaration (Derived_Type) 14462 then 14463 declare 14464 Partial_View : Entity_Id; 14465 Elmt : Elmt_Id; 14466 Ent : Entity_Id; 14467 14468 begin 14469 Partial_View := First_Entity (Current_Scope); 14470 loop 14471 exit when No (Partial_View) 14472 or else (Has_Private_Declaration (Partial_View) 14473 and then 14474 Full_View (Partial_View) = Derived_Type); 14475 14476 Next_Entity (Partial_View); 14477 end loop; 14478 14479 -- If the partial view was not found then the source code 14480 -- has errors and the derivation is not needed. 14481 14482 if Present (Partial_View) then 14483 Elmt := 14484 First_Elmt (Primitive_Operations (Partial_View)); 14485 while Present (Elmt) loop 14486 Ent := Node (Elmt); 14487 14488 if Present (Alias (Ent)) 14489 and then Ultimate_Alias (Ent) = Alias (Subp) 14490 then 14491 Append_Elmt 14492 (Ent, Primitive_Operations (Derived_Type)); 14493 exit; 14494 end if; 14495 14496 Next_Elmt (Elmt); 14497 end loop; 14498 14499 -- If the interface primitive was not found in the 14500 -- partial view then this interface primitive was 14501 -- overridden. We add a derivation to activate in 14502 -- Derive_Progenitor_Subprograms the machinery to 14503 -- search for it. 14504 14505 if No (Elmt) then 14506 Derive_Interface_Subprogram 14507 (New_Subp => New_Subp, 14508 Subp => Subp, 14509 Actual_Subp => Act_Subp); 14510 end if; 14511 end if; 14512 end; 14513 else 14514 Derive_Interface_Subprogram 14515 (New_Subp => New_Subp, 14516 Subp => Subp, 14517 Actual_Subp => Act_Subp); 14518 end if; 14519 14520 -- Case 3: Common derivation 14521 14522 else 14523 Derive_Subprogram 14524 (New_Subp => New_Subp, 14525 Parent_Subp => Subp, 14526 Derived_Type => Derived_Type, 14527 Parent_Type => Parent_Base, 14528 Actual_Subp => Act_Subp); 14529 end if; 14530 14531 -- No need to update Act_Elm if we must search for the 14532 -- corresponding operation in the generic actual 14533 14534 if not Need_Search 14535 and then Present (Act_Elmt) 14536 then 14537 Next_Elmt (Act_Elmt); 14538 Act_Subp := Node (Act_Elmt); 14539 end if; 14540 14541 <<Continue>> 14542 Next_Elmt (Elmt); 14543 end loop; 14544 14545 -- Inherit additional operations from progenitors. If the derived 14546 -- type is a generic actual, there are not new primitive operations 14547 -- for the type because it has those of the actual, and therefore 14548 -- nothing needs to be done. The renamings generated above are not 14549 -- primitive operations, and their purpose is simply to make the 14550 -- proper operations visible within an instantiation. 14551 14552 if No (Generic_Actual) then 14553 Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); 14554 end if; 14555 end if; 14556 14557 -- Final check: Direct descendants must have their primitives in the 14558 -- same order. We exclude from this test untagged types and instances 14559 -- of formal derived types. We skip this test if we have already 14560 -- reported serious errors in the sources. 14561 14562 pragma Assert (not Is_Tagged_Type (Derived_Type) 14563 or else Present (Generic_Actual) 14564 or else Serious_Errors_Detected > 0 14565 or else Check_Derived_Type); 14566 end Derive_Subprograms; 14567 14568 -------------------------------- 14569 -- Derived_Standard_Character -- 14570 -------------------------------- 14571 14572 procedure Derived_Standard_Character 14573 (N : Node_Id; 14574 Parent_Type : Entity_Id; 14575 Derived_Type : Entity_Id) 14576 is 14577 Loc : constant Source_Ptr := Sloc (N); 14578 Def : constant Node_Id := Type_Definition (N); 14579 Indic : constant Node_Id := Subtype_Indication (Def); 14580 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 14581 Implicit_Base : constant Entity_Id := 14582 Create_Itype 14583 (E_Enumeration_Type, N, Derived_Type, 'B'); 14584 14585 Lo : Node_Id; 14586 Hi : Node_Id; 14587 14588 begin 14589 Discard_Node (Process_Subtype (Indic, N)); 14590 14591 Set_Etype (Implicit_Base, Parent_Base); 14592 Set_Size_Info (Implicit_Base, Root_Type (Parent_Type)); 14593 Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type))); 14594 14595 Set_Is_Character_Type (Implicit_Base, True); 14596 Set_Has_Delayed_Freeze (Implicit_Base); 14597 14598 -- The bounds of the implicit base are the bounds of the parent base. 14599 -- Note that their type is the parent base. 14600 14601 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); 14602 Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); 14603 14604 Set_Scalar_Range (Implicit_Base, 14605 Make_Range (Loc, 14606 Low_Bound => Lo, 14607 High_Bound => Hi)); 14608 14609 Conditional_Delay (Derived_Type, Parent_Type); 14610 14611 Set_Ekind (Derived_Type, E_Enumeration_Subtype); 14612 Set_Etype (Derived_Type, Implicit_Base); 14613 Set_Size_Info (Derived_Type, Parent_Type); 14614 14615 if Unknown_RM_Size (Derived_Type) then 14616 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 14617 end if; 14618 14619 Set_Is_Character_Type (Derived_Type, True); 14620 14621 if Nkind (Indic) /= N_Subtype_Indication then 14622 14623 -- If no explicit constraint, the bounds are those 14624 -- of the parent type. 14625 14626 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type)); 14627 Hi := New_Copy_Tree (Type_High_Bound (Parent_Type)); 14628 Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi)); 14629 end if; 14630 14631 Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); 14632 14633 -- Because the implicit base is used in the conversion of the bounds, we 14634 -- have to freeze it now. This is similar to what is done for numeric 14635 -- types, and it equally suspicious, but otherwise a non-static bound 14636 -- will have a reference to an unfrozen type, which is rejected by Gigi 14637 -- (???). This requires specific care for definition of stream 14638 -- attributes. For details, see comments at the end of 14639 -- Build_Derived_Numeric_Type. 14640 14641 Freeze_Before (N, Implicit_Base); 14642 end Derived_Standard_Character; 14643 14644 ------------------------------ 14645 -- Derived_Type_Declaration -- 14646 ------------------------------ 14647 14648 procedure Derived_Type_Declaration 14649 (T : Entity_Id; 14650 N : Node_Id; 14651 Is_Completion : Boolean) 14652 is 14653 Parent_Type : Entity_Id; 14654 14655 function Comes_From_Generic (Typ : Entity_Id) return Boolean; 14656 -- Check whether the parent type is a generic formal, or derives 14657 -- directly or indirectly from one. 14658 14659 ------------------------ 14660 -- Comes_From_Generic -- 14661 ------------------------ 14662 14663 function Comes_From_Generic (Typ : Entity_Id) return Boolean is 14664 begin 14665 if Is_Generic_Type (Typ) then 14666 return True; 14667 14668 elsif Is_Generic_Type (Root_Type (Parent_Type)) then 14669 return True; 14670 14671 elsif Is_Private_Type (Typ) 14672 and then Present (Full_View (Typ)) 14673 and then Is_Generic_Type (Root_Type (Full_View (Typ))) 14674 then 14675 return True; 14676 14677 elsif Is_Generic_Actual_Type (Typ) then 14678 return True; 14679 14680 else 14681 return False; 14682 end if; 14683 end Comes_From_Generic; 14684 14685 -- Local variables 14686 14687 Def : constant Node_Id := Type_Definition (N); 14688 Iface_Def : Node_Id; 14689 Indic : constant Node_Id := Subtype_Indication (Def); 14690 Extension : constant Node_Id := Record_Extension_Part (Def); 14691 Parent_Node : Node_Id; 14692 Taggd : Boolean; 14693 14694 -- Start of processing for Derived_Type_Declaration 14695 14696 begin 14697 Parent_Type := Find_Type_Of_Subtype_Indic (Indic); 14698 14699 -- Ada 2005 (AI-251): In case of interface derivation check that the 14700 -- parent is also an interface. 14701 14702 if Interface_Present (Def) then 14703 Check_SPARK_Restriction ("interface is not allowed", Def); 14704 14705 if not Is_Interface (Parent_Type) then 14706 Diagnose_Interface (Indic, Parent_Type); 14707 14708 else 14709 Parent_Node := Parent (Base_Type (Parent_Type)); 14710 Iface_Def := Type_Definition (Parent_Node); 14711 14712 -- Ada 2005 (AI-251): Limited interfaces can only inherit from 14713 -- other limited interfaces. 14714 14715 if Limited_Present (Def) then 14716 if Limited_Present (Iface_Def) then 14717 null; 14718 14719 elsif Protected_Present (Iface_Def) then 14720 Error_Msg_NE 14721 ("descendant of& must be declared" 14722 & " as a protected interface", 14723 N, Parent_Type); 14724 14725 elsif Synchronized_Present (Iface_Def) then 14726 Error_Msg_NE 14727 ("descendant of& must be declared" 14728 & " as a synchronized interface", 14729 N, Parent_Type); 14730 14731 elsif Task_Present (Iface_Def) then 14732 Error_Msg_NE 14733 ("descendant of& must be declared as a task interface", 14734 N, Parent_Type); 14735 14736 else 14737 Error_Msg_N 14738 ("(Ada 2005) limited interface cannot " 14739 & "inherit from non-limited interface", Indic); 14740 end if; 14741 14742 -- Ada 2005 (AI-345): Non-limited interfaces can only inherit 14743 -- from non-limited or limited interfaces. 14744 14745 elsif not Protected_Present (Def) 14746 and then not Synchronized_Present (Def) 14747 and then not Task_Present (Def) 14748 then 14749 if Limited_Present (Iface_Def) then 14750 null; 14751 14752 elsif Protected_Present (Iface_Def) then 14753 Error_Msg_NE 14754 ("descendant of& must be declared" 14755 & " as a protected interface", 14756 N, Parent_Type); 14757 14758 elsif Synchronized_Present (Iface_Def) then 14759 Error_Msg_NE 14760 ("descendant of& must be declared" 14761 & " as a synchronized interface", 14762 N, Parent_Type); 14763 14764 elsif Task_Present (Iface_Def) then 14765 Error_Msg_NE 14766 ("descendant of& must be declared as a task interface", 14767 N, Parent_Type); 14768 else 14769 null; 14770 end if; 14771 end if; 14772 end if; 14773 end if; 14774 14775 if Is_Tagged_Type (Parent_Type) 14776 and then Is_Concurrent_Type (Parent_Type) 14777 and then not Is_Interface (Parent_Type) 14778 then 14779 Error_Msg_N 14780 ("parent type of a record extension cannot be " 14781 & "a synchronized tagged type (RM 3.9.1 (3/1))", N); 14782 Set_Etype (T, Any_Type); 14783 return; 14784 end if; 14785 14786 -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor 14787 -- interfaces 14788 14789 if Is_Tagged_Type (Parent_Type) 14790 and then Is_Non_Empty_List (Interface_List (Def)) 14791 then 14792 declare 14793 Intf : Node_Id; 14794 T : Entity_Id; 14795 14796 begin 14797 Intf := First (Interface_List (Def)); 14798 while Present (Intf) loop 14799 T := Find_Type_Of_Subtype_Indic (Intf); 14800 14801 if not Is_Interface (T) then 14802 Diagnose_Interface (Intf, T); 14803 14804 -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow 14805 -- a limited type from having a nonlimited progenitor. 14806 14807 elsif (Limited_Present (Def) 14808 or else (not Is_Interface (Parent_Type) 14809 and then Is_Limited_Type (Parent_Type))) 14810 and then not Is_Limited_Interface (T) 14811 then 14812 Error_Msg_NE 14813 ("progenitor interface& of limited type must be limited", 14814 N, T); 14815 end if; 14816 14817 Next (Intf); 14818 end loop; 14819 end; 14820 end if; 14821 14822 if Parent_Type = Any_Type 14823 or else Etype (Parent_Type) = Any_Type 14824 or else (Is_Class_Wide_Type (Parent_Type) 14825 and then Etype (Parent_Type) = T) 14826 then 14827 -- If Parent_Type is undefined or illegal, make new type into a 14828 -- subtype of Any_Type, and set a few attributes to prevent cascaded 14829 -- errors. If this is a self-definition, emit error now. 14830 14831 if T = Parent_Type 14832 or else T = Etype (Parent_Type) 14833 then 14834 Error_Msg_N ("type cannot be used in its own definition", Indic); 14835 end if; 14836 14837 Set_Ekind (T, Ekind (Parent_Type)); 14838 Set_Etype (T, Any_Type); 14839 Set_Scalar_Range (T, Scalar_Range (Any_Type)); 14840 14841 if Is_Tagged_Type (T) 14842 and then Is_Record_Type (T) 14843 then 14844 Set_Direct_Primitive_Operations (T, New_Elmt_List); 14845 end if; 14846 14847 return; 14848 end if; 14849 14850 -- Ada 2005 (AI-251): The case in which the parent of the full-view is 14851 -- an interface is special because the list of interfaces in the full 14852 -- view can be given in any order. For example: 14853 14854 -- type A is interface; 14855 -- type B is interface and A; 14856 -- type D is new B with private; 14857 -- private 14858 -- type D is new A and B with null record; -- 1 -- 14859 14860 -- In this case we perform the following transformation of -1-: 14861 14862 -- type D is new B and A with null record; 14863 14864 -- If the parent of the full-view covers the parent of the partial-view 14865 -- we have two possible cases: 14866 14867 -- 1) They have the same parent 14868 -- 2) The parent of the full-view implements some further interfaces 14869 14870 -- In both cases we do not need to perform the transformation. In the 14871 -- first case the source program is correct and the transformation is 14872 -- not needed; in the second case the source program does not fulfill 14873 -- the no-hidden interfaces rule (AI-396) and the error will be reported 14874 -- later. 14875 14876 -- This transformation not only simplifies the rest of the analysis of 14877 -- this type declaration but also simplifies the correct generation of 14878 -- the object layout to the expander. 14879 14880 if In_Private_Part (Current_Scope) 14881 and then Is_Interface (Parent_Type) 14882 then 14883 declare 14884 Iface : Node_Id; 14885 Partial_View : Entity_Id; 14886 Partial_View_Parent : Entity_Id; 14887 New_Iface : Node_Id; 14888 14889 begin 14890 -- Look for the associated private type declaration 14891 14892 Partial_View := First_Entity (Current_Scope); 14893 loop 14894 exit when No (Partial_View) 14895 or else (Has_Private_Declaration (Partial_View) 14896 and then Full_View (Partial_View) = T); 14897 14898 Next_Entity (Partial_View); 14899 end loop; 14900 14901 -- If the partial view was not found then the source code has 14902 -- errors and the transformation is not needed. 14903 14904 if Present (Partial_View) then 14905 Partial_View_Parent := Etype (Partial_View); 14906 14907 -- If the parent of the full-view covers the parent of the 14908 -- partial-view we have nothing else to do. 14909 14910 if Interface_Present_In_Ancestor 14911 (Parent_Type, Partial_View_Parent) 14912 then 14913 null; 14914 14915 -- Traverse the list of interfaces of the full-view to look 14916 -- for the parent of the partial-view and perform the tree 14917 -- transformation. 14918 14919 else 14920 Iface := First (Interface_List (Def)); 14921 while Present (Iface) loop 14922 if Etype (Iface) = Etype (Partial_View) then 14923 Rewrite (Subtype_Indication (Def), 14924 New_Copy (Subtype_Indication 14925 (Parent (Partial_View)))); 14926 14927 New_Iface := 14928 Make_Identifier (Sloc (N), Chars (Parent_Type)); 14929 Append (New_Iface, Interface_List (Def)); 14930 14931 -- Analyze the transformed code 14932 14933 Derived_Type_Declaration (T, N, Is_Completion); 14934 return; 14935 end if; 14936 14937 Next (Iface); 14938 end loop; 14939 end if; 14940 end if; 14941 end; 14942 end if; 14943 14944 -- Only composite types other than array types are allowed to have 14945 -- discriminants. In SPARK, no types are allowed to have discriminants. 14946 14947 if Present (Discriminant_Specifications (N)) then 14948 if (Is_Elementary_Type (Parent_Type) 14949 or else Is_Array_Type (Parent_Type)) 14950 and then not Error_Posted (N) 14951 then 14952 Error_Msg_N 14953 ("elementary or array type cannot have discriminants", 14954 Defining_Identifier (First (Discriminant_Specifications (N)))); 14955 Set_Has_Discriminants (T, False); 14956 else 14957 Check_SPARK_Restriction ("discriminant type is not allowed", N); 14958 end if; 14959 end if; 14960 14961 -- In Ada 83, a derived type defined in a package specification cannot 14962 -- be used for further derivation until the end of its visible part. 14963 -- Note that derivation in the private part of the package is allowed. 14964 14965 if Ada_Version = Ada_83 14966 and then Is_Derived_Type (Parent_Type) 14967 and then In_Visible_Part (Scope (Parent_Type)) 14968 then 14969 if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then 14970 Error_Msg_N 14971 ("(Ada 83): premature use of type for derivation", Indic); 14972 end if; 14973 end if; 14974 14975 -- Check for early use of incomplete or private type 14976 14977 if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then 14978 Error_Msg_N ("premature derivation of incomplete type", Indic); 14979 return; 14980 14981 elsif (Is_Incomplete_Or_Private_Type (Parent_Type) 14982 and then not Comes_From_Generic (Parent_Type)) 14983 or else Has_Private_Component (Parent_Type) 14984 then 14985 -- The ancestor type of a formal type can be incomplete, in which 14986 -- case only the operations of the partial view are available in the 14987 -- generic. Subsequent checks may be required when the full view is 14988 -- analyzed to verify that a derivation from a tagged type has an 14989 -- extension. 14990 14991 if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then 14992 null; 14993 14994 elsif No (Underlying_Type (Parent_Type)) 14995 or else Has_Private_Component (Parent_Type) 14996 then 14997 Error_Msg_N 14998 ("premature derivation of derived or private type", Indic); 14999 15000 -- Flag the type itself as being in error, this prevents some 15001 -- nasty problems with subsequent uses of the malformed type. 15002 15003 Set_Error_Posted (T); 15004 15005 -- Check that within the immediate scope of an untagged partial 15006 -- view it's illegal to derive from the partial view if the 15007 -- full view is tagged. (7.3(7)) 15008 15009 -- We verify that the Parent_Type is a partial view by checking 15010 -- that it is not a Full_Type_Declaration (i.e. a private type or 15011 -- private extension declaration), to distinguish a partial view 15012 -- from a derivation from a private type which also appears as 15013 -- E_Private_Type. If the parent base type is not declared in an 15014 -- enclosing scope there is no need to check. 15015 15016 elsif Present (Full_View (Parent_Type)) 15017 and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration 15018 and then not Is_Tagged_Type (Parent_Type) 15019 and then Is_Tagged_Type (Full_View (Parent_Type)) 15020 and then In_Open_Scopes (Scope (Base_Type (Parent_Type))) 15021 then 15022 Error_Msg_N 15023 ("premature derivation from type with tagged full view", 15024 Indic); 15025 end if; 15026 end if; 15027 15028 -- Check that form of derivation is appropriate 15029 15030 Taggd := Is_Tagged_Type (Parent_Type); 15031 15032 -- Perhaps the parent type should be changed to the class-wide type's 15033 -- specific type in this case to prevent cascading errors ??? 15034 15035 if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then 15036 Error_Msg_N ("parent type must not be a class-wide type", Indic); 15037 return; 15038 end if; 15039 15040 if Present (Extension) and then not Taggd then 15041 Error_Msg_N 15042 ("type derived from untagged type cannot have extension", Indic); 15043 15044 elsif No (Extension) and then Taggd then 15045 15046 -- If this declaration is within a private part (or body) of a 15047 -- generic instantiation then the derivation is allowed (the parent 15048 -- type can only appear tagged in this case if it's a generic actual 15049 -- type, since it would otherwise have been rejected in the analysis 15050 -- of the generic template). 15051 15052 if not Is_Generic_Actual_Type (Parent_Type) 15053 or else In_Visible_Part (Scope (Parent_Type)) 15054 then 15055 if Is_Class_Wide_Type (Parent_Type) then 15056 Error_Msg_N 15057 ("parent type must not be a class-wide type", Indic); 15058 15059 -- Use specific type to prevent cascaded errors. 15060 15061 Parent_Type := Etype (Parent_Type); 15062 15063 else 15064 Error_Msg_N 15065 ("type derived from tagged type must have extension", Indic); 15066 end if; 15067 end if; 15068 end if; 15069 15070 -- AI-443: Synchronized formal derived types require a private 15071 -- extension. There is no point in checking the ancestor type or 15072 -- the progenitors since the construct is wrong to begin with. 15073 15074 if Ada_Version >= Ada_2005 15075 and then Is_Generic_Type (T) 15076 and then Present (Original_Node (N)) 15077 then 15078 declare 15079 Decl : constant Node_Id := Original_Node (N); 15080 15081 begin 15082 if Nkind (Decl) = N_Formal_Type_Declaration 15083 and then Nkind (Formal_Type_Definition (Decl)) = 15084 N_Formal_Derived_Type_Definition 15085 and then Synchronized_Present (Formal_Type_Definition (Decl)) 15086 and then No (Extension) 15087 15088 -- Avoid emitting a duplicate error message 15089 15090 and then not Error_Posted (Indic) 15091 then 15092 Error_Msg_N 15093 ("synchronized derived type must have extension", N); 15094 end if; 15095 end; 15096 end if; 15097 15098 if Null_Exclusion_Present (Def) 15099 and then not Is_Access_Type (Parent_Type) 15100 then 15101 Error_Msg_N ("null exclusion can only apply to an access type", N); 15102 end if; 15103 15104 -- Avoid deriving parent primitives of underlying record views 15105 15106 Build_Derived_Type (N, Parent_Type, T, Is_Completion, 15107 Derive_Subps => not Is_Underlying_Record_View (T)); 15108 15109 -- AI-419: The parent type of an explicitly limited derived type must 15110 -- be a limited type or a limited interface. 15111 15112 if Limited_Present (Def) then 15113 Set_Is_Limited_Record (T); 15114 15115 if Is_Interface (T) then 15116 Set_Is_Limited_Interface (T); 15117 end if; 15118 15119 if not Is_Limited_Type (Parent_Type) 15120 and then 15121 (not Is_Interface (Parent_Type) 15122 or else not Is_Limited_Interface (Parent_Type)) 15123 then 15124 -- AI05-0096: a derivation in the private part of an instance is 15125 -- legal if the generic formal is untagged limited, and the actual 15126 -- is non-limited. 15127 15128 if Is_Generic_Actual_Type (Parent_Type) 15129 and then In_Private_Part (Current_Scope) 15130 and then 15131 not Is_Tagged_Type 15132 (Generic_Parent_Type (Parent (Parent_Type))) 15133 then 15134 null; 15135 15136 else 15137 Error_Msg_NE 15138 ("parent type& of limited type must be limited", 15139 N, Parent_Type); 15140 end if; 15141 end if; 15142 end if; 15143 15144 -- In SPARK, there are no derived type definitions other than type 15145 -- extensions of tagged record types. 15146 15147 if No (Extension) then 15148 Check_SPARK_Restriction 15149 ("derived type is not allowed", Original_Node (N)); 15150 end if; 15151 end Derived_Type_Declaration; 15152 15153 ------------------------ 15154 -- Diagnose_Interface -- 15155 ------------------------ 15156 15157 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is 15158 begin 15159 if not Is_Interface (E) 15160 and then E /= Any_Type 15161 then 15162 Error_Msg_NE ("(Ada 2005) & must be an interface", N, E); 15163 end if; 15164 end Diagnose_Interface; 15165 15166 ---------------------------------- 15167 -- Enumeration_Type_Declaration -- 15168 ---------------------------------- 15169 15170 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is 15171 Ev : Uint; 15172 L : Node_Id; 15173 R_Node : Node_Id; 15174 B_Node : Node_Id; 15175 15176 begin 15177 -- Create identifier node representing lower bound 15178 15179 B_Node := New_Node (N_Identifier, Sloc (Def)); 15180 L := First (Literals (Def)); 15181 Set_Chars (B_Node, Chars (L)); 15182 Set_Entity (B_Node, L); 15183 Set_Etype (B_Node, T); 15184 Set_Is_Static_Expression (B_Node, True); 15185 15186 R_Node := New_Node (N_Range, Sloc (Def)); 15187 Set_Low_Bound (R_Node, B_Node); 15188 15189 Set_Ekind (T, E_Enumeration_Type); 15190 Set_First_Literal (T, L); 15191 Set_Etype (T, T); 15192 Set_Is_Constrained (T); 15193 15194 Ev := Uint_0; 15195 15196 -- Loop through literals of enumeration type setting pos and rep values 15197 -- except that if the Ekind is already set, then it means the literal 15198 -- was already constructed (case of a derived type declaration and we 15199 -- should not disturb the Pos and Rep values. 15200 15201 while Present (L) loop 15202 if Ekind (L) /= E_Enumeration_Literal then 15203 Set_Ekind (L, E_Enumeration_Literal); 15204 Set_Enumeration_Pos (L, Ev); 15205 Set_Enumeration_Rep (L, Ev); 15206 Set_Is_Known_Valid (L, True); 15207 end if; 15208 15209 Set_Etype (L, T); 15210 New_Overloaded_Entity (L); 15211 Generate_Definition (L); 15212 Set_Convention (L, Convention_Intrinsic); 15213 15214 -- Case of character literal 15215 15216 if Nkind (L) = N_Defining_Character_Literal then 15217 Set_Is_Character_Type (T, True); 15218 15219 -- Check violation of No_Wide_Characters 15220 15221 if Restriction_Check_Required (No_Wide_Characters) then 15222 Get_Name_String (Chars (L)); 15223 15224 if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then 15225 Check_Restriction (No_Wide_Characters, L); 15226 end if; 15227 end if; 15228 end if; 15229 15230 Ev := Ev + 1; 15231 Next (L); 15232 end loop; 15233 15234 -- Now create a node representing upper bound 15235 15236 B_Node := New_Node (N_Identifier, Sloc (Def)); 15237 Set_Chars (B_Node, Chars (Last (Literals (Def)))); 15238 Set_Entity (B_Node, Last (Literals (Def))); 15239 Set_Etype (B_Node, T); 15240 Set_Is_Static_Expression (B_Node, True); 15241 15242 Set_High_Bound (R_Node, B_Node); 15243 15244 -- Initialize various fields of the type. Some of this information 15245 -- may be overwritten later through rep.clauses. 15246 15247 Set_Scalar_Range (T, R_Node); 15248 Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); 15249 Set_Enum_Esize (T); 15250 Set_Enum_Pos_To_Rep (T, Empty); 15251 15252 -- Set Discard_Names if configuration pragma set, or if there is 15253 -- a parameterless pragma in the current declarative region 15254 15255 if Global_Discard_Names or else Discard_Names (Scope (T)) then 15256 Set_Discard_Names (T); 15257 end if; 15258 15259 -- Process end label if there is one 15260 15261 if Present (Def) then 15262 Process_End_Label (Def, 'e', T); 15263 end if; 15264 end Enumeration_Type_Declaration; 15265 15266 --------------------------------- 15267 -- Expand_To_Stored_Constraint -- 15268 --------------------------------- 15269 15270 function Expand_To_Stored_Constraint 15271 (Typ : Entity_Id; 15272 Constraint : Elist_Id) return Elist_Id 15273 is 15274 Explicitly_Discriminated_Type : Entity_Id; 15275 Expansion : Elist_Id; 15276 Discriminant : Entity_Id; 15277 15278 function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id; 15279 -- Find the nearest type that actually specifies discriminants 15280 15281 --------------------------------- 15282 -- Type_With_Explicit_Discrims -- 15283 --------------------------------- 15284 15285 function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is 15286 Typ : constant E := Base_Type (Id); 15287 15288 begin 15289 if Ekind (Typ) in Incomplete_Or_Private_Kind then 15290 if Present (Full_View (Typ)) then 15291 return Type_With_Explicit_Discrims (Full_View (Typ)); 15292 end if; 15293 15294 else 15295 if Has_Discriminants (Typ) then 15296 return Typ; 15297 end if; 15298 end if; 15299 15300 if Etype (Typ) = Typ then 15301 return Empty; 15302 elsif Has_Discriminants (Typ) then 15303 return Typ; 15304 else 15305 return Type_With_Explicit_Discrims (Etype (Typ)); 15306 end if; 15307 15308 end Type_With_Explicit_Discrims; 15309 15310 -- Start of processing for Expand_To_Stored_Constraint 15311 15312 begin 15313 if No (Constraint) 15314 or else Is_Empty_Elmt_List (Constraint) 15315 then 15316 return No_Elist; 15317 end if; 15318 15319 Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ); 15320 15321 if No (Explicitly_Discriminated_Type) then 15322 return No_Elist; 15323 end if; 15324 15325 Expansion := New_Elmt_List; 15326 15327 Discriminant := 15328 First_Stored_Discriminant (Explicitly_Discriminated_Type); 15329 while Present (Discriminant) loop 15330 Append_Elmt ( 15331 Get_Discriminant_Value ( 15332 Discriminant, Explicitly_Discriminated_Type, Constraint), 15333 Expansion); 15334 Next_Stored_Discriminant (Discriminant); 15335 end loop; 15336 15337 return Expansion; 15338 end Expand_To_Stored_Constraint; 15339 15340 --------------------------- 15341 -- Find_Hidden_Interface -- 15342 --------------------------- 15343 15344 function Find_Hidden_Interface 15345 (Src : Elist_Id; 15346 Dest : Elist_Id) return Entity_Id 15347 is 15348 Iface : Entity_Id; 15349 Iface_Elmt : Elmt_Id; 15350 15351 begin 15352 if Present (Src) and then Present (Dest) then 15353 Iface_Elmt := First_Elmt (Src); 15354 while Present (Iface_Elmt) loop 15355 Iface := Node (Iface_Elmt); 15356 15357 if Is_Interface (Iface) 15358 and then not Contain_Interface (Iface, Dest) 15359 then 15360 return Iface; 15361 end if; 15362 15363 Next_Elmt (Iface_Elmt); 15364 end loop; 15365 end if; 15366 15367 return Empty; 15368 end Find_Hidden_Interface; 15369 15370 -------------------- 15371 -- Find_Type_Name -- 15372 -------------------- 15373 15374 function Find_Type_Name (N : Node_Id) return Entity_Id is 15375 Id : constant Entity_Id := Defining_Identifier (N); 15376 Prev : Entity_Id; 15377 New_Id : Entity_Id; 15378 Prev_Par : Node_Id; 15379 15380 procedure Check_Duplicate_Aspects; 15381 -- Check that aspects specified in a completion have not been specified 15382 -- already in the partial view. Type_Invariant and others can be 15383 -- specified on either view but never on both. 15384 15385 procedure Tag_Mismatch; 15386 -- Diagnose a tagged partial view whose full view is untagged. 15387 -- We post the message on the full view, with a reference to 15388 -- the previous partial view. The partial view can be private 15389 -- or incomplete, and these are handled in a different manner, 15390 -- so we determine the position of the error message from the 15391 -- respective slocs of both. 15392 15393 ----------------------------- 15394 -- Check_Duplicate_Aspects -- 15395 ----------------------------- 15396 procedure Check_Duplicate_Aspects is 15397 Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par); 15398 Full_Aspects : constant List_Id := Aspect_Specifications (N); 15399 F_Spec, P_Spec : Node_Id; 15400 15401 begin 15402 if Present (Prev_Aspects) and then Present (Full_Aspects) then 15403 F_Spec := First (Full_Aspects); 15404 while Present (F_Spec) loop 15405 P_Spec := First (Prev_Aspects); 15406 while Present (P_Spec) loop 15407 if 15408 Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec)) 15409 then 15410 Error_Msg_N 15411 ("aspect already specified in private declaration", 15412 F_Spec); 15413 Remove (F_Spec); 15414 return; 15415 end if; 15416 15417 Next (P_Spec); 15418 end loop; 15419 15420 Next (F_Spec); 15421 end loop; 15422 end if; 15423 end Check_Duplicate_Aspects; 15424 15425 ------------------ 15426 -- Tag_Mismatch -- 15427 ------------------ 15428 15429 procedure Tag_Mismatch is 15430 begin 15431 if Sloc (Prev) < Sloc (Id) then 15432 if Ada_Version >= Ada_2012 15433 and then Nkind (N) = N_Private_Type_Declaration 15434 then 15435 Error_Msg_NE 15436 ("declaration of private } must be a tagged type ", Id, Prev); 15437 else 15438 Error_Msg_NE 15439 ("full declaration of } must be a tagged type ", Id, Prev); 15440 end if; 15441 15442 else 15443 if Ada_Version >= Ada_2012 15444 and then Nkind (N) = N_Private_Type_Declaration 15445 then 15446 Error_Msg_NE 15447 ("declaration of private } must be a tagged type ", Prev, Id); 15448 else 15449 Error_Msg_NE 15450 ("full declaration of } must be a tagged type ", Prev, Id); 15451 end if; 15452 end if; 15453 end Tag_Mismatch; 15454 15455 -- Start of processing for Find_Type_Name 15456 15457 begin 15458 -- Find incomplete declaration, if one was given 15459 15460 Prev := Current_Entity_In_Scope (Id); 15461 15462 -- New type declaration 15463 15464 if No (Prev) then 15465 Enter_Name (Id); 15466 return Id; 15467 15468 -- Previous declaration exists 15469 15470 else 15471 Prev_Par := Parent (Prev); 15472 15473 -- Error if not incomplete/private case except if previous 15474 -- declaration is implicit, etc. Enter_Name will emit error if 15475 -- appropriate. 15476 15477 if not Is_Incomplete_Or_Private_Type (Prev) then 15478 Enter_Name (Id); 15479 New_Id := Id; 15480 15481 -- Check invalid completion of private or incomplete type 15482 15483 elsif not Nkind_In (N, N_Full_Type_Declaration, 15484 N_Task_Type_Declaration, 15485 N_Protected_Type_Declaration) 15486 and then 15487 (Ada_Version < Ada_2012 15488 or else not Is_Incomplete_Type (Prev) 15489 or else not Nkind_In (N, N_Private_Type_Declaration, 15490 N_Private_Extension_Declaration)) 15491 then 15492 -- Completion must be a full type declarations (RM 7.3(4)) 15493 15494 Error_Msg_Sloc := Sloc (Prev); 15495 Error_Msg_NE ("invalid completion of }", Id, Prev); 15496 15497 -- Set scope of Id to avoid cascaded errors. Entity is never 15498 -- examined again, except when saving globals in generics. 15499 15500 Set_Scope (Id, Current_Scope); 15501 New_Id := Id; 15502 15503 -- If this is a repeated incomplete declaration, no further 15504 -- checks are possible. 15505 15506 if Nkind (N) = N_Incomplete_Type_Declaration then 15507 return Prev; 15508 end if; 15509 15510 -- Case of full declaration of incomplete type 15511 15512 elsif Ekind (Prev) = E_Incomplete_Type 15513 and then (Ada_Version < Ada_2012 15514 or else No (Full_View (Prev)) 15515 or else not Is_Private_Type (Full_View (Prev))) 15516 then 15517 15518 -- Indicate that the incomplete declaration has a matching full 15519 -- declaration. The defining occurrence of the incomplete 15520 -- declaration remains the visible one, and the procedure 15521 -- Get_Full_View dereferences it whenever the type is used. 15522 15523 if Present (Full_View (Prev)) then 15524 Error_Msg_NE ("invalid redeclaration of }", Id, Prev); 15525 end if; 15526 15527 Set_Full_View (Prev, Id); 15528 Append_Entity (Id, Current_Scope); 15529 Set_Is_Public (Id, Is_Public (Prev)); 15530 Set_Is_Internal (Id); 15531 New_Id := Prev; 15532 15533 -- If the incomplete view is tagged, a class_wide type has been 15534 -- created already. Use it for the private type as well, in order 15535 -- to prevent multiple incompatible class-wide types that may be 15536 -- created for self-referential anonymous access components. 15537 15538 if Is_Tagged_Type (Prev) 15539 and then Present (Class_Wide_Type (Prev)) 15540 then 15541 Set_Ekind (Id, Ekind (Prev)); -- will be reset later 15542 Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); 15543 15544 -- If the incomplete type is completed by a private declaration 15545 -- the class-wide type remains associated with the incomplete 15546 -- type, to prevent order-of-elaboration issues in gigi, else 15547 -- we associate the class-wide type with the known full view. 15548 15549 if Nkind (N) /= N_Private_Type_Declaration then 15550 Set_Etype (Class_Wide_Type (Id), Id); 15551 end if; 15552 end if; 15553 15554 -- Case of full declaration of private type 15555 15556 else 15557 -- If the private type was a completion of an incomplete type then 15558 -- update Prev to reference the private type 15559 15560 if Ada_Version >= Ada_2012 15561 and then Ekind (Prev) = E_Incomplete_Type 15562 and then Present (Full_View (Prev)) 15563 and then Is_Private_Type (Full_View (Prev)) 15564 then 15565 Prev := Full_View (Prev); 15566 Prev_Par := Parent (Prev); 15567 end if; 15568 15569 if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then 15570 if Etype (Prev) /= Prev then 15571 15572 -- Prev is a private subtype or a derived type, and needs 15573 -- no completion. 15574 15575 Error_Msg_NE ("invalid redeclaration of }", Id, Prev); 15576 New_Id := Id; 15577 15578 elsif Ekind (Prev) = E_Private_Type 15579 and then Nkind_In (N, N_Task_Type_Declaration, 15580 N_Protected_Type_Declaration) 15581 then 15582 Error_Msg_N 15583 ("completion of nonlimited type cannot be limited", N); 15584 15585 elsif Ekind (Prev) = E_Record_Type_With_Private 15586 and then Nkind_In (N, N_Task_Type_Declaration, 15587 N_Protected_Type_Declaration) 15588 then 15589 if not Is_Limited_Record (Prev) then 15590 Error_Msg_N 15591 ("completion of nonlimited type cannot be limited", N); 15592 15593 elsif No (Interface_List (N)) then 15594 Error_Msg_N 15595 ("completion of tagged private type must be tagged", 15596 N); 15597 end if; 15598 15599 elsif Nkind (N) = N_Full_Type_Declaration 15600 and then 15601 Nkind (Type_Definition (N)) = N_Record_Definition 15602 and then Interface_Present (Type_Definition (N)) 15603 then 15604 Error_Msg_N 15605 ("completion of private type cannot be an interface", N); 15606 end if; 15607 15608 -- Ada 2005 (AI-251): Private extension declaration of a task 15609 -- type or a protected type. This case arises when covering 15610 -- interface types. 15611 15612 elsif Nkind_In (N, N_Task_Type_Declaration, 15613 N_Protected_Type_Declaration) 15614 then 15615 null; 15616 15617 elsif Nkind (N) /= N_Full_Type_Declaration 15618 or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition 15619 then 15620 Error_Msg_N 15621 ("full view of private extension must be an extension", N); 15622 15623 elsif not (Abstract_Present (Parent (Prev))) 15624 and then Abstract_Present (Type_Definition (N)) 15625 then 15626 Error_Msg_N 15627 ("full view of non-abstract extension cannot be abstract", N); 15628 end if; 15629 15630 if not In_Private_Part (Current_Scope) then 15631 Error_Msg_N 15632 ("declaration of full view must appear in private part", N); 15633 end if; 15634 15635 if Ada_Version >= Ada_2012 then 15636 Check_Duplicate_Aspects; 15637 end if; 15638 15639 Copy_And_Swap (Prev, Id); 15640 Set_Has_Private_Declaration (Prev); 15641 Set_Has_Private_Declaration (Id); 15642 15643 -- Preserve aspect and iterator flags that may have been set on 15644 -- the partial view. 15645 15646 Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id)); 15647 Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id)); 15648 15649 -- If no error, propagate freeze_node from private to full view. 15650 -- It may have been generated for an early operational item. 15651 15652 if Present (Freeze_Node (Id)) 15653 and then Serious_Errors_Detected = 0 15654 and then No (Full_View (Id)) 15655 then 15656 Set_Freeze_Node (Prev, Freeze_Node (Id)); 15657 Set_Freeze_Node (Id, Empty); 15658 Set_First_Rep_Item (Prev, First_Rep_Item (Id)); 15659 end if; 15660 15661 Set_Full_View (Id, Prev); 15662 New_Id := Prev; 15663 end if; 15664 15665 -- Verify that full declaration conforms to partial one 15666 15667 if Is_Incomplete_Or_Private_Type (Prev) 15668 and then Present (Discriminant_Specifications (Prev_Par)) 15669 then 15670 if Present (Discriminant_Specifications (N)) then 15671 if Ekind (Prev) = E_Incomplete_Type then 15672 Check_Discriminant_Conformance (N, Prev, Prev); 15673 else 15674 Check_Discriminant_Conformance (N, Prev, Id); 15675 end if; 15676 15677 else 15678 Error_Msg_N 15679 ("missing discriminants in full type declaration", N); 15680 15681 -- To avoid cascaded errors on subsequent use, share the 15682 -- discriminants of the partial view. 15683 15684 Set_Discriminant_Specifications (N, 15685 Discriminant_Specifications (Prev_Par)); 15686 end if; 15687 end if; 15688 15689 -- A prior untagged partial view can have an associated class-wide 15690 -- type due to use of the class attribute, and in this case the full 15691 -- type must also be tagged. This Ada 95 usage is deprecated in favor 15692 -- of incomplete tagged declarations, but we check for it. 15693 15694 if Is_Type (Prev) 15695 and then (Is_Tagged_Type (Prev) 15696 or else Present (Class_Wide_Type (Prev))) 15697 then 15698 -- Ada 2012 (AI05-0162): A private type may be the completion of 15699 -- an incomplete type. 15700 15701 if Ada_Version >= Ada_2012 15702 and then Is_Incomplete_Type (Prev) 15703 and then Nkind_In (N, N_Private_Type_Declaration, 15704 N_Private_Extension_Declaration) 15705 then 15706 -- No need to check private extensions since they are tagged 15707 15708 if Nkind (N) = N_Private_Type_Declaration 15709 and then not Tagged_Present (N) 15710 then 15711 Tag_Mismatch; 15712 end if; 15713 15714 -- The full declaration is either a tagged type (including 15715 -- a synchronized type that implements interfaces) or a 15716 -- type extension, otherwise this is an error. 15717 15718 elsif Nkind_In (N, N_Task_Type_Declaration, 15719 N_Protected_Type_Declaration) 15720 then 15721 if No (Interface_List (N)) 15722 and then not Error_Posted (N) 15723 then 15724 Tag_Mismatch; 15725 end if; 15726 15727 elsif Nkind (Type_Definition (N)) = N_Record_Definition then 15728 15729 -- Indicate that the previous declaration (tagged incomplete 15730 -- or private declaration) requires the same on the full one. 15731 15732 if not Tagged_Present (Type_Definition (N)) then 15733 Tag_Mismatch; 15734 Set_Is_Tagged_Type (Id); 15735 end if; 15736 15737 elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 15738 if No (Record_Extension_Part (Type_Definition (N))) then 15739 Error_Msg_NE 15740 ("full declaration of } must be a record extension", 15741 Prev, Id); 15742 15743 -- Set some attributes to produce a usable full view 15744 15745 Set_Is_Tagged_Type (Id); 15746 end if; 15747 15748 else 15749 Tag_Mismatch; 15750 end if; 15751 end if; 15752 15753 if Present (Prev) 15754 and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration 15755 and then Present (Premature_Use (Parent (Prev))) 15756 then 15757 Error_Msg_Sloc := Sloc (N); 15758 Error_Msg_N 15759 ("\full declaration #", Premature_Use (Parent (Prev))); 15760 end if; 15761 15762 return New_Id; 15763 end if; 15764 end Find_Type_Name; 15765 15766 ------------------------- 15767 -- Find_Type_Of_Object -- 15768 ------------------------- 15769 15770 function Find_Type_Of_Object 15771 (Obj_Def : Node_Id; 15772 Related_Nod : Node_Id) return Entity_Id 15773 is 15774 Def_Kind : constant Node_Kind := Nkind (Obj_Def); 15775 P : Node_Id := Parent (Obj_Def); 15776 T : Entity_Id; 15777 Nam : Name_Id; 15778 15779 begin 15780 -- If the parent is a component_definition node we climb to the 15781 -- component_declaration node 15782 15783 if Nkind (P) = N_Component_Definition then 15784 P := Parent (P); 15785 end if; 15786 15787 -- Case of an anonymous array subtype 15788 15789 if Nkind_In (Def_Kind, N_Constrained_Array_Definition, 15790 N_Unconstrained_Array_Definition) 15791 then 15792 T := Empty; 15793 Array_Type_Declaration (T, Obj_Def); 15794 15795 -- Create an explicit subtype whenever possible 15796 15797 elsif Nkind (P) /= N_Component_Declaration 15798 and then Def_Kind = N_Subtype_Indication 15799 then 15800 -- Base name of subtype on object name, which will be unique in 15801 -- the current scope. 15802 15803 -- If this is a duplicate declaration, return base type, to avoid 15804 -- generating duplicate anonymous types. 15805 15806 if Error_Posted (P) then 15807 Analyze (Subtype_Mark (Obj_Def)); 15808 return Entity (Subtype_Mark (Obj_Def)); 15809 end if; 15810 15811 Nam := 15812 New_External_Name 15813 (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T'); 15814 15815 T := Make_Defining_Identifier (Sloc (P), Nam); 15816 15817 Insert_Action (Obj_Def, 15818 Make_Subtype_Declaration (Sloc (P), 15819 Defining_Identifier => T, 15820 Subtype_Indication => Relocate_Node (Obj_Def))); 15821 15822 -- This subtype may need freezing, and this will not be done 15823 -- automatically if the object declaration is not in declarative 15824 -- part. Since this is an object declaration, the type cannot always 15825 -- be frozen here. Deferred constants do not freeze their type 15826 -- (which often enough will be private). 15827 15828 if Nkind (P) = N_Object_Declaration 15829 and then Constant_Present (P) 15830 and then No (Expression (P)) 15831 then 15832 null; 15833 15834 -- Here we freeze the base type of object type to catch premature use 15835 -- of discriminated private type without a full view. 15836 15837 else 15838 Insert_Actions (Obj_Def, Freeze_Entity (Base_Type (T), P)); 15839 end if; 15840 15841 -- Ada 2005 AI-406: the object definition in an object declaration 15842 -- can be an access definition. 15843 15844 elsif Def_Kind = N_Access_Definition then 15845 T := Access_Definition (Related_Nod, Obj_Def); 15846 15847 Set_Is_Local_Anonymous_Access 15848 (T, 15849 V => (Ada_Version < Ada_2012) 15850 or else (Nkind (P) /= N_Object_Declaration) 15851 or else Is_Library_Level_Entity (Defining_Identifier (P))); 15852 15853 -- Otherwise, the object definition is just a subtype_mark 15854 15855 else 15856 T := Process_Subtype (Obj_Def, Related_Nod); 15857 15858 -- If expansion is disabled an object definition that is an aggregate 15859 -- will not get expanded and may lead to scoping problems in the back 15860 -- end, if the object is referenced in an inner scope. In that case 15861 -- create an itype reference for the object definition now. This 15862 -- may be redundant in some cases, but harmless. 15863 15864 if Is_Itype (T) 15865 and then Nkind (Related_Nod) = N_Object_Declaration 15866 and then ASIS_Mode 15867 then 15868 Build_Itype_Reference (T, Related_Nod); 15869 end if; 15870 end if; 15871 15872 return T; 15873 end Find_Type_Of_Object; 15874 15875 -------------------------------- 15876 -- Find_Type_Of_Subtype_Indic -- 15877 -------------------------------- 15878 15879 function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is 15880 Typ : Entity_Id; 15881 15882 begin 15883 -- Case of subtype mark with a constraint 15884 15885 if Nkind (S) = N_Subtype_Indication then 15886 Find_Type (Subtype_Mark (S)); 15887 Typ := Entity (Subtype_Mark (S)); 15888 15889 if not 15890 Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S))) 15891 then 15892 Error_Msg_N 15893 ("incorrect constraint for this kind of type", Constraint (S)); 15894 Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); 15895 end if; 15896 15897 -- Otherwise we have a subtype mark without a constraint 15898 15899 elsif Error_Posted (S) then 15900 Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S))); 15901 return Any_Type; 15902 15903 else 15904 Find_Type (S); 15905 Typ := Entity (S); 15906 end if; 15907 15908 -- Check No_Wide_Characters restriction 15909 15910 Check_Wide_Character_Restriction (Typ, S); 15911 15912 return Typ; 15913 end Find_Type_Of_Subtype_Indic; 15914 15915 ------------------------------------- 15916 -- Floating_Point_Type_Declaration -- 15917 ------------------------------------- 15918 15919 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is 15920 Digs : constant Node_Id := Digits_Expression (Def); 15921 Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float); 15922 Digs_Val : Uint; 15923 Base_Typ : Entity_Id; 15924 Implicit_Base : Entity_Id; 15925 Bound : Node_Id; 15926 15927 function Can_Derive_From (E : Entity_Id) return Boolean; 15928 -- Find if given digits value, and possibly a specified range, allows 15929 -- derivation from specified type 15930 15931 function Find_Base_Type return Entity_Id; 15932 -- Find a predefined base type that Def can derive from, or generate 15933 -- an error and substitute Long_Long_Float if none exists. 15934 15935 --------------------- 15936 -- Can_Derive_From -- 15937 --------------------- 15938 15939 function Can_Derive_From (E : Entity_Id) return Boolean is 15940 Spec : constant Entity_Id := Real_Range_Specification (Def); 15941 15942 begin 15943 -- Check specified "digits" constraint 15944 15945 if Digs_Val > Digits_Value (E) then 15946 return False; 15947 end if; 15948 15949 -- Avoid types not matching pragma Float_Representation, if present 15950 15951 if (Opt.Float_Format = 'I' and then Float_Rep (E) /= IEEE_Binary) 15952 or else 15953 (Opt.Float_Format = 'V' and then Float_Rep (E) /= VAX_Native) 15954 then 15955 return False; 15956 end if; 15957 15958 -- Check for matching range, if specified 15959 15960 if Present (Spec) then 15961 if Expr_Value_R (Type_Low_Bound (E)) > 15962 Expr_Value_R (Low_Bound (Spec)) 15963 then 15964 return False; 15965 end if; 15966 15967 if Expr_Value_R (Type_High_Bound (E)) < 15968 Expr_Value_R (High_Bound (Spec)) 15969 then 15970 return False; 15971 end if; 15972 end if; 15973 15974 return True; 15975 end Can_Derive_From; 15976 15977 -------------------- 15978 -- Find_Base_Type -- 15979 -------------------- 15980 15981 function Find_Base_Type return Entity_Id is 15982 Choice : Elmt_Id := First_Elmt (Predefined_Float_Types); 15983 15984 begin 15985 -- Iterate over the predefined types in order, returning the first 15986 -- one that Def can derive from. 15987 15988 while Present (Choice) loop 15989 if Can_Derive_From (Node (Choice)) then 15990 return Node (Choice); 15991 end if; 15992 15993 Next_Elmt (Choice); 15994 end loop; 15995 15996 -- If we can't derive from any existing type, use Long_Long_Float 15997 -- and give appropriate message explaining the problem. 15998 15999 if Digs_Val > Max_Digs_Val then 16000 -- It might be the case that there is a type with the requested 16001 -- range, just not the combination of digits and range. 16002 16003 Error_Msg_N 16004 ("no predefined type has requested range and precision", 16005 Real_Range_Specification (Def)); 16006 16007 else 16008 Error_Msg_N 16009 ("range too large for any predefined type", 16010 Real_Range_Specification (Def)); 16011 end if; 16012 16013 return Standard_Long_Long_Float; 16014 end Find_Base_Type; 16015 16016 -- Start of processing for Floating_Point_Type_Declaration 16017 16018 begin 16019 Check_Restriction (No_Floating_Point, Def); 16020 16021 -- Create an implicit base type 16022 16023 Implicit_Base := 16024 Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B'); 16025 16026 -- Analyze and verify digits value 16027 16028 Analyze_And_Resolve (Digs, Any_Integer); 16029 Check_Digits_Expression (Digs); 16030 Digs_Val := Expr_Value (Digs); 16031 16032 -- Process possible range spec and find correct type to derive from 16033 16034 Process_Real_Range_Specification (Def); 16035 16036 -- Check that requested number of digits is not too high. 16037 16038 if Digs_Val > Max_Digs_Val then 16039 -- The check for Max_Base_Digits may be somewhat expensive, as it 16040 -- requires reading System, so only do it when necessary. 16041 16042 declare 16043 Max_Base_Digits : constant Uint := 16044 Expr_Value 16045 (Expression 16046 (Parent (RTE (RE_Max_Base_Digits)))); 16047 16048 begin 16049 if Digs_Val > Max_Base_Digits then 16050 Error_Msg_Uint_1 := Max_Base_Digits; 16051 Error_Msg_N ("digits value out of range, maximum is ^", Digs); 16052 16053 elsif No (Real_Range_Specification (Def)) then 16054 Error_Msg_Uint_1 := Max_Digs_Val; 16055 Error_Msg_N ("types with more than ^ digits need range spec " 16056 & "(RM 3.5.7(6))", Digs); 16057 end if; 16058 end; 16059 end if; 16060 16061 -- Find a suitable type to derive from or complain and use a substitute 16062 16063 Base_Typ := Find_Base_Type; 16064 16065 -- If there are bounds given in the declaration use them as the bounds 16066 -- of the type, otherwise use the bounds of the predefined base type 16067 -- that was chosen based on the Digits value. 16068 16069 if Present (Real_Range_Specification (Def)) then 16070 Set_Scalar_Range (T, Real_Range_Specification (Def)); 16071 Set_Is_Constrained (T); 16072 16073 -- The bounds of this range must be converted to machine numbers 16074 -- in accordance with RM 4.9(38). 16075 16076 Bound := Type_Low_Bound (T); 16077 16078 if Nkind (Bound) = N_Real_Literal then 16079 Set_Realval 16080 (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); 16081 Set_Is_Machine_Number (Bound); 16082 end if; 16083 16084 Bound := Type_High_Bound (T); 16085 16086 if Nkind (Bound) = N_Real_Literal then 16087 Set_Realval 16088 (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); 16089 Set_Is_Machine_Number (Bound); 16090 end if; 16091 16092 else 16093 Set_Scalar_Range (T, Scalar_Range (Base_Typ)); 16094 end if; 16095 16096 -- Complete definition of implicit base and declared first subtype 16097 16098 Set_Etype (Implicit_Base, Base_Typ); 16099 16100 Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); 16101 Set_Size_Info (Implicit_Base, (Base_Typ)); 16102 Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); 16103 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); 16104 Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); 16105 Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); 16106 16107 Set_Ekind (T, E_Floating_Point_Subtype); 16108 Set_Etype (T, Implicit_Base); 16109 16110 Set_Size_Info (T, (Implicit_Base)); 16111 Set_RM_Size (T, RM_Size (Implicit_Base)); 16112 Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); 16113 Set_Digits_Value (T, Digs_Val); 16114 end Floating_Point_Type_Declaration; 16115 16116 ---------------------------- 16117 -- Get_Discriminant_Value -- 16118 ---------------------------- 16119 16120 -- This is the situation: 16121 16122 -- There is a non-derived type 16123 16124 -- type T0 (Dx, Dy, Dz...) 16125 16126 -- There are zero or more levels of derivation, with each derivation 16127 -- either purely inheriting the discriminants, or defining its own. 16128 16129 -- type Ti is new Ti-1 16130 -- or 16131 -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y) 16132 -- or 16133 -- subtype Ti is ... 16134 16135 -- The subtype issue is avoided by the use of Original_Record_Component, 16136 -- and the fact that derived subtypes also derive the constraints. 16137 16138 -- This chain leads back from 16139 16140 -- Typ_For_Constraint 16141 16142 -- Typ_For_Constraint has discriminants, and the value for each 16143 -- discriminant is given by its corresponding Elmt of Constraints. 16144 16145 -- Discriminant is some discriminant in this hierarchy 16146 16147 -- We need to return its value 16148 16149 -- We do this by recursively searching each level, and looking for 16150 -- Discriminant. Once we get to the bottom, we start backing up 16151 -- returning the value for it which may in turn be a discriminant 16152 -- further up, so on the backup we continue the substitution. 16153 16154 function Get_Discriminant_Value 16155 (Discriminant : Entity_Id; 16156 Typ_For_Constraint : Entity_Id; 16157 Constraint : Elist_Id) return Node_Id 16158 is 16159 function Root_Corresponding_Discriminant 16160 (Discr : Entity_Id) return Entity_Id; 16161 -- Given a discriminant, traverse the chain of inherited discriminants 16162 -- and return the topmost discriminant. 16163 16164 function Search_Derivation_Levels 16165 (Ti : Entity_Id; 16166 Discrim_Values : Elist_Id; 16167 Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id; 16168 -- This is the routine that performs the recursive search of levels 16169 -- as described above. 16170 16171 ------------------------------------- 16172 -- Root_Corresponding_Discriminant -- 16173 ------------------------------------- 16174 16175 function Root_Corresponding_Discriminant 16176 (Discr : Entity_Id) return Entity_Id 16177 is 16178 D : Entity_Id; 16179 16180 begin 16181 D := Discr; 16182 while Present (Corresponding_Discriminant (D)) loop 16183 D := Corresponding_Discriminant (D); 16184 end loop; 16185 16186 return D; 16187 end Root_Corresponding_Discriminant; 16188 16189 ------------------------------ 16190 -- Search_Derivation_Levels -- 16191 ------------------------------ 16192 16193 function Search_Derivation_Levels 16194 (Ti : Entity_Id; 16195 Discrim_Values : Elist_Id; 16196 Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id 16197 is 16198 Assoc : Elmt_Id; 16199 Disc : Entity_Id; 16200 Result : Node_Or_Entity_Id; 16201 Result_Entity : Node_Id; 16202 16203 begin 16204 -- If inappropriate type, return Error, this happens only in 16205 -- cascaded error situations, and we want to avoid a blow up. 16206 16207 if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then 16208 return Error; 16209 end if; 16210 16211 -- Look deeper if possible. Use Stored_Constraints only for 16212 -- untagged types. For tagged types use the given constraint. 16213 -- This asymmetry needs explanation??? 16214 16215 if not Stored_Discrim_Values 16216 and then Present (Stored_Constraint (Ti)) 16217 and then not Is_Tagged_Type (Ti) 16218 then 16219 Result := 16220 Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True); 16221 else 16222 declare 16223 Td : constant Entity_Id := Etype (Ti); 16224 16225 begin 16226 if Td = Ti then 16227 Result := Discriminant; 16228 16229 else 16230 if Present (Stored_Constraint (Ti)) then 16231 Result := 16232 Search_Derivation_Levels 16233 (Td, Stored_Constraint (Ti), True); 16234 else 16235 Result := 16236 Search_Derivation_Levels 16237 (Td, Discrim_Values, Stored_Discrim_Values); 16238 end if; 16239 end if; 16240 end; 16241 end if; 16242 16243 -- Extra underlying places to search, if not found above. For 16244 -- concurrent types, the relevant discriminant appears in the 16245 -- corresponding record. For a type derived from a private type 16246 -- without discriminant, the full view inherits the discriminants 16247 -- of the full view of the parent. 16248 16249 if Result = Discriminant then 16250 if Is_Concurrent_Type (Ti) 16251 and then Present (Corresponding_Record_Type (Ti)) 16252 then 16253 Result := 16254 Search_Derivation_Levels ( 16255 Corresponding_Record_Type (Ti), 16256 Discrim_Values, 16257 Stored_Discrim_Values); 16258 16259 elsif Is_Private_Type (Ti) 16260 and then not Has_Discriminants (Ti) 16261 and then Present (Full_View (Ti)) 16262 and then Etype (Full_View (Ti)) /= Ti 16263 then 16264 Result := 16265 Search_Derivation_Levels ( 16266 Full_View (Ti), 16267 Discrim_Values, 16268 Stored_Discrim_Values); 16269 end if; 16270 end if; 16271 16272 -- If Result is not a (reference to a) discriminant, return it, 16273 -- otherwise set Result_Entity to the discriminant. 16274 16275 if Nkind (Result) = N_Defining_Identifier then 16276 pragma Assert (Result = Discriminant); 16277 Result_Entity := Result; 16278 16279 else 16280 if not Denotes_Discriminant (Result) then 16281 return Result; 16282 end if; 16283 16284 Result_Entity := Entity (Result); 16285 end if; 16286 16287 -- See if this level of derivation actually has discriminants 16288 -- because tagged derivations can add them, hence the lower 16289 -- levels need not have any. 16290 16291 if not Has_Discriminants (Ti) then 16292 return Result; 16293 end if; 16294 16295 -- Scan Ti's discriminants for Result_Entity, 16296 -- and return its corresponding value, if any. 16297 16298 Result_Entity := Original_Record_Component (Result_Entity); 16299 16300 Assoc := First_Elmt (Discrim_Values); 16301 16302 if Stored_Discrim_Values then 16303 Disc := First_Stored_Discriminant (Ti); 16304 else 16305 Disc := First_Discriminant (Ti); 16306 end if; 16307 16308 while Present (Disc) loop 16309 pragma Assert (Present (Assoc)); 16310 16311 if Original_Record_Component (Disc) = Result_Entity then 16312 return Node (Assoc); 16313 end if; 16314 16315 Next_Elmt (Assoc); 16316 16317 if Stored_Discrim_Values then 16318 Next_Stored_Discriminant (Disc); 16319 else 16320 Next_Discriminant (Disc); 16321 end if; 16322 end loop; 16323 16324 -- Could not find it 16325 -- 16326 return Result; 16327 end Search_Derivation_Levels; 16328 16329 -- Local Variables 16330 16331 Result : Node_Or_Entity_Id; 16332 16333 -- Start of processing for Get_Discriminant_Value 16334 16335 begin 16336 -- ??? This routine is a gigantic mess and will be deleted. For the 16337 -- time being just test for the trivial case before calling recurse. 16338 16339 if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then 16340 declare 16341 D : Entity_Id; 16342 E : Elmt_Id; 16343 16344 begin 16345 D := First_Discriminant (Typ_For_Constraint); 16346 E := First_Elmt (Constraint); 16347 while Present (D) loop 16348 if Chars (D) = Chars (Discriminant) then 16349 return Node (E); 16350 end if; 16351 16352 Next_Discriminant (D); 16353 Next_Elmt (E); 16354 end loop; 16355 end; 16356 end if; 16357 16358 Result := Search_Derivation_Levels 16359 (Typ_For_Constraint, Constraint, False); 16360 16361 -- ??? hack to disappear when this routine is gone 16362 16363 if Nkind (Result) = N_Defining_Identifier then 16364 declare 16365 D : Entity_Id; 16366 E : Elmt_Id; 16367 16368 begin 16369 D := First_Discriminant (Typ_For_Constraint); 16370 E := First_Elmt (Constraint); 16371 while Present (D) loop 16372 if Root_Corresponding_Discriminant (D) = Discriminant then 16373 return Node (E); 16374 end if; 16375 16376 Next_Discriminant (D); 16377 Next_Elmt (E); 16378 end loop; 16379 end; 16380 end if; 16381 16382 pragma Assert (Nkind (Result) /= N_Defining_Identifier); 16383 return Result; 16384 end Get_Discriminant_Value; 16385 16386 -------------------------- 16387 -- Has_Range_Constraint -- 16388 -------------------------- 16389 16390 function Has_Range_Constraint (N : Node_Id) return Boolean is 16391 C : constant Node_Id := Constraint (N); 16392 16393 begin 16394 if Nkind (C) = N_Range_Constraint then 16395 return True; 16396 16397 elsif Nkind (C) = N_Digits_Constraint then 16398 return 16399 Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N))) 16400 or else 16401 Present (Range_Constraint (C)); 16402 16403 elsif Nkind (C) = N_Delta_Constraint then 16404 return Present (Range_Constraint (C)); 16405 16406 else 16407 return False; 16408 end if; 16409 end Has_Range_Constraint; 16410 16411 ------------------------ 16412 -- Inherit_Components -- 16413 ------------------------ 16414 16415 function Inherit_Components 16416 (N : Node_Id; 16417 Parent_Base : Entity_Id; 16418 Derived_Base : Entity_Id; 16419 Is_Tagged : Boolean; 16420 Inherit_Discr : Boolean; 16421 Discs : Elist_Id) return Elist_Id 16422 is 16423 Assoc_List : constant Elist_Id := New_Elmt_List; 16424 16425 procedure Inherit_Component 16426 (Old_C : Entity_Id; 16427 Plain_Discrim : Boolean := False; 16428 Stored_Discrim : Boolean := False); 16429 -- Inherits component Old_C from Parent_Base to the Derived_Base. If 16430 -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is 16431 -- True, Old_C is a stored discriminant. If they are both false then 16432 -- Old_C is a regular component. 16433 16434 ----------------------- 16435 -- Inherit_Component -- 16436 ----------------------- 16437 16438 procedure Inherit_Component 16439 (Old_C : Entity_Id; 16440 Plain_Discrim : Boolean := False; 16441 Stored_Discrim : Boolean := False) 16442 is 16443 procedure Set_Anonymous_Type (Id : Entity_Id); 16444 -- Id denotes the entity of an access discriminant or anonymous 16445 -- access component. Set the type of Id to either the same type of 16446 -- Old_C or create a new one depending on whether the parent and 16447 -- the child types are in the same scope. 16448 16449 ------------------------ 16450 -- Set_Anonymous_Type -- 16451 ------------------------ 16452 16453 procedure Set_Anonymous_Type (Id : Entity_Id) is 16454 Old_Typ : constant Entity_Id := Etype (Old_C); 16455 16456 begin 16457 if Scope (Parent_Base) = Scope (Derived_Base) then 16458 Set_Etype (Id, Old_Typ); 16459 16460 -- The parent and the derived type are in two different scopes. 16461 -- Reuse the type of the original discriminant / component by 16462 -- copying it in order to preserve all attributes. 16463 16464 else 16465 declare 16466 Typ : constant Entity_Id := New_Copy (Old_Typ); 16467 16468 begin 16469 Set_Etype (Id, Typ); 16470 16471 -- Since we do not generate component declarations for 16472 -- inherited components, associate the itype with the 16473 -- derived type. 16474 16475 Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base)); 16476 Set_Scope (Typ, Derived_Base); 16477 end; 16478 end if; 16479 end Set_Anonymous_Type; 16480 16481 -- Local variables and constants 16482 16483 New_C : constant Entity_Id := New_Copy (Old_C); 16484 16485 Corr_Discrim : Entity_Id; 16486 Discrim : Entity_Id; 16487 16488 -- Start of processing for Inherit_Component 16489 16490 begin 16491 pragma Assert (not Is_Tagged or else not Stored_Discrim); 16492 16493 Set_Parent (New_C, Parent (Old_C)); 16494 16495 -- Regular discriminants and components must be inserted in the scope 16496 -- of the Derived_Base. Do it here. 16497 16498 if not Stored_Discrim then 16499 Enter_Name (New_C); 16500 end if; 16501 16502 -- For tagged types the Original_Record_Component must point to 16503 -- whatever this field was pointing to in the parent type. This has 16504 -- already been achieved by the call to New_Copy above. 16505 16506 if not Is_Tagged then 16507 Set_Original_Record_Component (New_C, New_C); 16508 end if; 16509 16510 -- Set the proper type of an access discriminant 16511 16512 if Ekind (New_C) = E_Discriminant 16513 and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type 16514 then 16515 Set_Anonymous_Type (New_C); 16516 end if; 16517 16518 -- If we have inherited a component then see if its Etype contains 16519 -- references to Parent_Base discriminants. In this case, replace 16520 -- these references with the constraints given in Discs. We do not 16521 -- do this for the partial view of private types because this is 16522 -- not needed (only the components of the full view will be used 16523 -- for code generation) and cause problem. We also avoid this 16524 -- transformation in some error situations. 16525 16526 if Ekind (New_C) = E_Component then 16527 16528 -- Set the proper type of an anonymous access component 16529 16530 if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then 16531 Set_Anonymous_Type (New_C); 16532 16533 elsif (Is_Private_Type (Derived_Base) 16534 and then not Is_Generic_Type (Derived_Base)) 16535 or else (Is_Empty_Elmt_List (Discs) 16536 and then not Expander_Active) 16537 then 16538 Set_Etype (New_C, Etype (Old_C)); 16539 16540 else 16541 -- The current component introduces a circularity of the 16542 -- following kind: 16543 16544 -- limited with Pack_2; 16545 -- package Pack_1 is 16546 -- type T_1 is tagged record 16547 -- Comp : access Pack_2.T_2; 16548 -- ... 16549 -- end record; 16550 -- end Pack_1; 16551 16552 -- with Pack_1; 16553 -- package Pack_2 is 16554 -- type T_2 is new Pack_1.T_1 with ...; 16555 -- end Pack_2; 16556 16557 Set_Etype 16558 (New_C, 16559 Constrain_Component_Type 16560 (Old_C, Derived_Base, N, Parent_Base, Discs)); 16561 end if; 16562 end if; 16563 16564 -- In derived tagged types it is illegal to reference a non 16565 -- discriminant component in the parent type. To catch this, mark 16566 -- these components with an Ekind of E_Void. This will be reset in 16567 -- Record_Type_Definition after processing the record extension of 16568 -- the derived type. 16569 16570 -- If the declaration is a private extension, there is no further 16571 -- record extension to process, and the components retain their 16572 -- current kind, because they are visible at this point. 16573 16574 if Is_Tagged and then Ekind (New_C) = E_Component 16575 and then Nkind (N) /= N_Private_Extension_Declaration 16576 then 16577 Set_Ekind (New_C, E_Void); 16578 end if; 16579 16580 if Plain_Discrim then 16581 Set_Corresponding_Discriminant (New_C, Old_C); 16582 Build_Discriminal (New_C); 16583 16584 -- If we are explicitly inheriting a stored discriminant it will be 16585 -- completely hidden. 16586 16587 elsif Stored_Discrim then 16588 Set_Corresponding_Discriminant (New_C, Empty); 16589 Set_Discriminal (New_C, Empty); 16590 Set_Is_Completely_Hidden (New_C); 16591 16592 -- Set the Original_Record_Component of each discriminant in the 16593 -- derived base to point to the corresponding stored that we just 16594 -- created. 16595 16596 Discrim := First_Discriminant (Derived_Base); 16597 while Present (Discrim) loop 16598 Corr_Discrim := Corresponding_Discriminant (Discrim); 16599 16600 -- Corr_Discrim could be missing in an error situation 16601 16602 if Present (Corr_Discrim) 16603 and then Original_Record_Component (Corr_Discrim) = Old_C 16604 then 16605 Set_Original_Record_Component (Discrim, New_C); 16606 end if; 16607 16608 Next_Discriminant (Discrim); 16609 end loop; 16610 16611 Append_Entity (New_C, Derived_Base); 16612 end if; 16613 16614 if not Is_Tagged then 16615 Append_Elmt (Old_C, Assoc_List); 16616 Append_Elmt (New_C, Assoc_List); 16617 end if; 16618 end Inherit_Component; 16619 16620 -- Variables local to Inherit_Component 16621 16622 Loc : constant Source_Ptr := Sloc (N); 16623 16624 Parent_Discrim : Entity_Id; 16625 Stored_Discrim : Entity_Id; 16626 D : Entity_Id; 16627 Component : Entity_Id; 16628 16629 -- Start of processing for Inherit_Components 16630 16631 begin 16632 if not Is_Tagged then 16633 Append_Elmt (Parent_Base, Assoc_List); 16634 Append_Elmt (Derived_Base, Assoc_List); 16635 end if; 16636 16637 -- Inherit parent discriminants if needed 16638 16639 if Inherit_Discr then 16640 Parent_Discrim := First_Discriminant (Parent_Base); 16641 while Present (Parent_Discrim) loop 16642 Inherit_Component (Parent_Discrim, Plain_Discrim => True); 16643 Next_Discriminant (Parent_Discrim); 16644 end loop; 16645 end if; 16646 16647 -- Create explicit stored discrims for untagged types when necessary 16648 16649 if not Has_Unknown_Discriminants (Derived_Base) 16650 and then Has_Discriminants (Parent_Base) 16651 and then not Is_Tagged 16652 and then 16653 (not Inherit_Discr 16654 or else First_Discriminant (Parent_Base) /= 16655 First_Stored_Discriminant (Parent_Base)) 16656 then 16657 Stored_Discrim := First_Stored_Discriminant (Parent_Base); 16658 while Present (Stored_Discrim) loop 16659 Inherit_Component (Stored_Discrim, Stored_Discrim => True); 16660 Next_Stored_Discriminant (Stored_Discrim); 16661 end loop; 16662 end if; 16663 16664 -- See if we can apply the second transformation for derived types, as 16665 -- explained in point 6. in the comments above Build_Derived_Record_Type 16666 -- This is achieved by appending Derived_Base discriminants into Discs, 16667 -- which has the side effect of returning a non empty Discs list to the 16668 -- caller of Inherit_Components, which is what we want. This must be 16669 -- done for private derived types if there are explicit stored 16670 -- discriminants, to ensure that we can retrieve the values of the 16671 -- constraints provided in the ancestors. 16672 16673 if Inherit_Discr 16674 and then Is_Empty_Elmt_List (Discs) 16675 and then Present (First_Discriminant (Derived_Base)) 16676 and then 16677 (not Is_Private_Type (Derived_Base) 16678 or else Is_Completely_Hidden 16679 (First_Stored_Discriminant (Derived_Base)) 16680 or else Is_Generic_Type (Derived_Base)) 16681 then 16682 D := First_Discriminant (Derived_Base); 16683 while Present (D) loop 16684 Append_Elmt (New_Occurrence_Of (D, Loc), Discs); 16685 Next_Discriminant (D); 16686 end loop; 16687 end if; 16688 16689 -- Finally, inherit non-discriminant components unless they are not 16690 -- visible because defined or inherited from the full view of the 16691 -- parent. Don't inherit the _parent field of the parent type. 16692 16693 Component := First_Entity (Parent_Base); 16694 while Present (Component) loop 16695 16696 -- Ada 2005 (AI-251): Do not inherit components associated with 16697 -- secondary tags of the parent. 16698 16699 if Ekind (Component) = E_Component 16700 and then Present (Related_Type (Component)) 16701 then 16702 null; 16703 16704 elsif Ekind (Component) /= E_Component 16705 or else Chars (Component) = Name_uParent 16706 then 16707 null; 16708 16709 -- If the derived type is within the parent type's declarative 16710 -- region, then the components can still be inherited even though 16711 -- they aren't visible at this point. This can occur for cases 16712 -- such as within public child units where the components must 16713 -- become visible upon entering the child unit's private part. 16714 16715 elsif not Is_Visible_Component (Component) 16716 and then not In_Open_Scopes (Scope (Parent_Base)) 16717 then 16718 null; 16719 16720 elsif Ekind_In (Derived_Base, E_Private_Type, 16721 E_Limited_Private_Type) 16722 then 16723 null; 16724 16725 else 16726 Inherit_Component (Component); 16727 end if; 16728 16729 Next_Entity (Component); 16730 end loop; 16731 16732 -- For tagged derived types, inherited discriminants cannot be used in 16733 -- component declarations of the record extension part. To achieve this 16734 -- we mark the inherited discriminants as not visible. 16735 16736 if Is_Tagged and then Inherit_Discr then 16737 D := First_Discriminant (Derived_Base); 16738 while Present (D) loop 16739 Set_Is_Immediately_Visible (D, False); 16740 Next_Discriminant (D); 16741 end loop; 16742 end if; 16743 16744 return Assoc_List; 16745 end Inherit_Components; 16746 16747 ----------------------- 16748 -- Is_Null_Extension -- 16749 ----------------------- 16750 16751 function Is_Null_Extension (T : Entity_Id) return Boolean is 16752 Type_Decl : constant Node_Id := Parent (Base_Type (T)); 16753 Comp_List : Node_Id; 16754 Comp : Node_Id; 16755 16756 begin 16757 if Nkind (Type_Decl) /= N_Full_Type_Declaration 16758 or else not Is_Tagged_Type (T) 16759 or else Nkind (Type_Definition (Type_Decl)) /= 16760 N_Derived_Type_Definition 16761 or else No (Record_Extension_Part (Type_Definition (Type_Decl))) 16762 then 16763 return False; 16764 end if; 16765 16766 Comp_List := 16767 Component_List (Record_Extension_Part (Type_Definition (Type_Decl))); 16768 16769 if Present (Discriminant_Specifications (Type_Decl)) then 16770 return False; 16771 16772 elsif Present (Comp_List) 16773 and then Is_Non_Empty_List (Component_Items (Comp_List)) 16774 then 16775 Comp := First (Component_Items (Comp_List)); 16776 16777 -- Only user-defined components are relevant. The component list 16778 -- may also contain a parent component and internal components 16779 -- corresponding to secondary tags, but these do not determine 16780 -- whether this is a null extension. 16781 16782 while Present (Comp) loop 16783 if Comes_From_Source (Comp) then 16784 return False; 16785 end if; 16786 16787 Next (Comp); 16788 end loop; 16789 16790 return True; 16791 else 16792 return True; 16793 end if; 16794 end Is_Null_Extension; 16795 16796 ------------------------------ 16797 -- Is_Valid_Constraint_Kind -- 16798 ------------------------------ 16799 16800 function Is_Valid_Constraint_Kind 16801 (T_Kind : Type_Kind; 16802 Constraint_Kind : Node_Kind) return Boolean 16803 is 16804 begin 16805 case T_Kind is 16806 when Enumeration_Kind | 16807 Integer_Kind => 16808 return Constraint_Kind = N_Range_Constraint; 16809 16810 when Decimal_Fixed_Point_Kind => 16811 return Nkind_In (Constraint_Kind, N_Digits_Constraint, 16812 N_Range_Constraint); 16813 16814 when Ordinary_Fixed_Point_Kind => 16815 return Nkind_In (Constraint_Kind, N_Delta_Constraint, 16816 N_Range_Constraint); 16817 16818 when Float_Kind => 16819 return Nkind_In (Constraint_Kind, N_Digits_Constraint, 16820 N_Range_Constraint); 16821 16822 when Access_Kind | 16823 Array_Kind | 16824 E_Record_Type | 16825 E_Record_Subtype | 16826 Class_Wide_Kind | 16827 E_Incomplete_Type | 16828 Private_Kind | 16829 Concurrent_Kind => 16830 return Constraint_Kind = N_Index_Or_Discriminant_Constraint; 16831 16832 when others => 16833 return True; -- Error will be detected later 16834 end case; 16835 end Is_Valid_Constraint_Kind; 16836 16837 -------------------------- 16838 -- Is_Visible_Component -- 16839 -------------------------- 16840 16841 function Is_Visible_Component 16842 (C : Entity_Id; 16843 N : Node_Id := Empty) return Boolean 16844 is 16845 Original_Comp : Entity_Id := Empty; 16846 Original_Scope : Entity_Id; 16847 Type_Scope : Entity_Id; 16848 16849 function Is_Local_Type (Typ : Entity_Id) return Boolean; 16850 -- Check whether parent type of inherited component is declared locally, 16851 -- possibly within a nested package or instance. The current scope is 16852 -- the derived record itself. 16853 16854 ------------------- 16855 -- Is_Local_Type -- 16856 ------------------- 16857 16858 function Is_Local_Type (Typ : Entity_Id) return Boolean is 16859 Scop : Entity_Id; 16860 16861 begin 16862 Scop := Scope (Typ); 16863 while Present (Scop) 16864 and then Scop /= Standard_Standard 16865 loop 16866 if Scop = Scope (Current_Scope) then 16867 return True; 16868 end if; 16869 16870 Scop := Scope (Scop); 16871 end loop; 16872 16873 return False; 16874 end Is_Local_Type; 16875 16876 -- Start of processing for Is_Visible_Component 16877 16878 begin 16879 if Ekind_In (C, E_Component, E_Discriminant) then 16880 Original_Comp := Original_Record_Component (C); 16881 end if; 16882 16883 if No (Original_Comp) then 16884 16885 -- Premature usage, or previous error 16886 16887 return False; 16888 16889 else 16890 Original_Scope := Scope (Original_Comp); 16891 Type_Scope := Scope (Base_Type (Scope (C))); 16892 end if; 16893 16894 -- For an untagged type derived from a private type, the only visible 16895 -- components are new discriminants. In an instance all components are 16896 -- visible (see Analyze_Selected_Component). 16897 16898 if not Is_Tagged_Type (Original_Scope) then 16899 return not Has_Private_Ancestor (Original_Scope) 16900 or else In_Open_Scopes (Scope (Original_Scope)) 16901 or else In_Instance 16902 or else (Ekind (Original_Comp) = E_Discriminant 16903 and then Original_Scope = Type_Scope); 16904 16905 -- If it is _Parent or _Tag, there is no visibility issue 16906 16907 elsif not Comes_From_Source (Original_Comp) then 16908 return True; 16909 16910 -- Discriminants are visible unless the (private) type has unknown 16911 -- discriminants. If the discriminant reference is inserted for a 16912 -- discriminant check on a full view it is also visible. 16913 16914 elsif Ekind (Original_Comp) = E_Discriminant 16915 and then 16916 (not Has_Unknown_Discriminants (Original_Scope) 16917 or else (Present (N) 16918 and then Nkind (N) = N_Selected_Component 16919 and then Nkind (Prefix (N)) = N_Type_Conversion 16920 and then not Comes_From_Source (Prefix (N)))) 16921 then 16922 return True; 16923 16924 -- In the body of an instantiation, no need to check for the visibility 16925 -- of a component. 16926 16927 elsif In_Instance_Body then 16928 return True; 16929 16930 -- If the component has been declared in an ancestor which is currently 16931 -- a private type, then it is not visible. The same applies if the 16932 -- component's containing type is not in an open scope and the original 16933 -- component's enclosing type is a visible full view of a private type 16934 -- (which can occur in cases where an attempt is being made to reference 16935 -- a component in a sibling package that is inherited from a visible 16936 -- component of a type in an ancestor package; the component in the 16937 -- sibling package should not be visible even though the component it 16938 -- inherited from is visible). This does not apply however in the case 16939 -- where the scope of the type is a private child unit, or when the 16940 -- parent comes from a local package in which the ancestor is currently 16941 -- visible. The latter suppression of visibility is needed for cases 16942 -- that are tested in B730006. 16943 16944 elsif Is_Private_Type (Original_Scope) 16945 or else 16946 (not Is_Private_Descendant (Type_Scope) 16947 and then not In_Open_Scopes (Type_Scope) 16948 and then Has_Private_Declaration (Original_Scope)) 16949 then 16950 -- If the type derives from an entity in a formal package, there 16951 -- are no additional visible components. 16952 16953 if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) = 16954 N_Formal_Package_Declaration 16955 then 16956 return False; 16957 16958 -- if we are not in the private part of the current package, there 16959 -- are no additional visible components. 16960 16961 elsif Ekind (Scope (Current_Scope)) = E_Package 16962 and then not In_Private_Part (Scope (Current_Scope)) 16963 then 16964 return False; 16965 else 16966 return 16967 Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) 16968 and then In_Open_Scopes (Scope (Original_Scope)) 16969 and then Is_Local_Type (Type_Scope); 16970 end if; 16971 16972 -- There is another weird way in which a component may be invisible when 16973 -- the private and the full view are not derived from the same ancestor. 16974 -- Here is an example : 16975 16976 -- type A1 is tagged record F1 : integer; end record; 16977 -- type A2 is new A1 with record F2 : integer; end record; 16978 -- type T is new A1 with private; 16979 -- private 16980 -- type T is new A2 with null record; 16981 16982 -- In this case, the full view of T inherits F1 and F2 but the private 16983 -- view inherits only F1 16984 16985 else 16986 declare 16987 Ancestor : Entity_Id := Scope (C); 16988 16989 begin 16990 loop 16991 if Ancestor = Original_Scope then 16992 return True; 16993 elsif Ancestor = Etype (Ancestor) then 16994 return False; 16995 end if; 16996 16997 Ancestor := Etype (Ancestor); 16998 end loop; 16999 end; 17000 end if; 17001 end Is_Visible_Component; 17002 17003 -------------------------- 17004 -- Make_Class_Wide_Type -- 17005 -------------------------- 17006 17007 procedure Make_Class_Wide_Type (T : Entity_Id) is 17008 CW_Type : Entity_Id; 17009 CW_Name : Name_Id; 17010 Next_E : Entity_Id; 17011 17012 begin 17013 if Present (Class_Wide_Type (T)) then 17014 17015 -- The class-wide type is a partially decorated entity created for a 17016 -- unanalyzed tagged type referenced through a limited with clause. 17017 -- When the tagged type is analyzed, its class-wide type needs to be 17018 -- redecorated. Note that we reuse the entity created by Decorate_ 17019 -- Tagged_Type in order to preserve all links. 17020 17021 if Materialize_Entity (Class_Wide_Type (T)) then 17022 CW_Type := Class_Wide_Type (T); 17023 Set_Materialize_Entity (CW_Type, False); 17024 17025 -- The class wide type can have been defined by the partial view, in 17026 -- which case everything is already done. 17027 17028 else 17029 return; 17030 end if; 17031 17032 -- Default case, we need to create a new class-wide type 17033 17034 else 17035 CW_Type := 17036 New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T'); 17037 end if; 17038 17039 -- Inherit root type characteristics 17040 17041 CW_Name := Chars (CW_Type); 17042 Next_E := Next_Entity (CW_Type); 17043 Copy_Node (T, CW_Type); 17044 Set_Comes_From_Source (CW_Type, False); 17045 Set_Chars (CW_Type, CW_Name); 17046 Set_Parent (CW_Type, Parent (T)); 17047 Set_Next_Entity (CW_Type, Next_E); 17048 17049 -- Ensure we have a new freeze node for the class-wide type. The partial 17050 -- view may have freeze action of its own, requiring a proper freeze 17051 -- node, and the same freeze node cannot be shared between the two 17052 -- types. 17053 17054 Set_Has_Delayed_Freeze (CW_Type); 17055 Set_Freeze_Node (CW_Type, Empty); 17056 17057 -- Customize the class-wide type: It has no prim. op., it cannot be 17058 -- abstract and its Etype points back to the specific root type. 17059 17060 Set_Ekind (CW_Type, E_Class_Wide_Type); 17061 Set_Is_Tagged_Type (CW_Type, True); 17062 Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); 17063 Set_Is_Abstract_Type (CW_Type, False); 17064 Set_Is_Constrained (CW_Type, False); 17065 Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); 17066 17067 if Ekind (T) = E_Class_Wide_Subtype then 17068 Set_Etype (CW_Type, Etype (Base_Type (T))); 17069 else 17070 Set_Etype (CW_Type, T); 17071 end if; 17072 17073 -- If this is the class_wide type of a constrained subtype, it does 17074 -- not have discriminants. 17075 17076 Set_Has_Discriminants (CW_Type, 17077 Has_Discriminants (T) and then not Is_Constrained (T)); 17078 17079 Set_Has_Unknown_Discriminants (CW_Type, True); 17080 Set_Class_Wide_Type (T, CW_Type); 17081 Set_Equivalent_Type (CW_Type, Empty); 17082 17083 -- The class-wide type of a class-wide type is itself (RM 3.9(14)) 17084 17085 Set_Class_Wide_Type (CW_Type, CW_Type); 17086 end Make_Class_Wide_Type; 17087 17088 ---------------- 17089 -- Make_Index -- 17090 ---------------- 17091 17092 procedure Make_Index 17093 (I : Node_Id; 17094 Related_Nod : Node_Id; 17095 Related_Id : Entity_Id := Empty; 17096 Suffix_Index : Nat := 1; 17097 In_Iter_Schm : Boolean := False) 17098 is 17099 R : Node_Id; 17100 T : Entity_Id; 17101 Def_Id : Entity_Id := Empty; 17102 Found : Boolean := False; 17103 17104 begin 17105 -- For a discrete range used in a constrained array definition and 17106 -- defined by a range, an implicit conversion to the predefined type 17107 -- INTEGER is assumed if each bound is either a numeric literal, a named 17108 -- number, or an attribute, and the type of both bounds (prior to the 17109 -- implicit conversion) is the type universal_integer. Otherwise, both 17110 -- bounds must be of the same discrete type, other than universal 17111 -- integer; this type must be determinable independently of the 17112 -- context, but using the fact that the type must be discrete and that 17113 -- both bounds must have the same type. 17114 17115 -- Character literals also have a universal type in the absence of 17116 -- of additional context, and are resolved to Standard_Character. 17117 17118 if Nkind (I) = N_Range then 17119 17120 -- The index is given by a range constraint. The bounds are known 17121 -- to be of a consistent type. 17122 17123 if not Is_Overloaded (I) then 17124 T := Etype (I); 17125 17126 -- For universal bounds, choose the specific predefined type 17127 17128 if T = Universal_Integer then 17129 T := Standard_Integer; 17130 17131 elsif T = Any_Character then 17132 Ambiguous_Character (Low_Bound (I)); 17133 17134 T := Standard_Character; 17135 end if; 17136 17137 -- The node may be overloaded because some user-defined operators 17138 -- are available, but if a universal interpretation exists it is 17139 -- also the selected one. 17140 17141 elsif Universal_Interpretation (I) = Universal_Integer then 17142 T := Standard_Integer; 17143 17144 else 17145 T := Any_Type; 17146 17147 declare 17148 Ind : Interp_Index; 17149 It : Interp; 17150 17151 begin 17152 Get_First_Interp (I, Ind, It); 17153 while Present (It.Typ) loop 17154 if Is_Discrete_Type (It.Typ) then 17155 17156 if Found 17157 and then not Covers (It.Typ, T) 17158 and then not Covers (T, It.Typ) 17159 then 17160 Error_Msg_N ("ambiguous bounds in discrete range", I); 17161 exit; 17162 else 17163 T := It.Typ; 17164 Found := True; 17165 end if; 17166 end if; 17167 17168 Get_Next_Interp (Ind, It); 17169 end loop; 17170 17171 if T = Any_Type then 17172 Error_Msg_N ("discrete type required for range", I); 17173 Set_Etype (I, Any_Type); 17174 return; 17175 17176 elsif T = Universal_Integer then 17177 T := Standard_Integer; 17178 end if; 17179 end; 17180 end if; 17181 17182 if not Is_Discrete_Type (T) then 17183 Error_Msg_N ("discrete type required for range", I); 17184 Set_Etype (I, Any_Type); 17185 return; 17186 end if; 17187 17188 if Nkind (Low_Bound (I)) = N_Attribute_Reference 17189 and then Attribute_Name (Low_Bound (I)) = Name_First 17190 and then Is_Entity_Name (Prefix (Low_Bound (I))) 17191 and then Is_Type (Entity (Prefix (Low_Bound (I)))) 17192 and then Is_Discrete_Type (Entity (Prefix (Low_Bound (I)))) 17193 then 17194 -- The type of the index will be the type of the prefix, as long 17195 -- as the upper bound is 'Last of the same type. 17196 17197 Def_Id := Entity (Prefix (Low_Bound (I))); 17198 17199 if Nkind (High_Bound (I)) /= N_Attribute_Reference 17200 or else Attribute_Name (High_Bound (I)) /= Name_Last 17201 or else not Is_Entity_Name (Prefix (High_Bound (I))) 17202 or else Entity (Prefix (High_Bound (I))) /= Def_Id 17203 then 17204 Def_Id := Empty; 17205 end if; 17206 end if; 17207 17208 R := I; 17209 Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm); 17210 17211 elsif Nkind (I) = N_Subtype_Indication then 17212 17213 -- The index is given by a subtype with a range constraint 17214 17215 T := Base_Type (Entity (Subtype_Mark (I))); 17216 17217 if not Is_Discrete_Type (T) then 17218 Error_Msg_N ("discrete type required for range", I); 17219 Set_Etype (I, Any_Type); 17220 return; 17221 end if; 17222 17223 R := Range_Expression (Constraint (I)); 17224 17225 Resolve (R, T); 17226 Process_Range_Expr_In_Decl 17227 (R, Entity (Subtype_Mark (I)), In_Iter_Schm => In_Iter_Schm); 17228 17229 elsif Nkind (I) = N_Attribute_Reference then 17230 17231 -- The parser guarantees that the attribute is a RANGE attribute 17232 17233 -- If the node denotes the range of a type mark, that is also the 17234 -- resulting type, and we do no need to create an Itype for it. 17235 17236 if Is_Entity_Name (Prefix (I)) 17237 and then Comes_From_Source (I) 17238 and then Is_Type (Entity (Prefix (I))) 17239 and then Is_Discrete_Type (Entity (Prefix (I))) 17240 then 17241 Def_Id := Entity (Prefix (I)); 17242 end if; 17243 17244 Analyze_And_Resolve (I); 17245 T := Etype (I); 17246 R := I; 17247 17248 -- If none of the above, must be a subtype. We convert this to a 17249 -- range attribute reference because in the case of declared first 17250 -- named subtypes, the types in the range reference can be different 17251 -- from the type of the entity. A range attribute normalizes the 17252 -- reference and obtains the correct types for the bounds. 17253 17254 -- This transformation is in the nature of an expansion, is only 17255 -- done if expansion is active. In particular, it is not done on 17256 -- formal generic types, because we need to retain the name of the 17257 -- original index for instantiation purposes. 17258 17259 else 17260 if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then 17261 Error_Msg_N ("invalid subtype mark in discrete range ", I); 17262 Set_Etype (I, Any_Integer); 17263 return; 17264 17265 else 17266 -- The type mark may be that of an incomplete type. It is only 17267 -- now that we can get the full view, previous analysis does 17268 -- not look specifically for a type mark. 17269 17270 Set_Entity (I, Get_Full_View (Entity (I))); 17271 Set_Etype (I, Entity (I)); 17272 Def_Id := Entity (I); 17273 17274 if not Is_Discrete_Type (Def_Id) then 17275 Error_Msg_N ("discrete type required for index", I); 17276 Set_Etype (I, Any_Type); 17277 return; 17278 end if; 17279 end if; 17280 17281 if Expander_Active then 17282 Rewrite (I, 17283 Make_Attribute_Reference (Sloc (I), 17284 Attribute_Name => Name_Range, 17285 Prefix => Relocate_Node (I))); 17286 17287 -- The original was a subtype mark that does not freeze. This 17288 -- means that the rewritten version must not freeze either. 17289 17290 Set_Must_Not_Freeze (I); 17291 Set_Must_Not_Freeze (Prefix (I)); 17292 Analyze_And_Resolve (I); 17293 T := Etype (I); 17294 R := I; 17295 17296 -- If expander is inactive, type is legal, nothing else to construct 17297 17298 else 17299 return; 17300 end if; 17301 end if; 17302 17303 if not Is_Discrete_Type (T) then 17304 Error_Msg_N ("discrete type required for range", I); 17305 Set_Etype (I, Any_Type); 17306 return; 17307 17308 elsif T = Any_Type then 17309 Set_Etype (I, Any_Type); 17310 return; 17311 end if; 17312 17313 -- We will now create the appropriate Itype to describe the range, but 17314 -- first a check. If we originally had a subtype, then we just label 17315 -- the range with this subtype. Not only is there no need to construct 17316 -- a new subtype, but it is wrong to do so for two reasons: 17317 17318 -- 1. A legality concern, if we have a subtype, it must not freeze, 17319 -- and the Itype would cause freezing incorrectly 17320 17321 -- 2. An efficiency concern, if we created an Itype, it would not be 17322 -- recognized as the same type for the purposes of eliminating 17323 -- checks in some circumstances. 17324 17325 -- We signal this case by setting the subtype entity in Def_Id 17326 17327 if No (Def_Id) then 17328 Def_Id := 17329 Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index); 17330 Set_Etype (Def_Id, Base_Type (T)); 17331 17332 if Is_Signed_Integer_Type (T) then 17333 Set_Ekind (Def_Id, E_Signed_Integer_Subtype); 17334 17335 elsif Is_Modular_Integer_Type (T) then 17336 Set_Ekind (Def_Id, E_Modular_Integer_Subtype); 17337 17338 else 17339 Set_Ekind (Def_Id, E_Enumeration_Subtype); 17340 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 17341 Set_First_Literal (Def_Id, First_Literal (T)); 17342 end if; 17343 17344 Set_Size_Info (Def_Id, (T)); 17345 Set_RM_Size (Def_Id, RM_Size (T)); 17346 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 17347 17348 Set_Scalar_Range (Def_Id, R); 17349 Conditional_Delay (Def_Id, T); 17350 17351 -- In the subtype indication case, if the immediate parent of the 17352 -- new subtype is non-static, then the subtype we create is non- 17353 -- static, even if its bounds are static. 17354 17355 if Nkind (I) = N_Subtype_Indication 17356 and then not Is_Static_Subtype (Entity (Subtype_Mark (I))) 17357 then 17358 Set_Is_Non_Static_Subtype (Def_Id); 17359 end if; 17360 end if; 17361 17362 -- Final step is to label the index with this constructed type 17363 17364 Set_Etype (I, Def_Id); 17365 end Make_Index; 17366 17367 ------------------------------ 17368 -- Modular_Type_Declaration -- 17369 ------------------------------ 17370 17371 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is 17372 Mod_Expr : constant Node_Id := Expression (Def); 17373 M_Val : Uint; 17374 17375 procedure Set_Modular_Size (Bits : Int); 17376 -- Sets RM_Size to Bits, and Esize to normal word size above this 17377 17378 ---------------------- 17379 -- Set_Modular_Size -- 17380 ---------------------- 17381 17382 procedure Set_Modular_Size (Bits : Int) is 17383 begin 17384 Set_RM_Size (T, UI_From_Int (Bits)); 17385 17386 if Bits <= 8 then 17387 Init_Esize (T, 8); 17388 17389 elsif Bits <= 16 then 17390 Init_Esize (T, 16); 17391 17392 elsif Bits <= 32 then 17393 Init_Esize (T, 32); 17394 17395 else 17396 Init_Esize (T, System_Max_Binary_Modulus_Power); 17397 end if; 17398 17399 if not Non_Binary_Modulus (T) 17400 and then Esize (T) = RM_Size (T) 17401 then 17402 Set_Is_Known_Valid (T); 17403 end if; 17404 end Set_Modular_Size; 17405 17406 -- Start of processing for Modular_Type_Declaration 17407 17408 begin 17409 -- If the mod expression is (exactly) 2 * literal, where literal is 17410 -- 64 or less,then almost certainly the * was meant to be **. Warn. 17411 17412 if Warn_On_Suspicious_Modulus_Value 17413 and then Nkind (Mod_Expr) = N_Op_Multiply 17414 and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal 17415 and then Intval (Left_Opnd (Mod_Expr)) = Uint_2 17416 and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal 17417 and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64 17418 then 17419 Error_Msg_N 17420 ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr); 17421 end if; 17422 17423 -- Proceed with analysis of mod expression 17424 17425 Analyze_And_Resolve (Mod_Expr, Any_Integer); 17426 Set_Etype (T, T); 17427 Set_Ekind (T, E_Modular_Integer_Type); 17428 Init_Alignment (T); 17429 Set_Is_Constrained (T); 17430 17431 if not Is_OK_Static_Expression (Mod_Expr) then 17432 Flag_Non_Static_Expr 17433 ("non-static expression used for modular type bound!", Mod_Expr); 17434 M_Val := 2 ** System_Max_Binary_Modulus_Power; 17435 else 17436 M_Val := Expr_Value (Mod_Expr); 17437 end if; 17438 17439 if M_Val < 1 then 17440 Error_Msg_N ("modulus value must be positive", Mod_Expr); 17441 M_Val := 2 ** System_Max_Binary_Modulus_Power; 17442 end if; 17443 17444 Set_Modulus (T, M_Val); 17445 17446 -- Create bounds for the modular type based on the modulus given in 17447 -- the type declaration and then analyze and resolve those bounds. 17448 17449 Set_Scalar_Range (T, 17450 Make_Range (Sloc (Mod_Expr), 17451 Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0), 17452 High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1))); 17453 17454 -- Properly analyze the literals for the range. We do this manually 17455 -- because we can't go calling Resolve, since we are resolving these 17456 -- bounds with the type, and this type is certainly not complete yet. 17457 17458 Set_Etype (Low_Bound (Scalar_Range (T)), T); 17459 Set_Etype (High_Bound (Scalar_Range (T)), T); 17460 Set_Is_Static_Expression (Low_Bound (Scalar_Range (T))); 17461 Set_Is_Static_Expression (High_Bound (Scalar_Range (T))); 17462 17463 -- Loop through powers of two to find number of bits required 17464 17465 for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop 17466 17467 -- Binary case 17468 17469 if M_Val = 2 ** Bits then 17470 Set_Modular_Size (Bits); 17471 return; 17472 17473 -- Non-binary case 17474 17475 elsif M_Val < 2 ** Bits then 17476 Check_SPARK_Restriction ("modulus should be a power of 2", T); 17477 Set_Non_Binary_Modulus (T); 17478 17479 if Bits > System_Max_Nonbinary_Modulus_Power then 17480 Error_Msg_Uint_1 := 17481 UI_From_Int (System_Max_Nonbinary_Modulus_Power); 17482 Error_Msg_F 17483 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr); 17484 Set_Modular_Size (System_Max_Binary_Modulus_Power); 17485 return; 17486 17487 else 17488 -- In the non-binary case, set size as per RM 13.3(55) 17489 17490 Set_Modular_Size (Bits); 17491 return; 17492 end if; 17493 end if; 17494 17495 end loop; 17496 17497 -- If we fall through, then the size exceed System.Max_Binary_Modulus 17498 -- so we just signal an error and set the maximum size. 17499 17500 Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power); 17501 Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr); 17502 17503 Set_Modular_Size (System_Max_Binary_Modulus_Power); 17504 Init_Alignment (T); 17505 17506 end Modular_Type_Declaration; 17507 17508 -------------------------- 17509 -- New_Concatenation_Op -- 17510 -------------------------- 17511 17512 procedure New_Concatenation_Op (Typ : Entity_Id) is 17513 Loc : constant Source_Ptr := Sloc (Typ); 17514 Op : Entity_Id; 17515 17516 function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id; 17517 -- Create abbreviated declaration for the formal of a predefined 17518 -- Operator 'Op' of type 'Typ' 17519 17520 -------------------- 17521 -- Make_Op_Formal -- 17522 -------------------- 17523 17524 function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is 17525 Formal : Entity_Id; 17526 begin 17527 Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P'); 17528 Set_Etype (Formal, Typ); 17529 Set_Mechanism (Formal, Default_Mechanism); 17530 return Formal; 17531 end Make_Op_Formal; 17532 17533 -- Start of processing for New_Concatenation_Op 17534 17535 begin 17536 Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); 17537 17538 Set_Ekind (Op, E_Operator); 17539 Set_Scope (Op, Current_Scope); 17540 Set_Etype (Op, Typ); 17541 Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); 17542 Set_Is_Immediately_Visible (Op); 17543 Set_Is_Intrinsic_Subprogram (Op); 17544 Set_Has_Completion (Op); 17545 Append_Entity (Op, Current_Scope); 17546 17547 Set_Name_Entity_Id (Name_Op_Concat, Op); 17548 17549 Append_Entity (Make_Op_Formal (Typ, Op), Op); 17550 Append_Entity (Make_Op_Formal (Typ, Op), Op); 17551 end New_Concatenation_Op; 17552 17553 ------------------------- 17554 -- OK_For_Limited_Init -- 17555 ------------------------- 17556 17557 -- ???Check all calls of this, and compare the conditions under which it's 17558 -- called. 17559 17560 function OK_For_Limited_Init 17561 (Typ : Entity_Id; 17562 Exp : Node_Id) return Boolean 17563 is 17564 begin 17565 return Is_CPP_Constructor_Call (Exp) 17566 or else (Ada_Version >= Ada_2005 17567 and then not Debug_Flag_Dot_L 17568 and then OK_For_Limited_Init_In_05 (Typ, Exp)); 17569 end OK_For_Limited_Init; 17570 17571 ------------------------------- 17572 -- OK_For_Limited_Init_In_05 -- 17573 ------------------------------- 17574 17575 function OK_For_Limited_Init_In_05 17576 (Typ : Entity_Id; 17577 Exp : Node_Id) return Boolean 17578 is 17579 begin 17580 -- An object of a limited interface type can be initialized with any 17581 -- expression of a nonlimited descendant type. 17582 17583 if Is_Class_Wide_Type (Typ) 17584 and then Is_Limited_Interface (Typ) 17585 and then not Is_Limited_Type (Etype (Exp)) 17586 then 17587 return True; 17588 end if; 17589 17590 -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in 17591 -- case of limited aggregates (including extension aggregates), and 17592 -- function calls. The function call may have been given in prefixed 17593 -- notation, in which case the original node is an indexed component. 17594 -- If the function is parameterless, the original node was an explicit 17595 -- dereference. The function may also be parameterless, in which case 17596 -- the source node is just an identifier. 17597 17598 case Nkind (Original_Node (Exp)) is 17599 when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op => 17600 return True; 17601 17602 when N_Identifier => 17603 return Present (Entity (Original_Node (Exp))) 17604 and then Ekind (Entity (Original_Node (Exp))) = E_Function; 17605 17606 when N_Qualified_Expression => 17607 return 17608 OK_For_Limited_Init_In_05 17609 (Typ, Expression (Original_Node (Exp))); 17610 17611 -- Ada 2005 (AI-251): If a class-wide interface object is initialized 17612 -- with a function call, the expander has rewritten the call into an 17613 -- N_Type_Conversion node to force displacement of the pointer to 17614 -- reference the component containing the secondary dispatch table. 17615 -- Otherwise a type conversion is not a legal context. 17616 -- A return statement for a build-in-place function returning a 17617 -- synchronized type also introduces an unchecked conversion. 17618 17619 when N_Type_Conversion | 17620 N_Unchecked_Type_Conversion => 17621 return not Comes_From_Source (Exp) 17622 and then 17623 OK_For_Limited_Init_In_05 17624 (Typ, Expression (Original_Node (Exp))); 17625 17626 when N_Indexed_Component | 17627 N_Selected_Component | 17628 N_Explicit_Dereference => 17629 return Nkind (Exp) = N_Function_Call; 17630 17631 -- A use of 'Input is a function call, hence allowed. Normally the 17632 -- attribute will be changed to a call, but the attribute by itself 17633 -- can occur with -gnatc. 17634 17635 when N_Attribute_Reference => 17636 return Attribute_Name (Original_Node (Exp)) = Name_Input; 17637 17638 -- For a case expression, all dependent expressions must be legal 17639 17640 when N_Case_Expression => 17641 declare 17642 Alt : Node_Id; 17643 17644 begin 17645 Alt := First (Alternatives (Original_Node (Exp))); 17646 while Present (Alt) loop 17647 if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then 17648 return False; 17649 end if; 17650 17651 Next (Alt); 17652 end loop; 17653 17654 return True; 17655 end; 17656 17657 -- For an if expression, all dependent expressions must be legal 17658 17659 when N_If_Expression => 17660 declare 17661 Then_Expr : constant Node_Id := 17662 Next (First (Expressions (Original_Node (Exp)))); 17663 Else_Expr : constant Node_Id := Next (Then_Expr); 17664 begin 17665 return OK_For_Limited_Init_In_05 (Typ, Then_Expr) 17666 and then 17667 OK_For_Limited_Init_In_05 (Typ, Else_Expr); 17668 end; 17669 17670 when others => 17671 return False; 17672 end case; 17673 end OK_For_Limited_Init_In_05; 17674 17675 ------------------------------------------- 17676 -- Ordinary_Fixed_Point_Type_Declaration -- 17677 ------------------------------------------- 17678 17679 procedure Ordinary_Fixed_Point_Type_Declaration 17680 (T : Entity_Id; 17681 Def : Node_Id) 17682 is 17683 Loc : constant Source_Ptr := Sloc (Def); 17684 Delta_Expr : constant Node_Id := Delta_Expression (Def); 17685 RRS : constant Node_Id := Real_Range_Specification (Def); 17686 Implicit_Base : Entity_Id; 17687 Delta_Val : Ureal; 17688 Small_Val : Ureal; 17689 Low_Val : Ureal; 17690 High_Val : Ureal; 17691 17692 begin 17693 Check_Restriction (No_Fixed_Point, Def); 17694 17695 -- Create implicit base type 17696 17697 Implicit_Base := 17698 Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B'); 17699 Set_Etype (Implicit_Base, Implicit_Base); 17700 17701 -- Analyze and process delta expression 17702 17703 Analyze_And_Resolve (Delta_Expr, Any_Real); 17704 17705 Check_Delta_Expression (Delta_Expr); 17706 Delta_Val := Expr_Value_R (Delta_Expr); 17707 17708 Set_Delta_Value (Implicit_Base, Delta_Val); 17709 17710 -- Compute default small from given delta, which is the largest power 17711 -- of two that does not exceed the given delta value. 17712 17713 declare 17714 Tmp : Ureal; 17715 Scale : Int; 17716 17717 begin 17718 Tmp := Ureal_1; 17719 Scale := 0; 17720 17721 if Delta_Val < Ureal_1 then 17722 while Delta_Val < Tmp loop 17723 Tmp := Tmp / Ureal_2; 17724 Scale := Scale + 1; 17725 end loop; 17726 17727 else 17728 loop 17729 Tmp := Tmp * Ureal_2; 17730 exit when Tmp > Delta_Val; 17731 Scale := Scale - 1; 17732 end loop; 17733 end if; 17734 17735 Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2); 17736 end; 17737 17738 Set_Small_Value (Implicit_Base, Small_Val); 17739 17740 -- If no range was given, set a dummy range 17741 17742 if RRS <= Empty_Or_Error then 17743 Low_Val := -Small_Val; 17744 High_Val := Small_Val; 17745 17746 -- Otherwise analyze and process given range 17747 17748 else 17749 declare 17750 Low : constant Node_Id := Low_Bound (RRS); 17751 High : constant Node_Id := High_Bound (RRS); 17752 17753 begin 17754 Analyze_And_Resolve (Low, Any_Real); 17755 Analyze_And_Resolve (High, Any_Real); 17756 Check_Real_Bound (Low); 17757 Check_Real_Bound (High); 17758 17759 -- Obtain and set the range 17760 17761 Low_Val := Expr_Value_R (Low); 17762 High_Val := Expr_Value_R (High); 17763 17764 if Low_Val > High_Val then 17765 Error_Msg_NE ("??fixed point type& has null range", Def, T); 17766 end if; 17767 end; 17768 end if; 17769 17770 -- The range for both the implicit base and the declared first subtype 17771 -- cannot be set yet, so we use the special routine Set_Fixed_Range to 17772 -- set a temporary range in place. Note that the bounds of the base 17773 -- type will be widened to be symmetrical and to fill the available 17774 -- bits when the type is frozen. 17775 17776 -- We could do this with all discrete types, and probably should, but 17777 -- we absolutely have to do it for fixed-point, since the end-points 17778 -- of the range and the size are determined by the small value, which 17779 -- could be reset before the freeze point. 17780 17781 Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); 17782 Set_Fixed_Range (T, Loc, Low_Val, High_Val); 17783 17784 -- Complete definition of first subtype 17785 17786 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); 17787 Set_Etype (T, Implicit_Base); 17788 Init_Size_Align (T); 17789 Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); 17790 Set_Small_Value (T, Small_Val); 17791 Set_Delta_Value (T, Delta_Val); 17792 Set_Is_Constrained (T); 17793 17794 end Ordinary_Fixed_Point_Type_Declaration; 17795 17796 ---------------------------------------- 17797 -- Prepare_Private_Subtype_Completion -- 17798 ---------------------------------------- 17799 17800 procedure Prepare_Private_Subtype_Completion 17801 (Id : Entity_Id; 17802 Related_Nod : Node_Id) 17803 is 17804 Id_B : constant Entity_Id := Base_Type (Id); 17805 Full_B : constant Entity_Id := Full_View (Id_B); 17806 Full : Entity_Id; 17807 17808 begin 17809 if Present (Full_B) then 17810 17811 -- The Base_Type is already completed, we can complete the subtype 17812 -- now. We have to create a new entity with the same name, Thus we 17813 -- can't use Create_Itype. 17814 17815 Full := Make_Defining_Identifier (Sloc (Id), Chars (Id)); 17816 Set_Is_Itype (Full); 17817 Set_Associated_Node_For_Itype (Full, Related_Nod); 17818 Complete_Private_Subtype (Id, Full, Full_B, Related_Nod); 17819 end if; 17820 17821 -- The parent subtype may be private, but the base might not, in some 17822 -- nested instances. In that case, the subtype does not need to be 17823 -- exchanged. It would still be nice to make private subtypes and their 17824 -- bases consistent at all times ??? 17825 17826 if Is_Private_Type (Id_B) then 17827 Append_Elmt (Id, Private_Dependents (Id_B)); 17828 end if; 17829 end Prepare_Private_Subtype_Completion; 17830 17831 --------------------------- 17832 -- Process_Discriminants -- 17833 --------------------------- 17834 17835 procedure Process_Discriminants 17836 (N : Node_Id; 17837 Prev : Entity_Id := Empty) 17838 is 17839 Elist : constant Elist_Id := New_Elmt_List; 17840 Id : Node_Id; 17841 Discr : Node_Id; 17842 Discr_Number : Uint; 17843 Discr_Type : Entity_Id; 17844 Default_Present : Boolean := False; 17845 Default_Not_Present : Boolean := False; 17846 17847 begin 17848 -- A composite type other than an array type can have discriminants. 17849 -- On entry, the current scope is the composite type. 17850 17851 -- The discriminants are initially entered into the scope of the type 17852 -- via Enter_Name with the default Ekind of E_Void to prevent premature 17853 -- use, as explained at the end of this procedure. 17854 17855 Discr := First (Discriminant_Specifications (N)); 17856 while Present (Discr) loop 17857 Enter_Name (Defining_Identifier (Discr)); 17858 17859 -- For navigation purposes we add a reference to the discriminant 17860 -- in the entity for the type. If the current declaration is a 17861 -- completion, place references on the partial view. Otherwise the 17862 -- type is the current scope. 17863 17864 if Present (Prev) then 17865 17866 -- The references go on the partial view, if present. If the 17867 -- partial view has discriminants, the references have been 17868 -- generated already. 17869 17870 if not Has_Discriminants (Prev) then 17871 Generate_Reference (Prev, Defining_Identifier (Discr), 'd'); 17872 end if; 17873 else 17874 Generate_Reference 17875 (Current_Scope, Defining_Identifier (Discr), 'd'); 17876 end if; 17877 17878 if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then 17879 Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr)); 17880 17881 -- Ada 2005 (AI-254) 17882 17883 if Present (Access_To_Subprogram_Definition 17884 (Discriminant_Type (Discr))) 17885 and then Protected_Present (Access_To_Subprogram_Definition 17886 (Discriminant_Type (Discr))) 17887 then 17888 Discr_Type := 17889 Replace_Anonymous_Access_To_Protected_Subprogram (Discr); 17890 end if; 17891 17892 else 17893 Find_Type (Discriminant_Type (Discr)); 17894 Discr_Type := Etype (Discriminant_Type (Discr)); 17895 17896 if Error_Posted (Discriminant_Type (Discr)) then 17897 Discr_Type := Any_Type; 17898 end if; 17899 end if; 17900 17901 if Is_Access_Type (Discr_Type) then 17902 17903 -- Ada 2005 (AI-230): Access discriminant allowed in non-limited 17904 -- record types 17905 17906 if Ada_Version < Ada_2005 then 17907 Check_Access_Discriminant_Requires_Limited 17908 (Discr, Discriminant_Type (Discr)); 17909 end if; 17910 17911 if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then 17912 Error_Msg_N 17913 ("(Ada 83) access discriminant not allowed", Discr); 17914 end if; 17915 17916 elsif not Is_Discrete_Type (Discr_Type) then 17917 Error_Msg_N ("discriminants must have a discrete or access type", 17918 Discriminant_Type (Discr)); 17919 end if; 17920 17921 Set_Etype (Defining_Identifier (Discr), Discr_Type); 17922 17923 -- If a discriminant specification includes the assignment compound 17924 -- delimiter followed by an expression, the expression is the default 17925 -- expression of the discriminant; the default expression must be of 17926 -- the type of the discriminant. (RM 3.7.1) Since this expression is 17927 -- a default expression, we do the special preanalysis, since this 17928 -- expression does not freeze (see "Handling of Default and Per- 17929 -- Object Expressions" in spec of package Sem). 17930 17931 if Present (Expression (Discr)) then 17932 Preanalyze_Spec_Expression (Expression (Discr), Discr_Type); 17933 17934 if Nkind (N) = N_Formal_Type_Declaration then 17935 Error_Msg_N 17936 ("discriminant defaults not allowed for formal type", 17937 Expression (Discr)); 17938 17939 -- Flag an error for a tagged type with defaulted discriminants, 17940 -- excluding limited tagged types when compiling for Ada 2012 17941 -- (see AI05-0214). 17942 17943 elsif Is_Tagged_Type (Current_Scope) 17944 and then (not Is_Limited_Type (Current_Scope) 17945 or else Ada_Version < Ada_2012) 17946 and then Comes_From_Source (N) 17947 then 17948 -- Note: see similar test in Check_Or_Process_Discriminants, to 17949 -- handle the (illegal) case of the completion of an untagged 17950 -- view with discriminants with defaults by a tagged full view. 17951 -- We skip the check if Discr does not come from source, to 17952 -- account for the case of an untagged derived type providing 17953 -- defaults for a renamed discriminant from a private untagged 17954 -- ancestor with a tagged full view (ACATS B460006). 17955 17956 if Ada_Version >= Ada_2012 then 17957 Error_Msg_N 17958 ("discriminants of nonlimited tagged type cannot have" 17959 & " defaults", 17960 Expression (Discr)); 17961 else 17962 Error_Msg_N 17963 ("discriminants of tagged type cannot have defaults", 17964 Expression (Discr)); 17965 end if; 17966 17967 else 17968 Default_Present := True; 17969 Append_Elmt (Expression (Discr), Elist); 17970 17971 -- Tag the defining identifiers for the discriminants with 17972 -- their corresponding default expressions from the tree. 17973 17974 Set_Discriminant_Default_Value 17975 (Defining_Identifier (Discr), Expression (Discr)); 17976 end if; 17977 17978 else 17979 Default_Not_Present := True; 17980 end if; 17981 17982 -- Ada 2005 (AI-231): Create an Itype that is a duplicate of 17983 -- Discr_Type but with the null-exclusion attribute 17984 17985 if Ada_Version >= Ada_2005 then 17986 17987 -- Ada 2005 (AI-231): Static checks 17988 17989 if Can_Never_Be_Null (Discr_Type) then 17990 Null_Exclusion_Static_Checks (Discr); 17991 17992 elsif Is_Access_Type (Discr_Type) 17993 and then Null_Exclusion_Present (Discr) 17994 17995 -- No need to check itypes because in their case this check 17996 -- was done at their point of creation 17997 17998 and then not Is_Itype (Discr_Type) 17999 then 18000 if Can_Never_Be_Null (Discr_Type) then 18001 Error_Msg_NE 18002 ("`NOT NULL` not allowed (& already excludes null)", 18003 Discr, 18004 Discr_Type); 18005 end if; 18006 18007 Set_Etype (Defining_Identifier (Discr), 18008 Create_Null_Excluding_Itype 18009 (T => Discr_Type, 18010 Related_Nod => Discr)); 18011 18012 -- Check for improper null exclusion if the type is otherwise 18013 -- legal for a discriminant. 18014 18015 elsif Null_Exclusion_Present (Discr) 18016 and then Is_Discrete_Type (Discr_Type) 18017 then 18018 Error_Msg_N 18019 ("null exclusion can only apply to an access type", Discr); 18020 end if; 18021 18022 -- Ada 2005 (AI-402): access discriminants of nonlimited types 18023 -- can't have defaults. Synchronized types, or types that are 18024 -- explicitly limited are fine, but special tests apply to derived 18025 -- types in generics: in a generic body we have to assume the 18026 -- worst, and therefore defaults are not allowed if the parent is 18027 -- a generic formal private type (see ACATS B370001). 18028 18029 if Is_Access_Type (Discr_Type) and then Default_Present then 18030 if Ekind (Discr_Type) /= E_Anonymous_Access_Type 18031 or else Is_Limited_Record (Current_Scope) 18032 or else Is_Concurrent_Type (Current_Scope) 18033 or else Is_Concurrent_Record_Type (Current_Scope) 18034 or else Ekind (Current_Scope) = E_Limited_Private_Type 18035 then 18036 if not Is_Derived_Type (Current_Scope) 18037 or else not Is_Generic_Type (Etype (Current_Scope)) 18038 or else not In_Package_Body (Scope (Etype (Current_Scope))) 18039 or else Limited_Present 18040 (Type_Definition (Parent (Current_Scope))) 18041 then 18042 null; 18043 18044 else 18045 Error_Msg_N ("access discriminants of nonlimited types", 18046 Expression (Discr)); 18047 Error_Msg_N ("\cannot have defaults", Expression (Discr)); 18048 end if; 18049 18050 elsif Present (Expression (Discr)) then 18051 Error_Msg_N 18052 ("(Ada 2005) access discriminants of nonlimited types", 18053 Expression (Discr)); 18054 Error_Msg_N ("\cannot have defaults", Expression (Discr)); 18055 end if; 18056 end if; 18057 end if; 18058 18059 -- A discriminant cannot be volatile. This check is only relevant 18060 -- when SPARK_Mode is on as it is not standard Ada legality rule 18061 -- (SPARK RM 7.1.3(6)). 18062 18063 if SPARK_Mode = On 18064 and then Is_SPARK_Volatile_Object (Defining_Identifier (Discr)) 18065 then 18066 Error_Msg_N ("discriminant cannot be volatile", Discr); 18067 end if; 18068 18069 Next (Discr); 18070 end loop; 18071 18072 -- An element list consisting of the default expressions of the 18073 -- discriminants is constructed in the above loop and used to set 18074 -- the Discriminant_Constraint attribute for the type. If an object 18075 -- is declared of this (record or task) type without any explicit 18076 -- discriminant constraint given, this element list will form the 18077 -- actual parameters for the corresponding initialization procedure 18078 -- for the type. 18079 18080 Set_Discriminant_Constraint (Current_Scope, Elist); 18081 Set_Stored_Constraint (Current_Scope, No_Elist); 18082 18083 -- Default expressions must be provided either for all or for none 18084 -- of the discriminants of a discriminant part. (RM 3.7.1) 18085 18086 if Default_Present and then Default_Not_Present then 18087 Error_Msg_N 18088 ("incomplete specification of defaults for discriminants", N); 18089 end if; 18090 18091 -- The use of the name of a discriminant is not allowed in default 18092 -- expressions of a discriminant part if the specification of the 18093 -- discriminant is itself given in the discriminant part. (RM 3.7.1) 18094 18095 -- To detect this, the discriminant names are entered initially with an 18096 -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any 18097 -- attempt to use a void entity (for example in an expression that is 18098 -- type-checked) produces the error message: premature usage. Now after 18099 -- completing the semantic analysis of the discriminant part, we can set 18100 -- the Ekind of all the discriminants appropriately. 18101 18102 Discr := First (Discriminant_Specifications (N)); 18103 Discr_Number := Uint_1; 18104 while Present (Discr) loop 18105 Id := Defining_Identifier (Discr); 18106 Set_Ekind (Id, E_Discriminant); 18107 Init_Component_Location (Id); 18108 Init_Esize (Id); 18109 Set_Discriminant_Number (Id, Discr_Number); 18110 18111 -- Make sure this is always set, even in illegal programs 18112 18113 Set_Corresponding_Discriminant (Id, Empty); 18114 18115 -- Initialize the Original_Record_Component to the entity itself. 18116 -- Inherit_Components will propagate the right value to 18117 -- discriminants in derived record types. 18118 18119 Set_Original_Record_Component (Id, Id); 18120 18121 -- Create the discriminal for the discriminant 18122 18123 Build_Discriminal (Id); 18124 18125 Next (Discr); 18126 Discr_Number := Discr_Number + 1; 18127 end loop; 18128 18129 Set_Has_Discriminants (Current_Scope); 18130 end Process_Discriminants; 18131 18132 ----------------------- 18133 -- Process_Full_View -- 18134 ----------------------- 18135 18136 procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is 18137 Priv_Parent : Entity_Id; 18138 Full_Parent : Entity_Id; 18139 Full_Indic : Node_Id; 18140 18141 procedure Collect_Implemented_Interfaces 18142 (Typ : Entity_Id; 18143 Ifaces : Elist_Id); 18144 -- Ada 2005: Gather all the interfaces that Typ directly or 18145 -- inherently implements. Duplicate entries are not added to 18146 -- the list Ifaces. 18147 18148 ------------------------------------ 18149 -- Collect_Implemented_Interfaces -- 18150 ------------------------------------ 18151 18152 procedure Collect_Implemented_Interfaces 18153 (Typ : Entity_Id; 18154 Ifaces : Elist_Id) 18155 is 18156 Iface : Entity_Id; 18157 Iface_Elmt : Elmt_Id; 18158 18159 begin 18160 -- Abstract interfaces are only associated with tagged record types 18161 18162 if not Is_Tagged_Type (Typ) 18163 or else not Is_Record_Type (Typ) 18164 then 18165 return; 18166 end if; 18167 18168 -- Recursively climb to the ancestors 18169 18170 if Etype (Typ) /= Typ 18171 18172 -- Protect the frontend against wrong cyclic declarations like: 18173 18174 -- type B is new A with private; 18175 -- type C is new A with private; 18176 -- private 18177 -- type B is new C with null record; 18178 -- type C is new B with null record; 18179 18180 and then Etype (Typ) /= Priv_T 18181 and then Etype (Typ) /= Full_T 18182 then 18183 -- Keep separate the management of private type declarations 18184 18185 if Ekind (Typ) = E_Record_Type_With_Private then 18186 18187 -- Handle the following erroneous case: 18188 -- type Private_Type is tagged private; 18189 -- private 18190 -- type Private_Type is new Type_Implementing_Iface; 18191 18192 if Present (Full_View (Typ)) 18193 and then Etype (Typ) /= Full_View (Typ) 18194 then 18195 if Is_Interface (Etype (Typ)) then 18196 Append_Unique_Elmt (Etype (Typ), Ifaces); 18197 end if; 18198 18199 Collect_Implemented_Interfaces (Etype (Typ), Ifaces); 18200 end if; 18201 18202 -- Non-private types 18203 18204 else 18205 if Is_Interface (Etype (Typ)) then 18206 Append_Unique_Elmt (Etype (Typ), Ifaces); 18207 end if; 18208 18209 Collect_Implemented_Interfaces (Etype (Typ), Ifaces); 18210 end if; 18211 end if; 18212 18213 -- Handle entities in the list of abstract interfaces 18214 18215 if Present (Interfaces (Typ)) then 18216 Iface_Elmt := First_Elmt (Interfaces (Typ)); 18217 while Present (Iface_Elmt) loop 18218 Iface := Node (Iface_Elmt); 18219 18220 pragma Assert (Is_Interface (Iface)); 18221 18222 if not Contain_Interface (Iface, Ifaces) then 18223 Append_Elmt (Iface, Ifaces); 18224 Collect_Implemented_Interfaces (Iface, Ifaces); 18225 end if; 18226 18227 Next_Elmt (Iface_Elmt); 18228 end loop; 18229 end if; 18230 end Collect_Implemented_Interfaces; 18231 18232 -- Start of processing for Process_Full_View 18233 18234 begin 18235 -- First some sanity checks that must be done after semantic 18236 -- decoration of the full view and thus cannot be placed with other 18237 -- similar checks in Find_Type_Name 18238 18239 if not Is_Limited_Type (Priv_T) 18240 and then (Is_Limited_Type (Full_T) 18241 or else Is_Limited_Composite (Full_T)) 18242 then 18243 if In_Instance then 18244 null; 18245 else 18246 Error_Msg_N 18247 ("completion of nonlimited type cannot be limited", Full_T); 18248 Explain_Limited_Type (Full_T, Full_T); 18249 end if; 18250 18251 elsif Is_Abstract_Type (Full_T) 18252 and then not Is_Abstract_Type (Priv_T) 18253 then 18254 Error_Msg_N 18255 ("completion of nonabstract type cannot be abstract", Full_T); 18256 18257 elsif Is_Tagged_Type (Priv_T) 18258 and then Is_Limited_Type (Priv_T) 18259 and then not Is_Limited_Type (Full_T) 18260 then 18261 -- If pragma CPP_Class was applied to the private declaration 18262 -- propagate the limitedness to the full-view 18263 18264 if Is_CPP_Class (Priv_T) then 18265 Set_Is_Limited_Record (Full_T); 18266 18267 -- GNAT allow its own definition of Limited_Controlled to disobey 18268 -- this rule in order in ease the implementation. This test is safe 18269 -- because Root_Controlled is defined in a child of System that 18270 -- normal programs are not supposed to use. 18271 18272 elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then 18273 Set_Is_Limited_Composite (Full_T); 18274 else 18275 Error_Msg_N 18276 ("completion of limited tagged type must be limited", Full_T); 18277 end if; 18278 18279 elsif Is_Generic_Type (Priv_T) then 18280 Error_Msg_N ("generic type cannot have a completion", Full_T); 18281 end if; 18282 18283 -- Check that ancestor interfaces of private and full views are 18284 -- consistent. We omit this check for synchronized types because 18285 -- they are performed on the corresponding record type when frozen. 18286 18287 if Ada_Version >= Ada_2005 18288 and then Is_Tagged_Type (Priv_T) 18289 and then Is_Tagged_Type (Full_T) 18290 and then not Is_Concurrent_Type (Full_T) 18291 then 18292 declare 18293 Iface : Entity_Id; 18294 Priv_T_Ifaces : constant Elist_Id := New_Elmt_List; 18295 Full_T_Ifaces : constant Elist_Id := New_Elmt_List; 18296 18297 begin 18298 Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces); 18299 Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces); 18300 18301 -- Ada 2005 (AI-251): The partial view shall be a descendant of 18302 -- an interface type if and only if the full type is descendant 18303 -- of the interface type (AARM 7.3 (7.3/2)). 18304 18305 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); 18306 18307 if Present (Iface) then 18308 Error_Msg_NE 18309 ("interface & not implemented by full type " & 18310 "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); 18311 end if; 18312 18313 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); 18314 18315 if Present (Iface) then 18316 Error_Msg_NE 18317 ("interface & not implemented by partial view " & 18318 "(RM-2005 7.3 (7.3/2))", Full_T, Iface); 18319 end if; 18320 end; 18321 end if; 18322 18323 if Is_Tagged_Type (Priv_T) 18324 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 18325 and then Is_Derived_Type (Full_T) 18326 then 18327 Priv_Parent := Etype (Priv_T); 18328 18329 -- The full view of a private extension may have been transformed 18330 -- into an unconstrained derived type declaration and a subtype 18331 -- declaration (see build_derived_record_type for details). 18332 18333 if Nkind (N) = N_Subtype_Declaration then 18334 Full_Indic := Subtype_Indication (N); 18335 Full_Parent := Etype (Base_Type (Full_T)); 18336 else 18337 Full_Indic := Subtype_Indication (Type_Definition (N)); 18338 Full_Parent := Etype (Full_T); 18339 end if; 18340 18341 -- Check that the parent type of the full type is a descendant of 18342 -- the ancestor subtype given in the private extension. If either 18343 -- entity has an Etype equal to Any_Type then we had some previous 18344 -- error situation [7.3(8)]. 18345 18346 if Priv_Parent = Any_Type or else Full_Parent = Any_Type then 18347 return; 18348 18349 -- Ada 2005 (AI-251): Interfaces in the full-typ can be given in 18350 -- any order. Therefore we don't have to check that its parent must 18351 -- be a descendant of the parent of the private type declaration. 18352 18353 elsif Is_Interface (Priv_Parent) 18354 and then Is_Interface (Full_Parent) 18355 then 18356 null; 18357 18358 -- Ada 2005 (AI-251): If the parent of the private type declaration 18359 -- is an interface there is no need to check that it is an ancestor 18360 -- of the associated full type declaration. The required tests for 18361 -- this case are performed by Build_Derived_Record_Type. 18362 18363 elsif not Is_Interface (Base_Type (Priv_Parent)) 18364 and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) 18365 then 18366 Error_Msg_N 18367 ("parent of full type must descend from parent" 18368 & " of private extension", Full_Indic); 18369 18370 -- First check a formal restriction, and then proceed with checking 18371 -- Ada rules. Since the formal restriction is not a serious error, we 18372 -- don't prevent further error detection for this check, hence the 18373 -- ELSE. 18374 18375 else 18376 18377 -- In formal mode, when completing a private extension the type 18378 -- named in the private part must be exactly the same as that 18379 -- named in the visible part. 18380 18381 if Priv_Parent /= Full_Parent then 18382 Error_Msg_Name_1 := Chars (Priv_Parent); 18383 Check_SPARK_Restriction ("% expected", Full_Indic); 18384 end if; 18385 18386 -- Check the rules of 7.3(10): if the private extension inherits 18387 -- known discriminants, then the full type must also inherit those 18388 -- discriminants from the same (ancestor) type, and the parent 18389 -- subtype of the full type must be constrained if and only if 18390 -- the ancestor subtype of the private extension is constrained. 18391 18392 if No (Discriminant_Specifications (Parent (Priv_T))) 18393 and then not Has_Unknown_Discriminants (Priv_T) 18394 and then Has_Discriminants (Base_Type (Priv_Parent)) 18395 then 18396 declare 18397 Priv_Indic : constant Node_Id := 18398 Subtype_Indication (Parent (Priv_T)); 18399 18400 Priv_Constr : constant Boolean := 18401 Is_Constrained (Priv_Parent) 18402 or else 18403 Nkind (Priv_Indic) = N_Subtype_Indication 18404 or else 18405 Is_Constrained (Entity (Priv_Indic)); 18406 18407 Full_Constr : constant Boolean := 18408 Is_Constrained (Full_Parent) 18409 or else 18410 Nkind (Full_Indic) = N_Subtype_Indication 18411 or else 18412 Is_Constrained (Entity (Full_Indic)); 18413 18414 Priv_Discr : Entity_Id; 18415 Full_Discr : Entity_Id; 18416 18417 begin 18418 Priv_Discr := First_Discriminant (Priv_Parent); 18419 Full_Discr := First_Discriminant (Full_Parent); 18420 while Present (Priv_Discr) and then Present (Full_Discr) loop 18421 if Original_Record_Component (Priv_Discr) = 18422 Original_Record_Component (Full_Discr) 18423 or else 18424 Corresponding_Discriminant (Priv_Discr) = 18425 Corresponding_Discriminant (Full_Discr) 18426 then 18427 null; 18428 else 18429 exit; 18430 end if; 18431 18432 Next_Discriminant (Priv_Discr); 18433 Next_Discriminant (Full_Discr); 18434 end loop; 18435 18436 if Present (Priv_Discr) or else Present (Full_Discr) then 18437 Error_Msg_N 18438 ("full view must inherit discriminants of the parent" 18439 & " type used in the private extension", Full_Indic); 18440 18441 elsif Priv_Constr and then not Full_Constr then 18442 Error_Msg_N 18443 ("parent subtype of full type must be constrained", 18444 Full_Indic); 18445 18446 elsif Full_Constr and then not Priv_Constr then 18447 Error_Msg_N 18448 ("parent subtype of full type must be unconstrained", 18449 Full_Indic); 18450 end if; 18451 end; 18452 18453 -- Check the rules of 7.3(12): if a partial view has neither 18454 -- known or unknown discriminants, then the full type 18455 -- declaration shall define a definite subtype. 18456 18457 elsif not Has_Unknown_Discriminants (Priv_T) 18458 and then not Has_Discriminants (Priv_T) 18459 and then not Is_Constrained (Full_T) 18460 then 18461 Error_Msg_N 18462 ("full view must define a constrained type if partial view" 18463 & " has no discriminants", Full_T); 18464 end if; 18465 18466 -- ??????? Do we implement the following properly ????? 18467 -- If the ancestor subtype of a private extension has constrained 18468 -- discriminants, then the parent subtype of the full view shall 18469 -- impose a statically matching constraint on those discriminants 18470 -- [7.3(13)]. 18471 end if; 18472 18473 else 18474 -- For untagged types, verify that a type without discriminants is 18475 -- not completed with an unconstrained type. A separate error message 18476 -- is produced if the full type has defaulted discriminants. 18477 18478 if not Is_Indefinite_Subtype (Priv_T) 18479 and then Is_Indefinite_Subtype (Full_T) 18480 then 18481 Error_Msg_Sloc := Sloc (Parent (Priv_T)); 18482 Error_Msg_NE 18483 ("full view of& not compatible with declaration#", 18484 Full_T, Priv_T); 18485 18486 if not Is_Tagged_Type (Full_T) then 18487 Error_Msg_N 18488 ("\one is constrained, the other unconstrained", Full_T); 18489 end if; 18490 end if; 18491 end if; 18492 18493 -- AI-419: verify that the use of "limited" is consistent 18494 18495 declare 18496 Orig_Decl : constant Node_Id := Original_Node (N); 18497 18498 begin 18499 if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 18500 and then not Limited_Present (Parent (Priv_T)) 18501 and then not Synchronized_Present (Parent (Priv_T)) 18502 and then Nkind (Orig_Decl) = N_Full_Type_Declaration 18503 and then Nkind 18504 (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition 18505 and then Limited_Present (Type_Definition (Orig_Decl)) 18506 then 18507 Error_Msg_N 18508 ("full view of non-limited extension cannot be limited", N); 18509 end if; 18510 end; 18511 18512 -- Ada 2005 (AI-443): A synchronized private extension must be 18513 -- completed by a task or protected type. 18514 18515 if Ada_Version >= Ada_2005 18516 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 18517 and then Synchronized_Present (Parent (Priv_T)) 18518 and then not Is_Concurrent_Type (Full_T) 18519 then 18520 Error_Msg_N ("full view of synchronized extension must " & 18521 "be synchronized type", N); 18522 end if; 18523 18524 -- Ada 2005 AI-363: if the full view has discriminants with 18525 -- defaults, it is illegal to declare constrained access subtypes 18526 -- whose designated type is the current type. This allows objects 18527 -- of the type that are declared in the heap to be unconstrained. 18528 18529 if not Has_Unknown_Discriminants (Priv_T) 18530 and then not Has_Discriminants (Priv_T) 18531 and then Has_Discriminants (Full_T) 18532 and then 18533 Present (Discriminant_Default_Value (First_Discriminant (Full_T))) 18534 then 18535 Set_Has_Constrained_Partial_View (Full_T); 18536 Set_Has_Constrained_Partial_View (Priv_T); 18537 end if; 18538 18539 -- Create a full declaration for all its subtypes recorded in 18540 -- Private_Dependents and swap them similarly to the base type. These 18541 -- are subtypes that have been define before the full declaration of 18542 -- the private type. We also swap the entry in Private_Dependents list 18543 -- so we can properly restore the private view on exit from the scope. 18544 18545 declare 18546 Priv_Elmt : Elmt_Id; 18547 Priv : Entity_Id; 18548 Full : Entity_Id; 18549 18550 begin 18551 Priv_Elmt := First_Elmt (Private_Dependents (Priv_T)); 18552 while Present (Priv_Elmt) loop 18553 Priv := Node (Priv_Elmt); 18554 18555 if Ekind_In (Priv, E_Private_Subtype, 18556 E_Limited_Private_Subtype, 18557 E_Record_Subtype_With_Private) 18558 then 18559 Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); 18560 Set_Is_Itype (Full); 18561 Set_Parent (Full, Parent (Priv)); 18562 Set_Associated_Node_For_Itype (Full, N); 18563 18564 -- Now we need to complete the private subtype, but since the 18565 -- base type has already been swapped, we must also swap the 18566 -- subtypes (and thus, reverse the arguments in the call to 18567 -- Complete_Private_Subtype). 18568 18569 Copy_And_Swap (Priv, Full); 18570 Complete_Private_Subtype (Full, Priv, Full_T, N); 18571 Replace_Elmt (Priv_Elmt, Full); 18572 end if; 18573 18574 Next_Elmt (Priv_Elmt); 18575 end loop; 18576 end; 18577 18578 -- If the private view was tagged, copy the new primitive operations 18579 -- from the private view to the full view. 18580 18581 if Is_Tagged_Type (Full_T) then 18582 declare 18583 Disp_Typ : Entity_Id; 18584 Full_List : Elist_Id; 18585 Prim : Entity_Id; 18586 Prim_Elmt : Elmt_Id; 18587 Priv_List : Elist_Id; 18588 18589 function Contains 18590 (E : Entity_Id; 18591 L : Elist_Id) return Boolean; 18592 -- Determine whether list L contains element E 18593 18594 -------------- 18595 -- Contains -- 18596 -------------- 18597 18598 function Contains 18599 (E : Entity_Id; 18600 L : Elist_Id) return Boolean 18601 is 18602 List_Elmt : Elmt_Id; 18603 18604 begin 18605 List_Elmt := First_Elmt (L); 18606 while Present (List_Elmt) loop 18607 if Node (List_Elmt) = E then 18608 return True; 18609 end if; 18610 18611 Next_Elmt (List_Elmt); 18612 end loop; 18613 18614 return False; 18615 end Contains; 18616 18617 -- Start of processing 18618 18619 begin 18620 if Is_Tagged_Type (Priv_T) then 18621 Priv_List := Primitive_Operations (Priv_T); 18622 Prim_Elmt := First_Elmt (Priv_List); 18623 18624 -- In the case of a concurrent type completing a private tagged 18625 -- type, primitives may have been declared in between the two 18626 -- views. These subprograms need to be wrapped the same way 18627 -- entries and protected procedures are handled because they 18628 -- cannot be directly shared by the two views. 18629 18630 if Is_Concurrent_Type (Full_T) then 18631 declare 18632 Conc_Typ : constant Entity_Id := 18633 Corresponding_Record_Type (Full_T); 18634 Curr_Nod : Node_Id := Parent (Conc_Typ); 18635 Wrap_Spec : Node_Id; 18636 18637 begin 18638 while Present (Prim_Elmt) loop 18639 Prim := Node (Prim_Elmt); 18640 18641 if Comes_From_Source (Prim) 18642 and then not Is_Abstract_Subprogram (Prim) 18643 then 18644 Wrap_Spec := 18645 Make_Subprogram_Declaration (Sloc (Prim), 18646 Specification => 18647 Build_Wrapper_Spec 18648 (Subp_Id => Prim, 18649 Obj_Typ => Conc_Typ, 18650 Formals => 18651 Parameter_Specifications ( 18652 Parent (Prim)))); 18653 18654 Insert_After (Curr_Nod, Wrap_Spec); 18655 Curr_Nod := Wrap_Spec; 18656 18657 Analyze (Wrap_Spec); 18658 end if; 18659 18660 Next_Elmt (Prim_Elmt); 18661 end loop; 18662 18663 return; 18664 end; 18665 18666 -- For non-concurrent types, transfer explicit primitives, but 18667 -- omit those inherited from the parent of the private view 18668 -- since they will be re-inherited later on. 18669 18670 else 18671 Full_List := Primitive_Operations (Full_T); 18672 18673 while Present (Prim_Elmt) loop 18674 Prim := Node (Prim_Elmt); 18675 18676 if Comes_From_Source (Prim) 18677 and then not Contains (Prim, Full_List) 18678 then 18679 Append_Elmt (Prim, Full_List); 18680 end if; 18681 18682 Next_Elmt (Prim_Elmt); 18683 end loop; 18684 end if; 18685 18686 -- Untagged private view 18687 18688 else 18689 Full_List := Primitive_Operations (Full_T); 18690 18691 -- In this case the partial view is untagged, so here we locate 18692 -- all of the earlier primitives that need to be treated as 18693 -- dispatching (those that appear between the two views). Note 18694 -- that these additional operations must all be new operations 18695 -- (any earlier operations that override inherited operations 18696 -- of the full view will already have been inserted in the 18697 -- primitives list, marked by Check_Operation_From_Private_View 18698 -- as dispatching. Note that implicit "/=" operators are 18699 -- excluded from being added to the primitives list since they 18700 -- shouldn't be treated as dispatching (tagged "/=" is handled 18701 -- specially). 18702 18703 Prim := Next_Entity (Full_T); 18704 while Present (Prim) and then Prim /= Priv_T loop 18705 if Ekind_In (Prim, E_Procedure, E_Function) then 18706 Disp_Typ := Find_Dispatching_Type (Prim); 18707 18708 if Disp_Typ = Full_T 18709 and then (Chars (Prim) /= Name_Op_Ne 18710 or else Comes_From_Source (Prim)) 18711 then 18712 Check_Controlling_Formals (Full_T, Prim); 18713 18714 if not Is_Dispatching_Operation (Prim) then 18715 Append_Elmt (Prim, Full_List); 18716 Set_Is_Dispatching_Operation (Prim, True); 18717 Set_DT_Position (Prim, No_Uint); 18718 end if; 18719 18720 elsif Is_Dispatching_Operation (Prim) 18721 and then Disp_Typ /= Full_T 18722 then 18723 18724 -- Verify that it is not otherwise controlled by a 18725 -- formal or a return value of type T. 18726 18727 Check_Controlling_Formals (Disp_Typ, Prim); 18728 end if; 18729 end if; 18730 18731 Next_Entity (Prim); 18732 end loop; 18733 end if; 18734 18735 -- For the tagged case, the two views can share the same primitive 18736 -- operations list and the same class-wide type. Update attributes 18737 -- of the class-wide type which depend on the full declaration. 18738 18739 if Is_Tagged_Type (Priv_T) then 18740 Set_Direct_Primitive_Operations (Priv_T, Full_List); 18741 Set_Class_Wide_Type 18742 (Base_Type (Full_T), Class_Wide_Type (Priv_T)); 18743 18744 Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T)); 18745 end if; 18746 end; 18747 end if; 18748 18749 -- Ada 2005 AI 161: Check preelaborable initialization consistency 18750 18751 if Known_To_Have_Preelab_Init (Priv_T) then 18752 18753 -- Case where there is a pragma Preelaborable_Initialization. We 18754 -- always allow this in predefined units, which is a bit of a kludge, 18755 -- but it means we don't have to struggle to meet the requirements in 18756 -- the RM for having Preelaborable Initialization. Otherwise we 18757 -- require that the type meets the RM rules. But we can't check that 18758 -- yet, because of the rule about overriding Initialize, so we simply 18759 -- set a flag that will be checked at freeze time. 18760 18761 if not In_Predefined_Unit (Full_T) then 18762 Set_Must_Have_Preelab_Init (Full_T); 18763 end if; 18764 end if; 18765 18766 -- If pragma CPP_Class was applied to the private type declaration, 18767 -- propagate it now to the full type declaration. 18768 18769 if Is_CPP_Class (Priv_T) then 18770 Set_Is_CPP_Class (Full_T); 18771 Set_Convention (Full_T, Convention_CPP); 18772 18773 -- Check that components of imported CPP types do not have default 18774 -- expressions. 18775 18776 Check_CPP_Type_Has_No_Defaults (Full_T); 18777 end if; 18778 18779 -- If the private view has user specified stream attributes, then so has 18780 -- the full view. 18781 18782 -- Why the test, how could these flags be already set in Full_T ??? 18783 18784 if Has_Specified_Stream_Read (Priv_T) then 18785 Set_Has_Specified_Stream_Read (Full_T); 18786 end if; 18787 18788 if Has_Specified_Stream_Write (Priv_T) then 18789 Set_Has_Specified_Stream_Write (Full_T); 18790 end if; 18791 18792 if Has_Specified_Stream_Input (Priv_T) then 18793 Set_Has_Specified_Stream_Input (Full_T); 18794 end if; 18795 18796 if Has_Specified_Stream_Output (Priv_T) then 18797 Set_Has_Specified_Stream_Output (Full_T); 18798 end if; 18799 18800 -- Propagate invariants to full type 18801 18802 if Has_Invariants (Priv_T) then 18803 Set_Has_Invariants (Full_T); 18804 Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T)); 18805 end if; 18806 18807 if Has_Inheritable_Invariants (Priv_T) then 18808 Set_Has_Inheritable_Invariants (Full_T); 18809 end if; 18810 18811 -- Propagate predicates to full type, and predicate function if already 18812 -- defined. It is not clear that this can actually happen? the partial 18813 -- view cannot be frozen yet, and the predicate function has not been 18814 -- built. Still it is a cheap check and seems safer to make it. 18815 18816 if Has_Predicates (Priv_T) then 18817 if Present (Predicate_Function (Priv_T)) then 18818 Set_Predicate_Function (Full_T, Predicate_Function (Priv_T)); 18819 end if; 18820 18821 Set_Has_Predicates (Full_T); 18822 end if; 18823 end Process_Full_View; 18824 18825 ----------------------------------- 18826 -- Process_Incomplete_Dependents -- 18827 ----------------------------------- 18828 18829 procedure Process_Incomplete_Dependents 18830 (N : Node_Id; 18831 Full_T : Entity_Id; 18832 Inc_T : Entity_Id) 18833 is 18834 Inc_Elmt : Elmt_Id; 18835 Priv_Dep : Entity_Id; 18836 New_Subt : Entity_Id; 18837 18838 Disc_Constraint : Elist_Id; 18839 18840 begin 18841 if No (Private_Dependents (Inc_T)) then 18842 return; 18843 end if; 18844 18845 -- Itypes that may be generated by the completion of an incomplete 18846 -- subtype are not used by the back-end and not attached to the tree. 18847 -- They are created only for constraint-checking purposes. 18848 18849 Inc_Elmt := First_Elmt (Private_Dependents (Inc_T)); 18850 while Present (Inc_Elmt) loop 18851 Priv_Dep := Node (Inc_Elmt); 18852 18853 if Ekind (Priv_Dep) = E_Subprogram_Type then 18854 18855 -- An Access_To_Subprogram type may have a return type or a 18856 -- parameter type that is incomplete. Replace with the full view. 18857 18858 if Etype (Priv_Dep) = Inc_T then 18859 Set_Etype (Priv_Dep, Full_T); 18860 end if; 18861 18862 declare 18863 Formal : Entity_Id; 18864 18865 begin 18866 Formal := First_Formal (Priv_Dep); 18867 while Present (Formal) loop 18868 if Etype (Formal) = Inc_T then 18869 Set_Etype (Formal, Full_T); 18870 end if; 18871 18872 Next_Formal (Formal); 18873 end loop; 18874 end; 18875 18876 elsif Is_Overloadable (Priv_Dep) then 18877 18878 -- If a subprogram in the incomplete dependents list is primitive 18879 -- for a tagged full type then mark it as a dispatching operation, 18880 -- check whether it overrides an inherited subprogram, and check 18881 -- restrictions on its controlling formals. Note that a protected 18882 -- operation is never dispatching: only its wrapper operation 18883 -- (which has convention Ada) is. 18884 18885 if Is_Tagged_Type (Full_T) 18886 and then Is_Primitive (Priv_Dep) 18887 and then Convention (Priv_Dep) /= Convention_Protected 18888 then 18889 Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T); 18890 Set_Is_Dispatching_Operation (Priv_Dep); 18891 Check_Controlling_Formals (Full_T, Priv_Dep); 18892 end if; 18893 18894 elsif Ekind (Priv_Dep) = E_Subprogram_Body then 18895 18896 -- Can happen during processing of a body before the completion 18897 -- of a TA type. Ignore, because spec is also on dependent list. 18898 18899 return; 18900 18901 -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a 18902 -- corresponding subtype of the full view. 18903 18904 elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then 18905 Set_Subtype_Indication 18906 (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep))); 18907 Set_Etype (Priv_Dep, Full_T); 18908 Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); 18909 Set_Analyzed (Parent (Priv_Dep), False); 18910 18911 -- Reanalyze the declaration, suppressing the call to 18912 -- Enter_Name to avoid duplicate names. 18913 18914 Analyze_Subtype_Declaration 18915 (N => Parent (Priv_Dep), 18916 Skip => True); 18917 18918 -- Dependent is a subtype 18919 18920 else 18921 -- We build a new subtype indication using the full view of the 18922 -- incomplete parent. The discriminant constraints have been 18923 -- elaborated already at the point of the subtype declaration. 18924 18925 New_Subt := Create_Itype (E_Void, N); 18926 18927 if Has_Discriminants (Full_T) then 18928 Disc_Constraint := Discriminant_Constraint (Priv_Dep); 18929 else 18930 Disc_Constraint := No_Elist; 18931 end if; 18932 18933 Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N); 18934 Set_Full_View (Priv_Dep, New_Subt); 18935 end if; 18936 18937 Next_Elmt (Inc_Elmt); 18938 end loop; 18939 end Process_Incomplete_Dependents; 18940 18941 -------------------------------- 18942 -- Process_Range_Expr_In_Decl -- 18943 -------------------------------- 18944 18945 procedure Process_Range_Expr_In_Decl 18946 (R : Node_Id; 18947 T : Entity_Id; 18948 Check_List : List_Id := Empty_List; 18949 R_Check_Off : Boolean := False; 18950 In_Iter_Schm : Boolean := False) 18951 is 18952 Lo, Hi : Node_Id; 18953 R_Checks : Check_Result; 18954 Insert_Node : Node_Id; 18955 Def_Id : Entity_Id; 18956 18957 begin 18958 Analyze_And_Resolve (R, Base_Type (T)); 18959 18960 if Nkind (R) = N_Range then 18961 18962 -- In SPARK, all ranges should be static, with the exception of the 18963 -- discrete type definition of a loop parameter specification. 18964 18965 if not In_Iter_Schm 18966 and then not Is_Static_Range (R) 18967 then 18968 Check_SPARK_Restriction ("range should be static", R); 18969 end if; 18970 18971 Lo := Low_Bound (R); 18972 Hi := High_Bound (R); 18973 18974 -- We need to ensure validity of the bounds here, because if we 18975 -- go ahead and do the expansion, then the expanded code will get 18976 -- analyzed with range checks suppressed and we miss the check. 18977 -- Validity checks on the range of a quantified expression are 18978 -- delayed until the construct is transformed into a loop. 18979 18980 if Nkind (Parent (R)) /= N_Loop_Parameter_Specification 18981 or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression 18982 then 18983 Validity_Check_Range (R); 18984 end if; 18985 18986 -- If there were errors in the declaration, try and patch up some 18987 -- common mistakes in the bounds. The cases handled are literals 18988 -- which are Integer where the expected type is Real and vice versa. 18989 -- These corrections allow the compilation process to proceed further 18990 -- along since some basic assumptions of the format of the bounds 18991 -- are guaranteed. 18992 18993 if Etype (R) = Any_Type then 18994 if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then 18995 Rewrite (Lo, 18996 Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo)))); 18997 18998 elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then 18999 Rewrite (Hi, 19000 Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi)))); 19001 19002 elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then 19003 Rewrite (Lo, 19004 Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo)))); 19005 19006 elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then 19007 Rewrite (Hi, 19008 Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi)))); 19009 end if; 19010 19011 Set_Etype (Lo, T); 19012 Set_Etype (Hi, T); 19013 end if; 19014 19015 -- If the bounds of the range have been mistakenly given as string 19016 -- literals (perhaps in place of character literals), then an error 19017 -- has already been reported, but we rewrite the string literal as a 19018 -- bound of the range's type to avoid blowups in later processing 19019 -- that looks at static values. 19020 19021 if Nkind (Lo) = N_String_Literal then 19022 Rewrite (Lo, 19023 Make_Attribute_Reference (Sloc (Lo), 19024 Attribute_Name => Name_First, 19025 Prefix => New_Occurrence_Of (T, Sloc (Lo)))); 19026 Analyze_And_Resolve (Lo); 19027 end if; 19028 19029 if Nkind (Hi) = N_String_Literal then 19030 Rewrite (Hi, 19031 Make_Attribute_Reference (Sloc (Hi), 19032 Attribute_Name => Name_First, 19033 Prefix => New_Occurrence_Of (T, Sloc (Hi)))); 19034 Analyze_And_Resolve (Hi); 19035 end if; 19036 19037 -- If bounds aren't scalar at this point then exit, avoiding 19038 -- problems with further processing of the range in this procedure. 19039 19040 if not Is_Scalar_Type (Etype (Lo)) then 19041 return; 19042 end if; 19043 19044 -- Resolve (actually Sem_Eval) has checked that the bounds are in 19045 -- then range of the base type. Here we check whether the bounds 19046 -- are in the range of the subtype itself. Note that if the bounds 19047 -- represent the null range the Constraint_Error exception should 19048 -- not be raised. 19049 19050 -- ??? The following code should be cleaned up as follows 19051 19052 -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it 19053 -- is done in the call to Range_Check (R, T); below 19054 19055 -- 2. The use of R_Check_Off should be investigated and possibly 19056 -- removed, this would clean up things a bit. 19057 19058 if Is_Null_Range (Lo, Hi) then 19059 null; 19060 19061 else 19062 -- Capture values of bounds and generate temporaries for them 19063 -- if needed, before applying checks, since checks may cause 19064 -- duplication of the expression without forcing evaluation. 19065 19066 -- The forced evaluation removes side effects from expressions, 19067 -- which should occur also in GNATprove mode. Otherwise, we end up 19068 -- with unexpected insertions of actions at places where this is 19069 -- not supposed to occur, e.g. on default parameters of a call. 19070 19071 if Expander_Active or GNATprove_Mode then 19072 Force_Evaluation (Lo); 19073 Force_Evaluation (Hi); 19074 end if; 19075 19076 -- We use a flag here instead of suppressing checks on the 19077 -- type because the type we check against isn't necessarily 19078 -- the place where we put the check. 19079 19080 if not R_Check_Off then 19081 R_Checks := Get_Range_Checks (R, T); 19082 19083 -- Look up tree to find an appropriate insertion point. We 19084 -- can't just use insert_actions because later processing 19085 -- depends on the insertion node. Prior to Ada 2012 the 19086 -- insertion point could only be a declaration or a loop, but 19087 -- quantified expressions can appear within any context in an 19088 -- expression, and the insertion point can be any statement, 19089 -- pragma, or declaration. 19090 19091 Insert_Node := Parent (R); 19092 while Present (Insert_Node) loop 19093 exit when 19094 Nkind (Insert_Node) in N_Declaration 19095 and then 19096 not Nkind_In 19097 (Insert_Node, N_Component_Declaration, 19098 N_Loop_Parameter_Specification, 19099 N_Function_Specification, 19100 N_Procedure_Specification); 19101 19102 exit when Nkind (Insert_Node) in N_Later_Decl_Item 19103 or else Nkind (Insert_Node) in 19104 N_Statement_Other_Than_Procedure_Call 19105 or else Nkind_In (Insert_Node, N_Procedure_Call_Statement, 19106 N_Pragma); 19107 19108 Insert_Node := Parent (Insert_Node); 19109 end loop; 19110 19111 -- Why would Type_Decl not be present??? Without this test, 19112 -- short regression tests fail. 19113 19114 if Present (Insert_Node) then 19115 19116 -- Case of loop statement. Verify that the range is part 19117 -- of the subtype indication of the iteration scheme. 19118 19119 if Nkind (Insert_Node) = N_Loop_Statement then 19120 declare 19121 Indic : Node_Id; 19122 19123 begin 19124 Indic := Parent (R); 19125 while Present (Indic) 19126 and then Nkind (Indic) /= N_Subtype_Indication 19127 loop 19128 Indic := Parent (Indic); 19129 end loop; 19130 19131 if Present (Indic) then 19132 Def_Id := Etype (Subtype_Mark (Indic)); 19133 19134 Insert_Range_Checks 19135 (R_Checks, 19136 Insert_Node, 19137 Def_Id, 19138 Sloc (Insert_Node), 19139 R, 19140 Do_Before => True); 19141 end if; 19142 end; 19143 19144 -- Insertion before a declaration. If the declaration 19145 -- includes discriminants, the list of applicable checks 19146 -- is given by the caller. 19147 19148 elsif Nkind (Insert_Node) in N_Declaration then 19149 Def_Id := Defining_Identifier (Insert_Node); 19150 19151 if (Ekind (Def_Id) = E_Record_Type 19152 and then Depends_On_Discriminant (R)) 19153 or else 19154 (Ekind (Def_Id) = E_Protected_Type 19155 and then Has_Discriminants (Def_Id)) 19156 then 19157 Append_Range_Checks 19158 (R_Checks, 19159 Check_List, Def_Id, Sloc (Insert_Node), R); 19160 19161 else 19162 Insert_Range_Checks 19163 (R_Checks, 19164 Insert_Node, Def_Id, Sloc (Insert_Node), R); 19165 19166 end if; 19167 19168 -- Insertion before a statement. Range appears in the 19169 -- context of a quantified expression. Insertion will 19170 -- take place when expression is expanded. 19171 19172 else 19173 null; 19174 end if; 19175 end if; 19176 end if; 19177 end if; 19178 19179 -- Case of other than an explicit N_Range node 19180 19181 -- The forced evaluation removes side effects from expressions, which 19182 -- should occur also in GNATprove mode. Otherwise, we end up with 19183 -- unexpected insertions of actions at places where this is not 19184 -- supposed to occur, e.g. on default parameters of a call. 19185 19186 elsif Expander_Active or GNATprove_Mode then 19187 Get_Index_Bounds (R, Lo, Hi); 19188 Force_Evaluation (Lo); 19189 Force_Evaluation (Hi); 19190 end if; 19191 end Process_Range_Expr_In_Decl; 19192 19193 -------------------------------------- 19194 -- Process_Real_Range_Specification -- 19195 -------------------------------------- 19196 19197 procedure Process_Real_Range_Specification (Def : Node_Id) is 19198 Spec : constant Node_Id := Real_Range_Specification (Def); 19199 Lo : Node_Id; 19200 Hi : Node_Id; 19201 Err : Boolean := False; 19202 19203 procedure Analyze_Bound (N : Node_Id); 19204 -- Analyze and check one bound 19205 19206 ------------------- 19207 -- Analyze_Bound -- 19208 ------------------- 19209 19210 procedure Analyze_Bound (N : Node_Id) is 19211 begin 19212 Analyze_And_Resolve (N, Any_Real); 19213 19214 if not Is_OK_Static_Expression (N) then 19215 Flag_Non_Static_Expr 19216 ("bound in real type definition is not static!", N); 19217 Err := True; 19218 end if; 19219 end Analyze_Bound; 19220 19221 -- Start of processing for Process_Real_Range_Specification 19222 19223 begin 19224 if Present (Spec) then 19225 Lo := Low_Bound (Spec); 19226 Hi := High_Bound (Spec); 19227 Analyze_Bound (Lo); 19228 Analyze_Bound (Hi); 19229 19230 -- If error, clear away junk range specification 19231 19232 if Err then 19233 Set_Real_Range_Specification (Def, Empty); 19234 end if; 19235 end if; 19236 end Process_Real_Range_Specification; 19237 19238 --------------------- 19239 -- Process_Subtype -- 19240 --------------------- 19241 19242 function Process_Subtype 19243 (S : Node_Id; 19244 Related_Nod : Node_Id; 19245 Related_Id : Entity_Id := Empty; 19246 Suffix : Character := ' ') return Entity_Id 19247 is 19248 P : Node_Id; 19249 Def_Id : Entity_Id; 19250 Error_Node : Node_Id; 19251 Full_View_Id : Entity_Id; 19252 Subtype_Mark_Id : Entity_Id; 19253 19254 May_Have_Null_Exclusion : Boolean; 19255 19256 procedure Check_Incomplete (T : Entity_Id); 19257 -- Called to verify that an incomplete type is not used prematurely 19258 19259 ---------------------- 19260 -- Check_Incomplete -- 19261 ---------------------- 19262 19263 procedure Check_Incomplete (T : Entity_Id) is 19264 begin 19265 -- Ada 2005 (AI-412): Incomplete subtypes are legal 19266 19267 if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type 19268 and then 19269 not (Ada_Version >= Ada_2005 19270 and then 19271 (Nkind (Parent (T)) = N_Subtype_Declaration 19272 or else 19273 (Nkind (Parent (T)) = N_Subtype_Indication 19274 and then Nkind (Parent (Parent (T))) = 19275 N_Subtype_Declaration))) 19276 then 19277 Error_Msg_N ("invalid use of type before its full declaration", T); 19278 end if; 19279 end Check_Incomplete; 19280 19281 -- Start of processing for Process_Subtype 19282 19283 begin 19284 -- Case of no constraints present 19285 19286 if Nkind (S) /= N_Subtype_Indication then 19287 Find_Type (S); 19288 Check_Incomplete (S); 19289 P := Parent (S); 19290 19291 -- Ada 2005 (AI-231): Static check 19292 19293 if Ada_Version >= Ada_2005 19294 and then Present (P) 19295 and then Null_Exclusion_Present (P) 19296 and then Nkind (P) /= N_Access_To_Object_Definition 19297 and then not Is_Access_Type (Entity (S)) 19298 then 19299 Error_Msg_N ("`NOT NULL` only allowed for an access type", S); 19300 end if; 19301 19302 -- The following is ugly, can't we have a range or even a flag??? 19303 19304 May_Have_Null_Exclusion := 19305 Nkind_In (P, N_Access_Definition, 19306 N_Access_Function_Definition, 19307 N_Access_Procedure_Definition, 19308 N_Access_To_Object_Definition, 19309 N_Allocator, 19310 N_Component_Definition) 19311 or else 19312 Nkind_In (P, N_Derived_Type_Definition, 19313 N_Discriminant_Specification, 19314 N_Formal_Object_Declaration, 19315 N_Object_Declaration, 19316 N_Object_Renaming_Declaration, 19317 N_Parameter_Specification, 19318 N_Subtype_Declaration); 19319 19320 -- Create an Itype that is a duplicate of Entity (S) but with the 19321 -- null-exclusion attribute. 19322 19323 if May_Have_Null_Exclusion 19324 and then Is_Access_Type (Entity (S)) 19325 and then Null_Exclusion_Present (P) 19326 19327 -- No need to check the case of an access to object definition. 19328 -- It is correct to define double not-null pointers. 19329 19330 -- Example: 19331 -- type Not_Null_Int_Ptr is not null access Integer; 19332 -- type Acc is not null access Not_Null_Int_Ptr; 19333 19334 and then Nkind (P) /= N_Access_To_Object_Definition 19335 then 19336 if Can_Never_Be_Null (Entity (S)) then 19337 case Nkind (Related_Nod) is 19338 when N_Full_Type_Declaration => 19339 if Nkind (Type_Definition (Related_Nod)) 19340 in N_Array_Type_Definition 19341 then 19342 Error_Node := 19343 Subtype_Indication 19344 (Component_Definition 19345 (Type_Definition (Related_Nod))); 19346 else 19347 Error_Node := 19348 Subtype_Indication (Type_Definition (Related_Nod)); 19349 end if; 19350 19351 when N_Subtype_Declaration => 19352 Error_Node := Subtype_Indication (Related_Nod); 19353 19354 when N_Object_Declaration => 19355 Error_Node := Object_Definition (Related_Nod); 19356 19357 when N_Component_Declaration => 19358 Error_Node := 19359 Subtype_Indication (Component_Definition (Related_Nod)); 19360 19361 when N_Allocator => 19362 Error_Node := Expression (Related_Nod); 19363 19364 when others => 19365 pragma Assert (False); 19366 Error_Node := Related_Nod; 19367 end case; 19368 19369 Error_Msg_NE 19370 ("`NOT NULL` not allowed (& already excludes null)", 19371 Error_Node, 19372 Entity (S)); 19373 end if; 19374 19375 Set_Etype (S, 19376 Create_Null_Excluding_Itype 19377 (T => Entity (S), 19378 Related_Nod => P)); 19379 Set_Entity (S, Etype (S)); 19380 end if; 19381 19382 return Entity (S); 19383 19384 -- Case of constraint present, so that we have an N_Subtype_Indication 19385 -- node (this node is created only if constraints are present). 19386 19387 else 19388 Find_Type (Subtype_Mark (S)); 19389 19390 if Nkind (Parent (S)) /= N_Access_To_Object_Definition 19391 and then not 19392 (Nkind (Parent (S)) = N_Subtype_Declaration 19393 and then Is_Itype (Defining_Identifier (Parent (S)))) 19394 then 19395 Check_Incomplete (Subtype_Mark (S)); 19396 end if; 19397 19398 P := Parent (S); 19399 Subtype_Mark_Id := Entity (Subtype_Mark (S)); 19400 19401 -- Explicit subtype declaration case 19402 19403 if Nkind (P) = N_Subtype_Declaration then 19404 Def_Id := Defining_Identifier (P); 19405 19406 -- Explicit derived type definition case 19407 19408 elsif Nkind (P) = N_Derived_Type_Definition then 19409 Def_Id := Defining_Identifier (Parent (P)); 19410 19411 -- Implicit case, the Def_Id must be created as an implicit type. 19412 -- The one exception arises in the case of concurrent types, array 19413 -- and access types, where other subsidiary implicit types may be 19414 -- created and must appear before the main implicit type. In these 19415 -- cases we leave Def_Id set to Empty as a signal that Create_Itype 19416 -- has not yet been called to create Def_Id. 19417 19418 else 19419 if Is_Array_Type (Subtype_Mark_Id) 19420 or else Is_Concurrent_Type (Subtype_Mark_Id) 19421 or else Is_Access_Type (Subtype_Mark_Id) 19422 then 19423 Def_Id := Empty; 19424 19425 -- For the other cases, we create a new unattached Itype, 19426 -- and set the indication to ensure it gets attached later. 19427 19428 else 19429 Def_Id := 19430 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 19431 end if; 19432 end if; 19433 19434 -- If the kind of constraint is invalid for this kind of type, 19435 -- then give an error, and then pretend no constraint was given. 19436 19437 if not Is_Valid_Constraint_Kind 19438 (Ekind (Subtype_Mark_Id), Nkind (Constraint (S))) 19439 then 19440 Error_Msg_N 19441 ("incorrect constraint for this kind of type", Constraint (S)); 19442 19443 Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); 19444 19445 -- Set Ekind of orphan itype, to prevent cascaded errors 19446 19447 if Present (Def_Id) then 19448 Set_Ekind (Def_Id, Ekind (Any_Type)); 19449 end if; 19450 19451 -- Make recursive call, having got rid of the bogus constraint 19452 19453 return Process_Subtype (S, Related_Nod, Related_Id, Suffix); 19454 end if; 19455 19456 -- Remaining processing depends on type. Select on Base_Type kind to 19457 -- ensure getting to the concrete type kind in the case of a private 19458 -- subtype (needed when only doing semantic analysis). 19459 19460 case Ekind (Base_Type (Subtype_Mark_Id)) is 19461 when Access_Kind => 19462 19463 -- If this is a constraint on a class-wide type, discard it. 19464 -- There is currently no way to express a partial discriminant 19465 -- constraint on a type with unknown discriminants. This is 19466 -- a pathology that the ACATS wisely decides not to test. 19467 19468 if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then 19469 if Comes_From_Source (S) then 19470 Error_Msg_N 19471 ("constraint on class-wide type ignored?", 19472 Constraint (S)); 19473 end if; 19474 19475 if Nkind (P) = N_Subtype_Declaration then 19476 Set_Subtype_Indication (P, 19477 New_Occurrence_Of (Subtype_Mark_Id, Sloc (S))); 19478 end if; 19479 19480 return Subtype_Mark_Id; 19481 end if; 19482 19483 Constrain_Access (Def_Id, S, Related_Nod); 19484 19485 if Expander_Active 19486 and then Is_Itype (Designated_Type (Def_Id)) 19487 and then Nkind (Related_Nod) = N_Subtype_Declaration 19488 and then not Is_Incomplete_Type (Designated_Type (Def_Id)) 19489 then 19490 Build_Itype_Reference 19491 (Designated_Type (Def_Id), Related_Nod); 19492 end if; 19493 19494 when Array_Kind => 19495 Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); 19496 19497 when Decimal_Fixed_Point_Kind => 19498 Constrain_Decimal (Def_Id, S); 19499 19500 when Enumeration_Kind => 19501 Constrain_Enumeration (Def_Id, S); 19502 19503 when Ordinary_Fixed_Point_Kind => 19504 Constrain_Ordinary_Fixed (Def_Id, S); 19505 19506 when Float_Kind => 19507 Constrain_Float (Def_Id, S); 19508 19509 when Integer_Kind => 19510 Constrain_Integer (Def_Id, S); 19511 19512 when E_Record_Type | 19513 E_Record_Subtype | 19514 Class_Wide_Kind | 19515 E_Incomplete_Type => 19516 Constrain_Discriminated_Type (Def_Id, S, Related_Nod); 19517 19518 if Ekind (Def_Id) = E_Incomplete_Type then 19519 Set_Private_Dependents (Def_Id, New_Elmt_List); 19520 end if; 19521 19522 when Private_Kind => 19523 Constrain_Discriminated_Type (Def_Id, S, Related_Nod); 19524 Set_Private_Dependents (Def_Id, New_Elmt_List); 19525 19526 -- In case of an invalid constraint prevent further processing 19527 -- since the type constructed is missing expected fields. 19528 19529 if Etype (Def_Id) = Any_Type then 19530 return Def_Id; 19531 end if; 19532 19533 -- If the full view is that of a task with discriminants, 19534 -- we must constrain both the concurrent type and its 19535 -- corresponding record type. Otherwise we will just propagate 19536 -- the constraint to the full view, if available. 19537 19538 if Present (Full_View (Subtype_Mark_Id)) 19539 and then Has_Discriminants (Subtype_Mark_Id) 19540 and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id)) 19541 then 19542 Full_View_Id := 19543 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 19544 19545 Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id)); 19546 Constrain_Concurrent (Full_View_Id, S, 19547 Related_Nod, Related_Id, Suffix); 19548 Set_Entity (Subtype_Mark (S), Subtype_Mark_Id); 19549 Set_Full_View (Def_Id, Full_View_Id); 19550 19551 -- Introduce an explicit reference to the private subtype, 19552 -- to prevent scope anomalies in gigi if first use appears 19553 -- in a nested context, e.g. a later function body. 19554 -- Should this be generated in other contexts than a full 19555 -- type declaration? 19556 19557 if Is_Itype (Def_Id) 19558 and then 19559 Nkind (Parent (P)) = N_Full_Type_Declaration 19560 then 19561 Build_Itype_Reference (Def_Id, Parent (P)); 19562 end if; 19563 19564 else 19565 Prepare_Private_Subtype_Completion (Def_Id, Related_Nod); 19566 end if; 19567 19568 when Concurrent_Kind => 19569 Constrain_Concurrent (Def_Id, S, 19570 Related_Nod, Related_Id, Suffix); 19571 19572 when others => 19573 Error_Msg_N ("invalid subtype mark in subtype indication", S); 19574 end case; 19575 19576 -- Size and Convention are always inherited from the base type 19577 19578 Set_Size_Info (Def_Id, (Subtype_Mark_Id)); 19579 Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); 19580 19581 return Def_Id; 19582 end if; 19583 end Process_Subtype; 19584 19585 --------------------------------------- 19586 -- Check_Anonymous_Access_Components -- 19587 --------------------------------------- 19588 19589 procedure Check_Anonymous_Access_Components 19590 (Typ_Decl : Node_Id; 19591 Typ : Entity_Id; 19592 Prev : Entity_Id; 19593 Comp_List : Node_Id) 19594 is 19595 Loc : constant Source_Ptr := Sloc (Typ_Decl); 19596 Anon_Access : Entity_Id; 19597 Acc_Def : Node_Id; 19598 Comp : Node_Id; 19599 Comp_Def : Node_Id; 19600 Decl : Node_Id; 19601 Type_Def : Node_Id; 19602 19603 procedure Build_Incomplete_Type_Declaration; 19604 -- If the record type contains components that include an access to the 19605 -- current record, then create an incomplete type declaration for the 19606 -- record, to be used as the designated type of the anonymous access. 19607 -- This is done only once, and only if there is no previous partial 19608 -- view of the type. 19609 19610 function Designates_T (Subt : Node_Id) return Boolean; 19611 -- Check whether a node designates the enclosing record type, or 'Class 19612 -- of that type 19613 19614 function Mentions_T (Acc_Def : Node_Id) return Boolean; 19615 -- Check whether an access definition includes a reference to 19616 -- the enclosing record type. The reference can be a subtype mark 19617 -- in the access definition itself, a 'Class attribute reference, or 19618 -- recursively a reference appearing in a parameter specification 19619 -- or result definition of an access_to_subprogram definition. 19620 19621 -------------------------------------- 19622 -- Build_Incomplete_Type_Declaration -- 19623 -------------------------------------- 19624 19625 procedure Build_Incomplete_Type_Declaration is 19626 Decl : Node_Id; 19627 Inc_T : Entity_Id; 19628 H : Entity_Id; 19629 19630 -- Is_Tagged indicates whether the type is tagged. It is tagged if 19631 -- it's "is new ... with record" or else "is tagged record ...". 19632 19633 Is_Tagged : constant Boolean := 19634 (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition 19635 and then 19636 Present 19637 (Record_Extension_Part (Type_Definition (Typ_Decl)))) 19638 or else 19639 (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition 19640 and then Tagged_Present (Type_Definition (Typ_Decl))); 19641 19642 begin 19643 -- If there is a previous partial view, no need to create a new one 19644 -- If the partial view, given by Prev, is incomplete, If Prev is 19645 -- a private declaration, full declaration is flagged accordingly. 19646 19647 if Prev /= Typ then 19648 if Is_Tagged then 19649 Make_Class_Wide_Type (Prev); 19650 Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); 19651 Set_Etype (Class_Wide_Type (Typ), Typ); 19652 end if; 19653 19654 return; 19655 19656 elsif Has_Private_Declaration (Typ) then 19657 19658 -- If we refer to T'Class inside T, and T is the completion of a 19659 -- private type, then we need to make sure the class-wide type 19660 -- exists. 19661 19662 if Is_Tagged then 19663 Make_Class_Wide_Type (Typ); 19664 end if; 19665 19666 return; 19667 19668 -- If there was a previous anonymous access type, the incomplete 19669 -- type declaration will have been created already. 19670 19671 elsif Present (Current_Entity (Typ)) 19672 and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type 19673 and then Full_View (Current_Entity (Typ)) = Typ 19674 then 19675 if Is_Tagged 19676 and then Comes_From_Source (Current_Entity (Typ)) 19677 and then not Is_Tagged_Type (Current_Entity (Typ)) 19678 then 19679 Make_Class_Wide_Type (Typ); 19680 Error_Msg_N 19681 ("incomplete view of tagged type should be declared tagged??", 19682 Parent (Current_Entity (Typ))); 19683 end if; 19684 return; 19685 19686 else 19687 Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); 19688 Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); 19689 19690 -- Type has already been inserted into the current scope. Remove 19691 -- it, and add incomplete declaration for type, so that subsequent 19692 -- anonymous access types can use it. The entity is unchained from 19693 -- the homonym list and from immediate visibility. After analysis, 19694 -- the entity in the incomplete declaration becomes immediately 19695 -- visible in the record declaration that follows. 19696 19697 H := Current_Entity (Typ); 19698 19699 if H = Typ then 19700 Set_Name_Entity_Id (Chars (Typ), Homonym (Typ)); 19701 else 19702 while Present (H) 19703 and then Homonym (H) /= Typ 19704 loop 19705 H := Homonym (Typ); 19706 end loop; 19707 19708 Set_Homonym (H, Homonym (Typ)); 19709 end if; 19710 19711 Insert_Before (Typ_Decl, Decl); 19712 Analyze (Decl); 19713 Set_Full_View (Inc_T, Typ); 19714 19715 if Is_Tagged then 19716 19717 -- Create a common class-wide type for both views, and set the 19718 -- Etype of the class-wide type to the full view. 19719 19720 Make_Class_Wide_Type (Inc_T); 19721 Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); 19722 Set_Etype (Class_Wide_Type (Typ), Typ); 19723 end if; 19724 end if; 19725 end Build_Incomplete_Type_Declaration; 19726 19727 ------------------ 19728 -- Designates_T -- 19729 ------------------ 19730 19731 function Designates_T (Subt : Node_Id) return Boolean is 19732 Type_Id : constant Name_Id := Chars (Typ); 19733 19734 function Names_T (Nam : Node_Id) return Boolean; 19735 -- The record type has not been introduced in the current scope 19736 -- yet, so we must examine the name of the type itself, either 19737 -- an identifier T, or an expanded name of the form P.T, where 19738 -- P denotes the current scope. 19739 19740 ------------- 19741 -- Names_T -- 19742 ------------- 19743 19744 function Names_T (Nam : Node_Id) return Boolean is 19745 begin 19746 if Nkind (Nam) = N_Identifier then 19747 return Chars (Nam) = Type_Id; 19748 19749 elsif Nkind (Nam) = N_Selected_Component then 19750 if Chars (Selector_Name (Nam)) = Type_Id then 19751 if Nkind (Prefix (Nam)) = N_Identifier then 19752 return Chars (Prefix (Nam)) = Chars (Current_Scope); 19753 19754 elsif Nkind (Prefix (Nam)) = N_Selected_Component then 19755 return Chars (Selector_Name (Prefix (Nam))) = 19756 Chars (Current_Scope); 19757 else 19758 return False; 19759 end if; 19760 19761 else 19762 return False; 19763 end if; 19764 19765 else 19766 return False; 19767 end if; 19768 end Names_T; 19769 19770 -- Start of processing for Designates_T 19771 19772 begin 19773 if Nkind (Subt) = N_Identifier then 19774 return Chars (Subt) = Type_Id; 19775 19776 -- Reference can be through an expanded name which has not been 19777 -- analyzed yet, and which designates enclosing scopes. 19778 19779 elsif Nkind (Subt) = N_Selected_Component then 19780 if Names_T (Subt) then 19781 return True; 19782 19783 -- Otherwise it must denote an entity that is already visible. 19784 -- The access definition may name a subtype of the enclosing 19785 -- type, if there is a previous incomplete declaration for it. 19786 19787 else 19788 Find_Selected_Component (Subt); 19789 return 19790 Is_Entity_Name (Subt) 19791 and then Scope (Entity (Subt)) = Current_Scope 19792 and then 19793 (Chars (Base_Type (Entity (Subt))) = Type_Id 19794 or else 19795 (Is_Class_Wide_Type (Entity (Subt)) 19796 and then 19797 Chars (Etype (Base_Type (Entity (Subt)))) = 19798 Type_Id)); 19799 end if; 19800 19801 -- A reference to the current type may appear as the prefix of 19802 -- a 'Class attribute. 19803 19804 elsif Nkind (Subt) = N_Attribute_Reference 19805 and then Attribute_Name (Subt) = Name_Class 19806 then 19807 return Names_T (Prefix (Subt)); 19808 19809 else 19810 return False; 19811 end if; 19812 end Designates_T; 19813 19814 ---------------- 19815 -- Mentions_T -- 19816 ---------------- 19817 19818 function Mentions_T (Acc_Def : Node_Id) return Boolean is 19819 Param_Spec : Node_Id; 19820 19821 Acc_Subprg : constant Node_Id := 19822 Access_To_Subprogram_Definition (Acc_Def); 19823 19824 begin 19825 if No (Acc_Subprg) then 19826 return Designates_T (Subtype_Mark (Acc_Def)); 19827 end if; 19828 19829 -- Component is an access_to_subprogram: examine its formals, 19830 -- and result definition in the case of an access_to_function. 19831 19832 Param_Spec := First (Parameter_Specifications (Acc_Subprg)); 19833 while Present (Param_Spec) loop 19834 if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition 19835 and then Mentions_T (Parameter_Type (Param_Spec)) 19836 then 19837 return True; 19838 19839 elsif Designates_T (Parameter_Type (Param_Spec)) then 19840 return True; 19841 end if; 19842 19843 Next (Param_Spec); 19844 end loop; 19845 19846 if Nkind (Acc_Subprg) = N_Access_Function_Definition then 19847 if Nkind (Result_Definition (Acc_Subprg)) = 19848 N_Access_Definition 19849 then 19850 return Mentions_T (Result_Definition (Acc_Subprg)); 19851 else 19852 return Designates_T (Result_Definition (Acc_Subprg)); 19853 end if; 19854 end if; 19855 19856 return False; 19857 end Mentions_T; 19858 19859 -- Start of processing for Check_Anonymous_Access_Components 19860 19861 begin 19862 if No (Comp_List) then 19863 return; 19864 end if; 19865 19866 Comp := First (Component_Items (Comp_List)); 19867 while Present (Comp) loop 19868 if Nkind (Comp) = N_Component_Declaration 19869 and then Present 19870 (Access_Definition (Component_Definition (Comp))) 19871 and then 19872 Mentions_T (Access_Definition (Component_Definition (Comp))) 19873 then 19874 Comp_Def := Component_Definition (Comp); 19875 Acc_Def := 19876 Access_To_Subprogram_Definition 19877 (Access_Definition (Comp_Def)); 19878 19879 Build_Incomplete_Type_Declaration; 19880 Anon_Access := Make_Temporary (Loc, 'S'); 19881 19882 -- Create a declaration for the anonymous access type: either 19883 -- an access_to_object or an access_to_subprogram. 19884 19885 if Present (Acc_Def) then 19886 if Nkind (Acc_Def) = N_Access_Function_Definition then 19887 Type_Def := 19888 Make_Access_Function_Definition (Loc, 19889 Parameter_Specifications => 19890 Parameter_Specifications (Acc_Def), 19891 Result_Definition => Result_Definition (Acc_Def)); 19892 else 19893 Type_Def := 19894 Make_Access_Procedure_Definition (Loc, 19895 Parameter_Specifications => 19896 Parameter_Specifications (Acc_Def)); 19897 end if; 19898 19899 else 19900 Type_Def := 19901 Make_Access_To_Object_Definition (Loc, 19902 Subtype_Indication => 19903 Relocate_Node 19904 (Subtype_Mark 19905 (Access_Definition (Comp_Def)))); 19906 19907 Set_Constant_Present 19908 (Type_Def, Constant_Present (Access_Definition (Comp_Def))); 19909 Set_All_Present 19910 (Type_Def, All_Present (Access_Definition (Comp_Def))); 19911 end if; 19912 19913 Set_Null_Exclusion_Present 19914 (Type_Def, 19915 Null_Exclusion_Present (Access_Definition (Comp_Def))); 19916 19917 Decl := 19918 Make_Full_Type_Declaration (Loc, 19919 Defining_Identifier => Anon_Access, 19920 Type_Definition => Type_Def); 19921 19922 Insert_Before (Typ_Decl, Decl); 19923 Analyze (Decl); 19924 19925 -- If an access to subprogram, create the extra formals 19926 19927 if Present (Acc_Def) then 19928 Create_Extra_Formals (Designated_Type (Anon_Access)); 19929 19930 -- If an access to object, preserve entity of designated type, 19931 -- for ASIS use, before rewriting the component definition. 19932 19933 else 19934 declare 19935 Desig : Entity_Id; 19936 19937 begin 19938 Desig := Entity (Subtype_Indication (Type_Def)); 19939 19940 -- If the access definition is to the current record, 19941 -- the visible entity at this point is an incomplete 19942 -- type. Retrieve the full view to simplify ASIS queries 19943 19944 if Ekind (Desig) = E_Incomplete_Type then 19945 Desig := Full_View (Desig); 19946 end if; 19947 19948 Set_Entity 19949 (Subtype_Mark (Access_Definition (Comp_Def)), Desig); 19950 end; 19951 end if; 19952 19953 Rewrite (Comp_Def, 19954 Make_Component_Definition (Loc, 19955 Subtype_Indication => 19956 New_Occurrence_Of (Anon_Access, Loc))); 19957 19958 if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then 19959 Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); 19960 else 19961 Set_Ekind (Anon_Access, E_Anonymous_Access_Type); 19962 end if; 19963 19964 Set_Is_Local_Anonymous_Access (Anon_Access); 19965 end if; 19966 19967 Next (Comp); 19968 end loop; 19969 19970 if Present (Variant_Part (Comp_List)) then 19971 declare 19972 V : Node_Id; 19973 begin 19974 V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 19975 while Present (V) loop 19976 Check_Anonymous_Access_Components 19977 (Typ_Decl, Typ, Prev, Component_List (V)); 19978 Next_Non_Pragma (V); 19979 end loop; 19980 end; 19981 end if; 19982 end Check_Anonymous_Access_Components; 19983 19984 ---------------------------------- 19985 -- Preanalyze_Assert_Expression -- 19986 ---------------------------------- 19987 19988 procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is 19989 begin 19990 In_Assertion_Expr := In_Assertion_Expr + 1; 19991 Preanalyze_Spec_Expression (N, T); 19992 In_Assertion_Expr := In_Assertion_Expr - 1; 19993 end Preanalyze_Assert_Expression; 19994 19995 -------------------------------- 19996 -- Preanalyze_Spec_Expression -- 19997 -------------------------------- 19998 19999 procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is 20000 Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; 20001 begin 20002 In_Spec_Expression := True; 20003 Preanalyze_And_Resolve (N, T); 20004 In_Spec_Expression := Save_In_Spec_Expression; 20005 end Preanalyze_Spec_Expression; 20006 20007 ----------------------------- 20008 -- Record_Type_Declaration -- 20009 ----------------------------- 20010 20011 procedure Record_Type_Declaration 20012 (T : Entity_Id; 20013 N : Node_Id; 20014 Prev : Entity_Id) 20015 is 20016 Def : constant Node_Id := Type_Definition (N); 20017 Is_Tagged : Boolean; 20018 Tag_Comp : Entity_Id; 20019 20020 begin 20021 -- These flags must be initialized before calling Process_Discriminants 20022 -- because this routine makes use of them. 20023 20024 Set_Ekind (T, E_Record_Type); 20025 Set_Etype (T, T); 20026 Init_Size_Align (T); 20027 Set_Interfaces (T, No_Elist); 20028 Set_Stored_Constraint (T, No_Elist); 20029 20030 -- Normal case 20031 20032 if Ada_Version < Ada_2005 20033 or else not Interface_Present (Def) 20034 then 20035 if Limited_Present (Def) then 20036 Check_SPARK_Restriction ("limited is not allowed", N); 20037 end if; 20038 20039 if Abstract_Present (Def) then 20040 Check_SPARK_Restriction ("abstract is not allowed", N); 20041 end if; 20042 20043 -- The flag Is_Tagged_Type might have already been set by 20044 -- Find_Type_Name if it detected an error for declaration T. This 20045 -- arises in the case of private tagged types where the full view 20046 -- omits the word tagged. 20047 20048 Is_Tagged := 20049 Tagged_Present (Def) 20050 or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T)); 20051 20052 Set_Is_Tagged_Type (T, Is_Tagged); 20053 Set_Is_Limited_Record (T, Limited_Present (Def)); 20054 20055 -- Type is abstract if full declaration carries keyword, or if 20056 -- previous partial view did. 20057 20058 Set_Is_Abstract_Type (T, Is_Abstract_Type (T) 20059 or else Abstract_Present (Def)); 20060 20061 else 20062 Check_SPARK_Restriction ("interface is not allowed", N); 20063 20064 Is_Tagged := True; 20065 Analyze_Interface_Declaration (T, Def); 20066 20067 if Present (Discriminant_Specifications (N)) then 20068 Error_Msg_N 20069 ("interface types cannot have discriminants", 20070 Defining_Identifier 20071 (First (Discriminant_Specifications (N)))); 20072 end if; 20073 end if; 20074 20075 -- First pass: if there are self-referential access components, 20076 -- create the required anonymous access type declarations, and if 20077 -- need be an incomplete type declaration for T itself. 20078 20079 Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def)); 20080 20081 if Ada_Version >= Ada_2005 20082 and then Present (Interface_List (Def)) 20083 then 20084 Check_Interfaces (N, Def); 20085 20086 declare 20087 Ifaces_List : Elist_Id; 20088 20089 begin 20090 -- Ada 2005 (AI-251): Collect the list of progenitors that are not 20091 -- already in the parents. 20092 20093 Collect_Interfaces 20094 (T => T, 20095 Ifaces_List => Ifaces_List, 20096 Exclude_Parents => True); 20097 20098 Set_Interfaces (T, Ifaces_List); 20099 end; 20100 end if; 20101 20102 -- Records constitute a scope for the component declarations within. 20103 -- The scope is created prior to the processing of these declarations. 20104 -- Discriminants are processed first, so that they are visible when 20105 -- processing the other components. The Ekind of the record type itself 20106 -- is set to E_Record_Type (subtypes appear as E_Record_Subtype). 20107 20108 -- Enter record scope 20109 20110 Push_Scope (T); 20111 20112 -- If an incomplete or private type declaration was already given for 20113 -- the type, then this scope already exists, and the discriminants have 20114 -- been declared within. We must verify that the full declaration 20115 -- matches the incomplete one. 20116 20117 Check_Or_Process_Discriminants (N, T, Prev); 20118 20119 Set_Is_Constrained (T, not Has_Discriminants (T)); 20120 Set_Has_Delayed_Freeze (T, True); 20121 20122 -- For tagged types add a manually analyzed component corresponding 20123 -- to the component _tag, the corresponding piece of tree will be 20124 -- expanded as part of the freezing actions if it is not a CPP_Class. 20125 20126 if Is_Tagged then 20127 20128 -- Do not add the tag unless we are in expansion mode 20129 20130 if Expander_Active then 20131 Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag); 20132 Enter_Name (Tag_Comp); 20133 20134 Set_Ekind (Tag_Comp, E_Component); 20135 Set_Is_Tag (Tag_Comp); 20136 Set_Is_Aliased (Tag_Comp); 20137 Set_Etype (Tag_Comp, RTE (RE_Tag)); 20138 Set_DT_Entry_Count (Tag_Comp, No_Uint); 20139 Set_Original_Record_Component (Tag_Comp, Tag_Comp); 20140 Init_Component_Location (Tag_Comp); 20141 20142 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the 20143 -- implemented interfaces. 20144 20145 if Has_Interfaces (T) then 20146 Add_Interface_Tag_Components (N, T); 20147 end if; 20148 end if; 20149 20150 Make_Class_Wide_Type (T); 20151 Set_Direct_Primitive_Operations (T, New_Elmt_List); 20152 end if; 20153 20154 -- We must suppress range checks when processing record components in 20155 -- the presence of discriminants, since we don't want spurious checks to 20156 -- be generated during their analysis, but Suppress_Range_Checks flags 20157 -- must be reset the after processing the record definition. 20158 20159 -- Note: this is the only use of Kill_Range_Checks, and is a bit odd, 20160 -- couldn't we just use the normal range check suppression method here. 20161 -- That would seem cleaner ??? 20162 20163 if Has_Discriminants (T) and then not Range_Checks_Suppressed (T) then 20164 Set_Kill_Range_Checks (T, True); 20165 Record_Type_Definition (Def, Prev); 20166 Set_Kill_Range_Checks (T, False); 20167 else 20168 Record_Type_Definition (Def, Prev); 20169 end if; 20170 20171 -- Exit from record scope 20172 20173 End_Scope; 20174 20175 -- Ada 2005 (AI-251 and AI-345): Derive the interface subprograms of all 20176 -- the implemented interfaces and associate them an aliased entity. 20177 20178 if Is_Tagged 20179 and then not Is_Empty_List (Interface_List (Def)) 20180 then 20181 Derive_Progenitor_Subprograms (T, T); 20182 end if; 20183 20184 Check_Function_Writable_Actuals (N); 20185 end Record_Type_Declaration; 20186 20187 ---------------------------- 20188 -- Record_Type_Definition -- 20189 ---------------------------- 20190 20191 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is 20192 Component : Entity_Id; 20193 Ctrl_Components : Boolean := False; 20194 Final_Storage_Only : Boolean; 20195 T : Entity_Id; 20196 20197 begin 20198 if Ekind (Prev_T) = E_Incomplete_Type then 20199 T := Full_View (Prev_T); 20200 else 20201 T := Prev_T; 20202 end if; 20203 20204 -- In SPARK, tagged types and type extensions may only be declared in 20205 -- the specification of library unit packages. 20206 20207 if Present (Def) and then Is_Tagged_Type (T) then 20208 declare 20209 Typ : Node_Id; 20210 Ctxt : Node_Id; 20211 20212 begin 20213 if Nkind (Parent (Def)) = N_Full_Type_Declaration then 20214 Typ := Parent (Def); 20215 else 20216 pragma Assert 20217 (Nkind (Parent (Def)) = N_Derived_Type_Definition); 20218 Typ := Parent (Parent (Def)); 20219 end if; 20220 20221 Ctxt := Parent (Typ); 20222 20223 if Nkind (Ctxt) = N_Package_Body 20224 and then Nkind (Parent (Ctxt)) = N_Compilation_Unit 20225 then 20226 Check_SPARK_Restriction 20227 ("type should be defined in package specification", Typ); 20228 20229 elsif Nkind (Ctxt) /= N_Package_Specification 20230 or else Nkind (Parent (Parent (Ctxt))) /= N_Compilation_Unit 20231 then 20232 Check_SPARK_Restriction 20233 ("type should be defined in library unit package", Typ); 20234 end if; 20235 end; 20236 end if; 20237 20238 Final_Storage_Only := not Is_Controlled (T); 20239 20240 -- Ada 2005: Check whether an explicit Limited is present in a derived 20241 -- type declaration. 20242 20243 if Nkind (Parent (Def)) = N_Derived_Type_Definition 20244 and then Limited_Present (Parent (Def)) 20245 then 20246 Set_Is_Limited_Record (T); 20247 end if; 20248 20249 -- If the component list of a record type is defined by the reserved 20250 -- word null and there is no discriminant part, then the record type has 20251 -- no components and all records of the type are null records (RM 3.7) 20252 -- This procedure is also called to process the extension part of a 20253 -- record extension, in which case the current scope may have inherited 20254 -- components. 20255 20256 if No (Def) 20257 or else No (Component_List (Def)) 20258 or else Null_Present (Component_List (Def)) 20259 then 20260 if not Is_Tagged_Type (T) then 20261 Check_SPARK_Restriction ("non-tagged record cannot be null", Def); 20262 end if; 20263 20264 else 20265 Analyze_Declarations (Component_Items (Component_List (Def))); 20266 20267 if Present (Variant_Part (Component_List (Def))) then 20268 Check_SPARK_Restriction ("variant part is not allowed", Def); 20269 Analyze (Variant_Part (Component_List (Def))); 20270 end if; 20271 end if; 20272 20273 -- After completing the semantic analysis of the record definition, 20274 -- record components, both new and inherited, are accessible. Set their 20275 -- kind accordingly. Exclude malformed itypes from illegal declarations, 20276 -- whose Ekind may be void. 20277 20278 Component := First_Entity (Current_Scope); 20279 while Present (Component) loop 20280 if Ekind (Component) = E_Void 20281 and then not Is_Itype (Component) 20282 then 20283 Set_Ekind (Component, E_Component); 20284 Init_Component_Location (Component); 20285 end if; 20286 20287 if Has_Task (Etype (Component)) then 20288 Set_Has_Task (T); 20289 end if; 20290 20291 if Ekind (Component) /= E_Component then 20292 null; 20293 20294 -- Do not set Has_Controlled_Component on a class-wide equivalent 20295 -- type. See Make_CW_Equivalent_Type. 20296 20297 elsif not Is_Class_Wide_Equivalent_Type (T) 20298 and then (Has_Controlled_Component (Etype (Component)) 20299 or else (Chars (Component) /= Name_uParent 20300 and then Is_Controlled (Etype (Component)))) 20301 then 20302 Set_Has_Controlled_Component (T, True); 20303 Final_Storage_Only := 20304 Final_Storage_Only 20305 and then Finalize_Storage_Only (Etype (Component)); 20306 Ctrl_Components := True; 20307 end if; 20308 20309 Next_Entity (Component); 20310 end loop; 20311 20312 -- A Type is Finalize_Storage_Only only if all its controlled components 20313 -- are also. 20314 20315 if Ctrl_Components then 20316 Set_Finalize_Storage_Only (T, Final_Storage_Only); 20317 end if; 20318 20319 -- Place reference to end record on the proper entity, which may 20320 -- be a partial view. 20321 20322 if Present (Def) then 20323 Process_End_Label (Def, 'e', Prev_T); 20324 end if; 20325 end Record_Type_Definition; 20326 20327 ------------------------ 20328 -- Replace_Components -- 20329 ------------------------ 20330 20331 procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id) is 20332 function Process (N : Node_Id) return Traverse_Result; 20333 20334 ------------- 20335 -- Process -- 20336 ------------- 20337 20338 function Process (N : Node_Id) return Traverse_Result is 20339 Comp : Entity_Id; 20340 20341 begin 20342 if Nkind (N) = N_Discriminant_Specification then 20343 Comp := First_Discriminant (Typ); 20344 while Present (Comp) loop 20345 if Chars (Comp) = Chars (Defining_Identifier (N)) then 20346 Set_Defining_Identifier (N, Comp); 20347 exit; 20348 end if; 20349 20350 Next_Discriminant (Comp); 20351 end loop; 20352 20353 elsif Nkind (N) = N_Component_Declaration then 20354 Comp := First_Component (Typ); 20355 while Present (Comp) loop 20356 if Chars (Comp) = Chars (Defining_Identifier (N)) then 20357 Set_Defining_Identifier (N, Comp); 20358 exit; 20359 end if; 20360 20361 Next_Component (Comp); 20362 end loop; 20363 end if; 20364 20365 return OK; 20366 end Process; 20367 20368 procedure Replace is new Traverse_Proc (Process); 20369 20370 -- Start of processing for Replace_Components 20371 20372 begin 20373 Replace (Decl); 20374 end Replace_Components; 20375 20376 ------------------------------- 20377 -- Set_Completion_Referenced -- 20378 ------------------------------- 20379 20380 procedure Set_Completion_Referenced (E : Entity_Id) is 20381 begin 20382 -- If in main unit, mark entity that is a completion as referenced, 20383 -- warnings go on the partial view when needed. 20384 20385 if In_Extended_Main_Source_Unit (E) then 20386 Set_Referenced (E); 20387 end if; 20388 end Set_Completion_Referenced; 20389 20390 --------------------- 20391 -- Set_Fixed_Range -- 20392 --------------------- 20393 20394 -- The range for fixed-point types is complicated by the fact that we 20395 -- do not know the exact end points at the time of the declaration. This 20396 -- is true for three reasons: 20397 20398 -- A size clause may affect the fudging of the end-points. 20399 -- A small clause may affect the values of the end-points. 20400 -- We try to include the end-points if it does not affect the size. 20401 20402 -- This means that the actual end-points must be established at the 20403 -- point when the type is frozen. Meanwhile, we first narrow the range 20404 -- as permitted (so that it will fit if necessary in a small specified 20405 -- size), and then build a range subtree with these narrowed bounds. 20406 -- Set_Fixed_Range constructs the range from real literal values, and 20407 -- sets the range as the Scalar_Range of the given fixed-point type entity. 20408 20409 -- The parent of this range is set to point to the entity so that it is 20410 -- properly hooked into the tree (unlike normal Scalar_Range entries for 20411 -- other scalar types, which are just pointers to the range in the 20412 -- original tree, this would otherwise be an orphan). 20413 20414 -- The tree is left unanalyzed. When the type is frozen, the processing 20415 -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not 20416 -- analyzed, and uses this as an indication that it should complete 20417 -- work on the range (it will know the final small and size values). 20418 20419 procedure Set_Fixed_Range 20420 (E : Entity_Id; 20421 Loc : Source_Ptr; 20422 Lo : Ureal; 20423 Hi : Ureal) 20424 is 20425 S : constant Node_Id := 20426 Make_Range (Loc, 20427 Low_Bound => Make_Real_Literal (Loc, Lo), 20428 High_Bound => Make_Real_Literal (Loc, Hi)); 20429 begin 20430 Set_Scalar_Range (E, S); 20431 Set_Parent (S, E); 20432 20433 -- Before the freeze point, the bounds of a fixed point are universal 20434 -- and carry the corresponding type. 20435 20436 Set_Etype (Low_Bound (S), Universal_Real); 20437 Set_Etype (High_Bound (S), Universal_Real); 20438 end Set_Fixed_Range; 20439 20440 ---------------------------------- 20441 -- Set_Scalar_Range_For_Subtype -- 20442 ---------------------------------- 20443 20444 procedure Set_Scalar_Range_For_Subtype 20445 (Def_Id : Entity_Id; 20446 R : Node_Id; 20447 Subt : Entity_Id) 20448 is 20449 Kind : constant Entity_Kind := Ekind (Def_Id); 20450 20451 begin 20452 -- Defend against previous error 20453 20454 if Nkind (R) = N_Error then 20455 return; 20456 end if; 20457 20458 Set_Scalar_Range (Def_Id, R); 20459 20460 -- We need to link the range into the tree before resolving it so 20461 -- that types that are referenced, including importantly the subtype 20462 -- itself, are properly frozen (Freeze_Expression requires that the 20463 -- expression be properly linked into the tree). Of course if it is 20464 -- already linked in, then we do not disturb the current link. 20465 20466 if No (Parent (R)) then 20467 Set_Parent (R, Def_Id); 20468 end if; 20469 20470 -- Reset the kind of the subtype during analysis of the range, to 20471 -- catch possible premature use in the bounds themselves. 20472 20473 Set_Ekind (Def_Id, E_Void); 20474 Process_Range_Expr_In_Decl (R, Subt); 20475 Set_Ekind (Def_Id, Kind); 20476 end Set_Scalar_Range_For_Subtype; 20477 20478 -------------------------------------------------------- 20479 -- Set_Stored_Constraint_From_Discriminant_Constraint -- 20480 -------------------------------------------------------- 20481 20482 procedure Set_Stored_Constraint_From_Discriminant_Constraint 20483 (E : Entity_Id) 20484 is 20485 begin 20486 -- Make sure set if encountered during Expand_To_Stored_Constraint 20487 20488 Set_Stored_Constraint (E, No_Elist); 20489 20490 -- Give it the right value 20491 20492 if Is_Constrained (E) and then Has_Discriminants (E) then 20493 Set_Stored_Constraint (E, 20494 Expand_To_Stored_Constraint (E, Discriminant_Constraint (E))); 20495 end if; 20496 end Set_Stored_Constraint_From_Discriminant_Constraint; 20497 20498 ------------------------------------- 20499 -- Signed_Integer_Type_Declaration -- 20500 ------------------------------------- 20501 20502 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is 20503 Implicit_Base : Entity_Id; 20504 Base_Typ : Entity_Id; 20505 Lo_Val : Uint; 20506 Hi_Val : Uint; 20507 Errs : Boolean := False; 20508 Lo : Node_Id; 20509 Hi : Node_Id; 20510 20511 function Can_Derive_From (E : Entity_Id) return Boolean; 20512 -- Determine whether given bounds allow derivation from specified type 20513 20514 procedure Check_Bound (Expr : Node_Id); 20515 -- Check bound to make sure it is integral and static. If not, post 20516 -- appropriate error message and set Errs flag 20517 20518 --------------------- 20519 -- Can_Derive_From -- 20520 --------------------- 20521 20522 -- Note we check both bounds against both end values, to deal with 20523 -- strange types like ones with a range of 0 .. -12341234. 20524 20525 function Can_Derive_From (E : Entity_Id) return Boolean is 20526 Lo : constant Uint := Expr_Value (Type_Low_Bound (E)); 20527 Hi : constant Uint := Expr_Value (Type_High_Bound (E)); 20528 begin 20529 return Lo <= Lo_Val and then Lo_Val <= Hi 20530 and then 20531 Lo <= Hi_Val and then Hi_Val <= Hi; 20532 end Can_Derive_From; 20533 20534 ----------------- 20535 -- Check_Bound -- 20536 ----------------- 20537 20538 procedure Check_Bound (Expr : Node_Id) is 20539 begin 20540 -- If a range constraint is used as an integer type definition, each 20541 -- bound of the range must be defined by a static expression of some 20542 -- integer type, but the two bounds need not have the same integer 20543 -- type (Negative bounds are allowed.) (RM 3.5.4) 20544 20545 if not Is_Integer_Type (Etype (Expr)) then 20546 Error_Msg_N 20547 ("integer type definition bounds must be of integer type", Expr); 20548 Errs := True; 20549 20550 elsif not Is_OK_Static_Expression (Expr) then 20551 Flag_Non_Static_Expr 20552 ("non-static expression used for integer type bound!", Expr); 20553 Errs := True; 20554 20555 -- The bounds are folded into literals, and we set their type to be 20556 -- universal, to avoid typing difficulties: we cannot set the type 20557 -- of the literal to the new type, because this would be a forward 20558 -- reference for the back end, and if the original type is user- 20559 -- defined this can lead to spurious semantic errors (e.g. 2928-003). 20560 20561 else 20562 if Is_Entity_Name (Expr) then 20563 Fold_Uint (Expr, Expr_Value (Expr), True); 20564 end if; 20565 20566 Set_Etype (Expr, Universal_Integer); 20567 end if; 20568 end Check_Bound; 20569 20570 -- Start of processing for Signed_Integer_Type_Declaration 20571 20572 begin 20573 -- Create an anonymous base type 20574 20575 Implicit_Base := 20576 Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B'); 20577 20578 -- Analyze and check the bounds, they can be of any integer type 20579 20580 Lo := Low_Bound (Def); 20581 Hi := High_Bound (Def); 20582 20583 -- Arbitrarily use Integer as the type if either bound had an error 20584 20585 if Hi = Error or else Lo = Error then 20586 Base_Typ := Any_Integer; 20587 Set_Error_Posted (T, True); 20588 20589 -- Here both bounds are OK expressions 20590 20591 else 20592 Analyze_And_Resolve (Lo, Any_Integer); 20593 Analyze_And_Resolve (Hi, Any_Integer); 20594 20595 Check_Bound (Lo); 20596 Check_Bound (Hi); 20597 20598 if Errs then 20599 Hi := Type_High_Bound (Standard_Long_Long_Integer); 20600 Lo := Type_Low_Bound (Standard_Long_Long_Integer); 20601 end if; 20602 20603 -- Find type to derive from 20604 20605 Lo_Val := Expr_Value (Lo); 20606 Hi_Val := Expr_Value (Hi); 20607 20608 if Can_Derive_From (Standard_Short_Short_Integer) then 20609 Base_Typ := Base_Type (Standard_Short_Short_Integer); 20610 20611 elsif Can_Derive_From (Standard_Short_Integer) then 20612 Base_Typ := Base_Type (Standard_Short_Integer); 20613 20614 elsif Can_Derive_From (Standard_Integer) then 20615 Base_Typ := Base_Type (Standard_Integer); 20616 20617 elsif Can_Derive_From (Standard_Long_Integer) then 20618 Base_Typ := Base_Type (Standard_Long_Integer); 20619 20620 elsif Can_Derive_From (Standard_Long_Long_Integer) then 20621 Base_Typ := Base_Type (Standard_Long_Long_Integer); 20622 20623 else 20624 Base_Typ := Base_Type (Standard_Long_Long_Integer); 20625 Error_Msg_N ("integer type definition bounds out of range", Def); 20626 Hi := Type_High_Bound (Standard_Long_Long_Integer); 20627 Lo := Type_Low_Bound (Standard_Long_Long_Integer); 20628 end if; 20629 end if; 20630 20631 -- Complete both implicit base and declared first subtype entities 20632 20633 Set_Etype (Implicit_Base, Base_Typ); 20634 Set_Size_Info (Implicit_Base, (Base_Typ)); 20635 Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); 20636 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); 20637 20638 Set_Ekind (T, E_Signed_Integer_Subtype); 20639 Set_Etype (T, Implicit_Base); 20640 20641 Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); 20642 20643 Set_Size_Info (T, (Implicit_Base)); 20644 Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); 20645 Set_Scalar_Range (T, Def); 20646 Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); 20647 Set_Is_Constrained (T); 20648 end Signed_Integer_Type_Declaration; 20649 20650end Sem_Ch3; 20651