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-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Contracts; use Contracts; 30with Debug; use Debug; 31with Elists; use Elists; 32with Einfo; use Einfo; 33with Errout; use Errout; 34with Eval_Fat; use Eval_Fat; 35with Exp_Ch3; use Exp_Ch3; 36with Exp_Ch9; use Exp_Ch9; 37with Exp_Disp; use Exp_Disp; 38with Exp_Dist; use Exp_Dist; 39with Exp_Tss; use Exp_Tss; 40with Exp_Util; use Exp_Util; 41with Freeze; use Freeze; 42with Ghost; use Ghost; 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_Elab; use Sem_Elab; 65with Sem_Elim; use Sem_Elim; 66with Sem_Eval; use Sem_Eval; 67with Sem_Mech; use Sem_Mech; 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 Build_Derived_Type 95 (N : Node_Id; 96 Parent_Type : Entity_Id; 97 Derived_Type : Entity_Id; 98 Is_Completion : Boolean; 99 Derive_Subps : Boolean := True); 100 -- Create and decorate a Derived_Type given the Parent_Type entity. N is 101 -- the N_Full_Type_Declaration node containing the derived type definition. 102 -- Parent_Type is the entity for the parent type in the derived type 103 -- definition and Derived_Type the actual derived type. Is_Completion must 104 -- be set to False if Derived_Type is the N_Defining_Identifier node in N 105 -- (i.e. Derived_Type = Defining_Identifier (N)). In this case N is not the 106 -- completion of a private type declaration. If Is_Completion is set to 107 -- True, N is the completion of a private type declaration and Derived_Type 108 -- is different from the defining identifier inside N (i.e. Derived_Type /= 109 -- Defining_Identifier (N)). Derive_Subps indicates whether the parent 110 -- subprograms should be derived. The only case where this parameter is 111 -- False is when Build_Derived_Type is recursively called to process an 112 -- implicit derived full type for a type derived from a private type (in 113 -- that case the subprograms must only be derived for the private view of 114 -- the type). 115 -- 116 -- ??? These flags need a bit of re-examination and re-documentation: 117 -- ??? are they both necessary (both seem related to the recursion)? 118 119 procedure Build_Derived_Access_Type 120 (N : Node_Id; 121 Parent_Type : Entity_Id; 122 Derived_Type : Entity_Id); 123 -- Subsidiary procedure to Build_Derived_Type. For a derived access type, 124 -- create an implicit base if the parent type is constrained or if the 125 -- subtype indication has a constraint. 126 127 procedure Build_Derived_Array_Type 128 (N : Node_Id; 129 Parent_Type : Entity_Id; 130 Derived_Type : Entity_Id); 131 -- Subsidiary procedure to Build_Derived_Type. For a derived array type, 132 -- create an implicit base if the parent type is constrained or if the 133 -- subtype indication has a constraint. 134 135 procedure Build_Derived_Concurrent_Type 136 (N : Node_Id; 137 Parent_Type : Entity_Id; 138 Derived_Type : Entity_Id); 139 -- Subsidiary procedure to Build_Derived_Type. For a derived task or 140 -- protected type, inherit entries and protected subprograms, check 141 -- legality of discriminant constraints if any. 142 143 procedure Build_Derived_Enumeration_Type 144 (N : Node_Id; 145 Parent_Type : Entity_Id; 146 Derived_Type : Entity_Id); 147 -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration 148 -- type, we must create a new list of literals. Types derived from 149 -- Character and [Wide_]Wide_Character are special-cased. 150 151 procedure Build_Derived_Numeric_Type 152 (N : Node_Id; 153 Parent_Type : Entity_Id; 154 Derived_Type : Entity_Id); 155 -- Subsidiary procedure to Build_Derived_Type. For numeric types, create 156 -- an anonymous base type, and propagate constraint to subtype if needed. 157 158 procedure Build_Derived_Private_Type 159 (N : Node_Id; 160 Parent_Type : Entity_Id; 161 Derived_Type : Entity_Id; 162 Is_Completion : Boolean; 163 Derive_Subps : Boolean := True); 164 -- Subsidiary procedure to Build_Derived_Type. This procedure is complex 165 -- because the parent may or may not have a completion, and the derivation 166 -- may itself be a completion. 167 168 procedure Build_Derived_Record_Type 169 (N : Node_Id; 170 Parent_Type : Entity_Id; 171 Derived_Type : Entity_Id; 172 Derive_Subps : Boolean := True); 173 -- Subsidiary procedure used for tagged and untagged record types 174 -- by Build_Derived_Type and Analyze_Private_Extension_Declaration. 175 -- All parameters are as in Build_Derived_Type except that N, in 176 -- addition to being an N_Full_Type_Declaration node, can also be an 177 -- N_Private_Extension_Declaration node. See the definition of this routine 178 -- for much more info. Derive_Subps indicates whether subprograms should be 179 -- derived from the parent type. The only case where Derive_Subps is False 180 -- is for an implicit derived full type for a type derived from a private 181 -- type (see Build_Derived_Type). 182 183 procedure Build_Discriminal (Discrim : Entity_Id); 184 -- Create the discriminal corresponding to discriminant Discrim, that is 185 -- the parameter corresponding to Discrim to be used in initialization 186 -- procedures for the type where Discrim is a discriminant. Discriminals 187 -- are not used during semantic analysis, and are not fully defined 188 -- entities until expansion. Thus they are not given a scope until 189 -- initialization procedures are built. 190 191 function Build_Discriminant_Constraints 192 (T : Entity_Id; 193 Def : Node_Id; 194 Derived_Def : Boolean := False) return Elist_Id; 195 -- Validate discriminant constraints and return the list of the constraints 196 -- in order of discriminant declarations, where T is the discriminated 197 -- unconstrained type. Def is the N_Subtype_Indication node where the 198 -- discriminants constraints for T are specified. Derived_Def is True 199 -- when building the discriminant constraints in a derived type definition 200 -- of the form "type D (...) is new T (xxx)". In this case T is the parent 201 -- type and Def is the constraint "(xxx)" on T and this routine sets the 202 -- Corresponding_Discriminant field of the discriminants in the derived 203 -- type D to point to the corresponding discriminants in the parent type T. 204 205 procedure Build_Discriminated_Subtype 206 (T : Entity_Id; 207 Def_Id : Entity_Id; 208 Elist : Elist_Id; 209 Related_Nod : Node_Id; 210 For_Access : Boolean := False); 211 -- Subsidiary procedure to Constrain_Discriminated_Type and to 212 -- Process_Incomplete_Dependents. Given 213 -- 214 -- T (a possibly discriminated base type) 215 -- Def_Id (a very partially built subtype for T), 216 -- 217 -- the call completes Def_Id to be the appropriate E_*_Subtype. 218 -- 219 -- The Elist is the list of discriminant constraints if any (it is set 220 -- to No_Elist if T is not a discriminated type, and to an empty list if 221 -- T has discriminants but there are no discriminant constraints). The 222 -- Related_Nod is the same as Decl_Node in Create_Constrained_Components. 223 -- The For_Access says whether or not this subtype is really constraining 224 -- an access type. 225 226 function Build_Scalar_Bound 227 (Bound : Node_Id; 228 Par_T : Entity_Id; 229 Der_T : Entity_Id) return Node_Id; 230 -- The bounds of a derived scalar type are conversions of the bounds of 231 -- the parent type. Optimize the representation if the bounds are literals. 232 -- Needs a more complete spec--what are the parameters exactly, and what 233 -- exactly is the returned value, and how is Bound affected??? 234 235 procedure Check_Access_Discriminant_Requires_Limited 236 (D : Node_Id; 237 Loc : Node_Id); 238 -- Check the restriction that the type to which an access discriminant 239 -- belongs must be a concurrent type or a descendant of a type with 240 -- the reserved word 'limited' in its declaration. 241 242 procedure Check_Anonymous_Access_Components 243 (Typ_Decl : Node_Id; 244 Typ : Entity_Id; 245 Prev : Entity_Id; 246 Comp_List : Node_Id); 247 -- Ada 2005 AI-382: an access component in a record definition can refer to 248 -- the enclosing record, in which case it denotes the type itself, and not 249 -- the current instance of the type. We create an anonymous access type for 250 -- the component, and flag it as an access to a component, so accessibility 251 -- checks are properly performed on it. The declaration of the access type 252 -- is placed ahead of that of the record to prevent order-of-elaboration 253 -- circularity issues in Gigi. We create an incomplete type for the record 254 -- declaration, which is the designated type of the anonymous access. 255 256 procedure Check_Delta_Expression (E : Node_Id); 257 -- Check that the expression represented by E is suitable for use as a 258 -- delta expression, i.e. it is of real type and is static. 259 260 procedure Check_Digits_Expression (E : Node_Id); 261 -- Check that the expression represented by E is suitable for use as a 262 -- digits expression, i.e. it is of integer type, positive and static. 263 264 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id); 265 -- Validate the initialization of an object declaration. T is the required 266 -- type, and Exp is the initialization expression. 267 268 procedure Check_Interfaces (N : Node_Id; Def : Node_Id); 269 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) 270 271 procedure Check_Or_Process_Discriminants 272 (N : Node_Id; 273 T : Entity_Id; 274 Prev : Entity_Id := Empty); 275 -- If N is the full declaration of the completion T of an incomplete or 276 -- private type, check its discriminants (which are already known to be 277 -- conformant with those of the partial view, see Find_Type_Name), 278 -- otherwise process them. Prev is the entity of the partial declaration, 279 -- if any. 280 281 procedure Check_Real_Bound (Bound : Node_Id); 282 -- Check given bound for being of real type and static. If not, post an 283 -- appropriate message, and rewrite the bound with the real literal zero. 284 285 procedure Constant_Redeclaration 286 (Id : Entity_Id; 287 N : Node_Id; 288 T : out Entity_Id); 289 -- Various checks on legality of full declaration of deferred constant. 290 -- Id is the entity for the redeclaration, N is the N_Object_Declaration, 291 -- node. The caller has not yet set any attributes of this entity. 292 293 function Contain_Interface 294 (Iface : Entity_Id; 295 Ifaces : Elist_Id) return Boolean; 296 -- Ada 2005: Determine whether Iface is present in the list Ifaces 297 298 procedure Convert_Scalar_Bounds 299 (N : Node_Id; 300 Parent_Type : Entity_Id; 301 Derived_Type : Entity_Id; 302 Loc : Source_Ptr); 303 -- For derived scalar types, convert the bounds in the type definition to 304 -- the derived type, and complete their analysis. Given a constraint of the 305 -- form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with 306 -- T'Base, the parent_type. The bounds of the derived type (the anonymous 307 -- base) are copies of Lo and Hi. Finally, the bounds of the derived 308 -- subtype are conversions of those bounds to the derived_type, so that 309 -- their typing is consistent. 310 311 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id); 312 -- Copies attributes from array base type T2 to array base type T1. Copies 313 -- only attributes that apply to base types, but not subtypes. 314 315 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id); 316 -- Copies attributes from array subtype T2 to array subtype T1. Copies 317 -- attributes that apply to both subtypes and base types. 318 319 procedure Create_Constrained_Components 320 (Subt : Entity_Id; 321 Decl_Node : Node_Id; 322 Typ : Entity_Id; 323 Constraints : Elist_Id); 324 -- Build the list of entities for a constrained discriminated record 325 -- subtype. If a component depends on a discriminant, replace its subtype 326 -- using the discriminant values in the discriminant constraint. Subt 327 -- is the defining identifier for the subtype whose list of constrained 328 -- entities we will create. Decl_Node is the type declaration node where 329 -- we will attach all the itypes created. Typ is the base discriminated 330 -- type for the subtype Subt. Constraints is the list of discriminant 331 -- constraints for Typ. 332 333 function Constrain_Component_Type 334 (Comp : Entity_Id; 335 Constrained_Typ : Entity_Id; 336 Related_Node : Node_Id; 337 Typ : Entity_Id; 338 Constraints : Elist_Id) return Entity_Id; 339 -- Given a discriminated base type Typ, a list of discriminant constraints, 340 -- Constraints, for Typ and a component Comp of Typ, create and return the 341 -- type corresponding to Etype (Comp) where all discriminant references 342 -- are replaced with the corresponding constraint. If Etype (Comp) contains 343 -- no discriminant references then it is returned as-is. Constrained_Typ 344 -- is the final constrained subtype to which the constrained component 345 -- belongs. Related_Node is the node where we attach all created itypes. 346 347 procedure Constrain_Access 348 (Def_Id : in out Entity_Id; 349 S : Node_Id; 350 Related_Nod : Node_Id); 351 -- Apply a list of constraints to an access type. If Def_Id is empty, it is 352 -- an anonymous type created for a subtype indication. In that case it is 353 -- created in the procedure and attached to Related_Nod. 354 355 procedure Constrain_Array 356 (Def_Id : in out Entity_Id; 357 SI : Node_Id; 358 Related_Nod : Node_Id; 359 Related_Id : Entity_Id; 360 Suffix : Character); 361 -- Apply a list of index constraints to an unconstrained array type. The 362 -- first parameter is the entity for the resulting subtype. A value of 363 -- Empty for Def_Id indicates that an implicit type must be created, but 364 -- creation is delayed (and must be done by this procedure) because other 365 -- subsidiary implicit types must be created first (which is why Def_Id 366 -- is an in/out parameter). The second parameter is a subtype indication 367 -- node for the constrained array to be created (e.g. something of the 368 -- form string (1 .. 10)). Related_Nod gives the place where this type 369 -- has to be inserted in the tree. The Related_Id and Suffix parameters 370 -- are used to build the associated Implicit type name. 371 372 procedure Constrain_Concurrent 373 (Def_Id : in out Entity_Id; 374 SI : Node_Id; 375 Related_Nod : Node_Id; 376 Related_Id : Entity_Id; 377 Suffix : Character); 378 -- Apply list of discriminant constraints to an unconstrained concurrent 379 -- type. 380 -- 381 -- SI is the N_Subtype_Indication node containing the constraint and 382 -- the unconstrained type to constrain. 383 -- 384 -- Def_Id is the entity for the resulting constrained subtype. A value 385 -- of Empty for Def_Id indicates that an implicit type must be created, 386 -- but creation is delayed (and must be done by this procedure) because 387 -- other subsidiary implicit types must be created first (which is why 388 -- Def_Id is an in/out parameter). 389 -- 390 -- Related_Nod gives the place where this type has to be inserted 391 -- in the tree. 392 -- 393 -- The last two arguments are used to create its external name if needed. 394 395 function Constrain_Corresponding_Record 396 (Prot_Subt : Entity_Id; 397 Corr_Rec : Entity_Id; 398 Related_Nod : Node_Id) return Entity_Id; 399 -- When constraining a protected type or task type with discriminants, 400 -- constrain the corresponding record with the same discriminant values. 401 402 procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id); 403 -- Constrain a decimal fixed point type with a digits constraint and/or a 404 -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity. 405 406 procedure Constrain_Discriminated_Type 407 (Def_Id : Entity_Id; 408 S : Node_Id; 409 Related_Nod : Node_Id; 410 For_Access : Boolean := False); 411 -- Process discriminant constraints of composite type. Verify that values 412 -- have been provided for all discriminants, that the original type is 413 -- unconstrained, and that the types of the supplied expressions match 414 -- the discriminant types. The first three parameters are like in routine 415 -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation 416 -- of For_Access. 417 418 procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id); 419 -- Constrain an enumeration type with a range constraint. This is identical 420 -- to Constrain_Integer, but for the Ekind of the resulting subtype. 421 422 procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id); 423 -- Constrain a floating point type with either a digits constraint 424 -- and/or a range constraint, building a E_Floating_Point_Subtype. 425 426 procedure Constrain_Index 427 (Index : Node_Id; 428 S : Node_Id; 429 Related_Nod : Node_Id; 430 Related_Id : Entity_Id; 431 Suffix : Character; 432 Suffix_Index : Nat); 433 -- Process an index constraint S in a constrained array declaration. The 434 -- constraint can be a subtype name, or a range with or without an explicit 435 -- subtype mark. The index is the corresponding index of the unconstrained 436 -- array. The Related_Id and Suffix parameters are used to build the 437 -- associated Implicit type name. 438 439 procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id); 440 -- Build subtype of a signed or modular integer type 441 442 procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id); 443 -- Constrain an ordinary fixed point type with a range constraint, and 444 -- build an E_Ordinary_Fixed_Point_Subtype entity. 445 446 procedure Copy_And_Swap (Priv, Full : Entity_Id); 447 -- Copy the Priv entity into the entity of its full declaration then swap 448 -- the two entities in such a manner that the former private type is now 449 -- seen as a full type. 450 451 procedure Decimal_Fixed_Point_Type_Declaration 452 (T : Entity_Id; 453 Def : Node_Id); 454 -- Create a new decimal fixed point type, and apply the constraint to 455 -- obtain a subtype of this new type. 456 457 procedure Complete_Private_Subtype 458 (Priv : Entity_Id; 459 Full : Entity_Id; 460 Full_Base : Entity_Id; 461 Related_Nod : Node_Id); 462 -- Complete the implicit full view of a private subtype by setting the 463 -- appropriate semantic fields. If the full view of the parent is a record 464 -- type, build constrained components of subtype. 465 466 procedure Derive_Progenitor_Subprograms 467 (Parent_Type : Entity_Id; 468 Tagged_Type : Entity_Id); 469 -- Ada 2005 (AI-251): To complete type derivation, collect the primitive 470 -- operations of progenitors of Tagged_Type, and replace the subsidiary 471 -- subtypes with Tagged_Type, to build the specs of the inherited interface 472 -- primitives. The derived primitives are aliased to those of the 473 -- interface. This routine takes care also of transferring to the full view 474 -- subprograms associated with the partial view of Tagged_Type that cover 475 -- interface primitives. 476 477 procedure Derived_Standard_Character 478 (N : Node_Id; 479 Parent_Type : Entity_Id; 480 Derived_Type : Entity_Id); 481 -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles 482 -- derivations from types Standard.Character and Standard.Wide_Character. 483 484 procedure Derived_Type_Declaration 485 (T : Entity_Id; 486 N : Node_Id; 487 Is_Completion : Boolean); 488 -- Process a derived type declaration. Build_Derived_Type is invoked 489 -- to process the actual derived type definition. Parameters N and 490 -- Is_Completion have the same meaning as in Build_Derived_Type. 491 -- T is the N_Defining_Identifier for the entity defined in the 492 -- N_Full_Type_Declaration node N, that is T is the derived type. 493 494 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id); 495 -- Insert each literal in symbol table, as an overloadable identifier. Each 496 -- enumeration type is mapped into a sequence of integers, and each literal 497 -- is defined as a constant with integer value. If any of the literals are 498 -- character literals, the type is a character type, which means that 499 -- strings are legal aggregates for arrays of components of the type. 500 501 function Expand_To_Stored_Constraint 502 (Typ : Entity_Id; 503 Constraint : Elist_Id) return Elist_Id; 504 -- Given a constraint (i.e. a list of expressions) on the discriminants of 505 -- Typ, expand it into a constraint on the stored discriminants and return 506 -- the new list of expressions constraining the stored discriminants. 507 508 function Find_Type_Of_Object 509 (Obj_Def : Node_Id; 510 Related_Nod : Node_Id) return Entity_Id; 511 -- Get type entity for object referenced by Obj_Def, attaching the implicit 512 -- types generated to Related_Nod. 513 514 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id); 515 -- Create a new float and apply the constraint to obtain subtype of it 516 517 function Has_Range_Constraint (N : Node_Id) return Boolean; 518 -- Given an N_Subtype_Indication node N, return True if a range constraint 519 -- is present, either directly, or as part of a digits or delta constraint. 520 -- In addition, a digits constraint in the decimal case returns True, since 521 -- it establishes a default range if no explicit range is present. 522 523 function Inherit_Components 524 (N : Node_Id; 525 Parent_Base : Entity_Id; 526 Derived_Base : Entity_Id; 527 Is_Tagged : Boolean; 528 Inherit_Discr : Boolean; 529 Discs : Elist_Id) return Elist_Id; 530 -- Called from Build_Derived_Record_Type to inherit the components of 531 -- Parent_Base (a base type) into the Derived_Base (the derived base type). 532 -- For more information on derived types and component inheritance please 533 -- consult the comment above the body of Build_Derived_Record_Type. 534 -- 535 -- N is the original derived type declaration 536 -- 537 -- Is_Tagged is set if we are dealing with tagged types 538 -- 539 -- If Inherit_Discr is set, Derived_Base inherits its discriminants from 540 -- Parent_Base, otherwise no discriminants are inherited. 541 -- 542 -- Discs gives the list of constraints that apply to Parent_Base in the 543 -- derived type declaration. If Discs is set to No_Elist, then we have 544 -- the following situation: 545 -- 546 -- type Parent (D1..Dn : ..) is [tagged] record ...; 547 -- type Derived is new Parent [with ...]; 548 -- 549 -- which gets treated as 550 -- 551 -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...]; 552 -- 553 -- For untagged types the returned value is an association list. The list 554 -- starts from the association (Parent_Base => Derived_Base), and then it 555 -- contains a sequence of the associations of the form 556 -- 557 -- (Old_Component => New_Component), 558 -- 559 -- where Old_Component is the Entity_Id of a component in Parent_Base and 560 -- New_Component is the Entity_Id of the corresponding component in 561 -- Derived_Base. For untagged records, this association list is needed when 562 -- copying the record declaration for the derived base. In the tagged case 563 -- the value returned is irrelevant. 564 565 procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id); 566 -- Propagate static and dynamic predicate flags from a parent to the 567 -- subtype in a subtype declaration with and without constraints. 568 569 function Is_EVF_Procedure (Subp : Entity_Id) return Boolean; 570 -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram. 571 -- Determine whether subprogram Subp is a procedure subject to pragma 572 -- Extensions_Visible with value False and has at least one controlling 573 -- parameter of mode OUT. 574 575 function Is_Valid_Constraint_Kind 576 (T_Kind : Type_Kind; 577 Constraint_Kind : Node_Kind) return Boolean; 578 -- Returns True if it is legal to apply the given kind of constraint to the 579 -- given kind of type (index constraint to an array type, for example). 580 581 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id); 582 -- Create new modular type. Verify that modulus is in bounds 583 584 procedure New_Concatenation_Op (Typ : Entity_Id); 585 -- Create an abbreviated declaration for an operator in order to 586 -- materialize concatenation on array types. 587 588 procedure Ordinary_Fixed_Point_Type_Declaration 589 (T : Entity_Id; 590 Def : Node_Id); 591 -- Create a new ordinary fixed point type, and apply the constraint to 592 -- obtain subtype of it. 593 594 procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id); 595 -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that 596 -- In_Default_Expr can be properly adjusted. 597 598 procedure Prepare_Private_Subtype_Completion 599 (Id : Entity_Id; 600 Related_Nod : Node_Id); 601 -- Id is a subtype of some private type. Creates the full declaration 602 -- associated with Id whenever possible, i.e. when the full declaration 603 -- of the base type is already known. Records each subtype into 604 -- Private_Dependents of the base type. 605 606 procedure Process_Incomplete_Dependents 607 (N : Node_Id; 608 Full_T : Entity_Id; 609 Inc_T : Entity_Id); 610 -- Process all entities that depend on an incomplete type. There include 611 -- subtypes, subprogram types that mention the incomplete type in their 612 -- profiles, and subprogram with access parameters that designate the 613 -- incomplete type. 614 615 -- Inc_T is the defining identifier of an incomplete type declaration, its 616 -- Ekind is E_Incomplete_Type. 617 -- 618 -- N is the corresponding N_Full_Type_Declaration for Inc_T. 619 -- 620 -- Full_T is N's defining identifier. 621 -- 622 -- Subtypes of incomplete types with discriminants are completed when the 623 -- parent type is. This is simpler than private subtypes, because they can 624 -- only appear in the same scope, and there is no need to exchange views. 625 -- Similarly, access_to_subprogram types may have a parameter or a return 626 -- type that is an incomplete type, and that must be replaced with the 627 -- full type. 628 -- 629 -- If the full type is tagged, subprogram with access parameters that 630 -- designated the incomplete may be primitive operations of the full type, 631 -- and have to be processed accordingly. 632 633 procedure Process_Real_Range_Specification (Def : Node_Id); 634 -- Given the type definition for a real type, this procedure processes and 635 -- checks the real range specification of this type definition if one is 636 -- present. If errors are found, error messages are posted, and the 637 -- Real_Range_Specification of Def is reset to Empty. 638 639 procedure Record_Type_Declaration 640 (T : Entity_Id; 641 N : Node_Id; 642 Prev : Entity_Id); 643 -- Process a record type declaration (for both untagged and tagged 644 -- records). Parameters T and N are exactly like in procedure 645 -- Derived_Type_Declaration, except that no flag Is_Completion is needed 646 -- for this routine. If this is the completion of an incomplete type 647 -- declaration, Prev is the entity of the incomplete declaration, used for 648 -- cross-referencing. Otherwise Prev = T. 649 650 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id); 651 -- This routine is used to process the actual record type definition (both 652 -- for untagged and tagged records). Def is a record type definition node. 653 -- This procedure analyzes the components in this record type definition. 654 -- Prev_T is the entity for the enclosing record type. It is provided so 655 -- that its Has_Task flag can be set if any of the component have Has_Task 656 -- set. If the declaration is the completion of an incomplete type 657 -- declaration, Prev_T is the original incomplete type, whose full view is 658 -- the record type. 659 660 procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id); 661 -- Subsidiary to Build_Derived_Record_Type. For untagged records, we 662 -- build a copy of the declaration tree of the parent, and we create 663 -- independently the list of components for the derived type. Semantic 664 -- information uses the component entities, but record representation 665 -- clauses are validated on the declaration tree. This procedure replaces 666 -- discriminants and components in the declaration with those that have 667 -- been created by Inherit_Components. 668 669 procedure Set_Fixed_Range 670 (E : Entity_Id; 671 Loc : Source_Ptr; 672 Lo : Ureal; 673 Hi : Ureal); 674 -- Build a range node with the given bounds and set it as the Scalar_Range 675 -- of the given fixed-point type entity. Loc is the source location used 676 -- for the constructed range. See body for further details. 677 678 procedure Set_Scalar_Range_For_Subtype 679 (Def_Id : Entity_Id; 680 R : Node_Id; 681 Subt : Entity_Id); 682 -- This routine is used to set the scalar range field for a subtype given 683 -- Def_Id, the entity for the subtype, and R, the range expression for the 684 -- scalar range. Subt provides the parent subtype to be used to analyze, 685 -- resolve, and check the given range. 686 687 procedure Set_Default_SSO (T : Entity_Id); 688 -- T is the entity for an array or record being declared. This procedure 689 -- sets the flags SSO_Set_Low_By_Default/SSO_Set_High_By_Default according 690 -- to the setting of Opt.Default_SSO. 691 692 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id); 693 -- Create a new signed integer entity, and apply the constraint to obtain 694 -- the required first named subtype of this type. 695 696 procedure Set_Stored_Constraint_From_Discriminant_Constraint 697 (E : Entity_Id); 698 -- E is some record type. This routine computes E's Stored_Constraint 699 -- from its Discriminant_Constraint. 700 701 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id); 702 -- Check that an entity in a list of progenitors is an interface, 703 -- emit error otherwise. 704 705 ----------------------- 706 -- Access_Definition -- 707 ----------------------- 708 709 function Access_Definition 710 (Related_Nod : Node_Id; 711 N : Node_Id) return Entity_Id 712 is 713 Anon_Type : Entity_Id; 714 Anon_Scope : Entity_Id; 715 Desig_Type : Entity_Id; 716 Enclosing_Prot_Type : Entity_Id := Empty; 717 718 begin 719 Check_SPARK_05_Restriction ("access type is not allowed", N); 720 721 if Is_Entry (Current_Scope) 722 and then Is_Task_Type (Etype (Scope (Current_Scope))) 723 then 724 Error_Msg_N ("task entries cannot have access parameters", N); 725 return Empty; 726 end if; 727 728 -- Ada 2005: For an object declaration the corresponding anonymous 729 -- type is declared in the current scope. 730 731 -- If the access definition is the return type of another access to 732 -- function, scope is the current one, because it is the one of the 733 -- current type declaration, except for the pathological case below. 734 735 if Nkind_In (Related_Nod, N_Object_Declaration, 736 N_Access_Function_Definition) 737 then 738 Anon_Scope := Current_Scope; 739 740 -- A pathological case: function returning access functions that 741 -- return access functions, etc. Each anonymous access type created 742 -- is in the enclosing scope of the outermost function. 743 744 declare 745 Par : Node_Id; 746 747 begin 748 Par := Related_Nod; 749 while Nkind_In (Par, N_Access_Function_Definition, 750 N_Access_Definition) 751 loop 752 Par := Parent (Par); 753 end loop; 754 755 if Nkind (Par) = N_Function_Specification then 756 Anon_Scope := Scope (Defining_Entity (Par)); 757 end if; 758 end; 759 760 -- For the anonymous function result case, retrieve the scope of the 761 -- function specification's associated entity rather than using the 762 -- current scope. The current scope will be the function itself if the 763 -- formal part is currently being analyzed, but will be the parent scope 764 -- in the case of a parameterless function, and we always want to use 765 -- the function's parent scope. Finally, if the function is a child 766 -- unit, we must traverse the tree to retrieve the proper entity. 767 768 elsif Nkind (Related_Nod) = N_Function_Specification 769 and then Nkind (Parent (N)) /= N_Parameter_Specification 770 then 771 -- If the current scope is a protected type, the anonymous access 772 -- is associated with one of the protected operations, and must 773 -- be available in the scope that encloses the protected declaration. 774 -- Otherwise the type is in the scope enclosing the subprogram. 775 776 -- If the function has formals, The return type of a subprogram 777 -- declaration is analyzed in the scope of the subprogram (see 778 -- Process_Formals) and thus the protected type, if present, is 779 -- the scope of the current function scope. 780 781 if Ekind (Current_Scope) = E_Protected_Type then 782 Enclosing_Prot_Type := Current_Scope; 783 784 elsif Ekind (Current_Scope) = E_Function 785 and then Ekind (Scope (Current_Scope)) = E_Protected_Type 786 then 787 Enclosing_Prot_Type := Scope (Current_Scope); 788 end if; 789 790 if Present (Enclosing_Prot_Type) then 791 Anon_Scope := Scope (Enclosing_Prot_Type); 792 793 else 794 Anon_Scope := Scope (Defining_Entity (Related_Nod)); 795 end if; 796 797 -- For an access type definition, if the current scope is a child 798 -- unit it is the scope of the type. 799 800 elsif Is_Compilation_Unit (Current_Scope) then 801 Anon_Scope := Current_Scope; 802 803 -- For access formals, access components, and access discriminants, the 804 -- scope is that of the enclosing declaration, 805 806 else 807 Anon_Scope := Scope (Current_Scope); 808 end if; 809 810 Anon_Type := 811 Create_Itype 812 (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); 813 814 if All_Present (N) 815 and then Ada_Version >= Ada_2005 816 then 817 Error_Msg_N ("ALL is not permitted for anonymous access types", N); 818 end if; 819 820 -- Ada 2005 (AI-254): In case of anonymous access to subprograms call 821 -- the corresponding semantic routine 822 823 if Present (Access_To_Subprogram_Definition (N)) then 824 825 -- Compiler runtime units are compiled in Ada 2005 mode when building 826 -- the runtime library but must also be compilable in Ada 95 mode 827 -- (when bootstrapping the compiler). 828 829 Check_Compiler_Unit ("anonymous access to subprogram", N); 830 831 Access_Subprogram_Declaration 832 (T_Name => Anon_Type, 833 T_Def => Access_To_Subprogram_Definition (N)); 834 835 if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then 836 Set_Ekind 837 (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type); 838 else 839 Set_Ekind (Anon_Type, E_Anonymous_Access_Subprogram_Type); 840 end if; 841 842 Set_Can_Use_Internal_Rep 843 (Anon_Type, not Always_Compatible_Rep_On_Target); 844 845 -- If the anonymous access is associated with a protected operation, 846 -- create a reference to it after the enclosing protected definition 847 -- because the itype will be used in the subsequent bodies. 848 849 -- If the anonymous access itself is protected, a full type 850 -- declaratiton will be created for it, so that the equivalent 851 -- record type can be constructed. For further details, see 852 -- Replace_Anonymous_Access_To_Protected-Subprogram. 853 854 if Ekind (Current_Scope) = E_Protected_Type 855 and then not Protected_Present (Access_To_Subprogram_Definition (N)) 856 then 857 Build_Itype_Reference (Anon_Type, Parent (Current_Scope)); 858 end if; 859 860 return Anon_Type; 861 end if; 862 863 Find_Type (Subtype_Mark (N)); 864 Desig_Type := Entity (Subtype_Mark (N)); 865 866 Set_Directly_Designated_Type (Anon_Type, Desig_Type); 867 Set_Etype (Anon_Type, Anon_Type); 868 869 -- Make sure the anonymous access type has size and alignment fields 870 -- set, as required by gigi. This is necessary in the case of the 871 -- Task_Body_Procedure. 872 873 if not Has_Private_Component (Desig_Type) then 874 Layout_Type (Anon_Type); 875 end if; 876 877 -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs 878 -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if 879 -- the null value is allowed. In Ada 95 the null value is never allowed. 880 881 if Ada_Version >= Ada_2005 then 882 Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N)); 883 else 884 Set_Can_Never_Be_Null (Anon_Type, True); 885 end if; 886 887 -- The anonymous access type is as public as the discriminated type or 888 -- subprogram that defines it. It is imported (for back-end purposes) 889 -- if the designated type is. 890 891 Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type))); 892 893 -- Ada 2005 (AI-231): Propagate the access-constant attribute 894 895 Set_Is_Access_Constant (Anon_Type, Constant_Present (N)); 896 897 -- The context is either a subprogram declaration, object declaration, 898 -- or an access discriminant, in a private or a full type declaration. 899 -- In the case of a subprogram, if the designated type is incomplete, 900 -- the operation will be a primitive operation of the full type, to be 901 -- updated subsequently. If the type is imported through a limited_with 902 -- clause, the subprogram is not a primitive operation of the type 903 -- (which is declared elsewhere in some other scope). 904 905 if Ekind (Desig_Type) = E_Incomplete_Type 906 and then not From_Limited_With (Desig_Type) 907 and then Is_Overloadable (Current_Scope) 908 then 909 Append_Elmt (Current_Scope, Private_Dependents (Desig_Type)); 910 Set_Has_Delayed_Freeze (Current_Scope); 911 end if; 912 913 -- If the designated type is limited and class-wide, the object might 914 -- contain tasks, so we create a Master entity for the declaration. This 915 -- must be done before expansion of the full declaration, because the 916 -- declaration may include an expression that is an allocator, whose 917 -- expansion needs the proper Master for the created tasks. 918 919 if Expander_Active 920 and then Nkind (Related_Nod) = N_Object_Declaration 921 then 922 if Is_Limited_Record (Desig_Type) 923 and then Is_Class_Wide_Type (Desig_Type) 924 and then Tasking_Allowed 925 then 926 Build_Class_Wide_Master (Anon_Type); 927 928 -- Similarly, if the type is an anonymous access that designates 929 -- tasks, create a master entity for it in the current context. 930 931 elsif Has_Task (Desig_Type) 932 and then Comes_From_Source (Related_Nod) 933 then 934 Build_Master_Entity (Defining_Identifier (Related_Nod)); 935 Build_Master_Renaming (Anon_Type); 936 end if; 937 end if; 938 939 -- For a private component of a protected type, it is imperative that 940 -- the back-end elaborate the type immediately after the protected 941 -- declaration, because this type will be used in the declarations 942 -- created for the component within each protected body, so we must 943 -- create an itype reference for it now. 944 945 if Nkind (Parent (Related_Nod)) = N_Protected_Definition then 946 Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod))); 947 948 -- Similarly, if the access definition is the return result of a 949 -- function, create an itype reference for it because it will be used 950 -- within the function body. For a regular function that is not a 951 -- compilation unit, insert reference after the declaration. For a 952 -- protected operation, insert it after the enclosing protected type 953 -- declaration. In either case, do not create a reference for a type 954 -- obtained through a limited_with clause, because this would introduce 955 -- semantic dependencies. 956 957 -- Similarly, do not create a reference if the designated type is a 958 -- generic formal, because no use of it will reach the backend. 959 960 elsif Nkind (Related_Nod) = N_Function_Specification 961 and then not From_Limited_With (Desig_Type) 962 and then not Is_Generic_Type (Desig_Type) 963 then 964 if Present (Enclosing_Prot_Type) then 965 Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type)); 966 967 elsif Is_List_Member (Parent (Related_Nod)) 968 and then Nkind (Parent (N)) /= N_Parameter_Specification 969 then 970 Build_Itype_Reference (Anon_Type, Parent (Related_Nod)); 971 end if; 972 973 -- Finally, create an itype reference for an object declaration of an 974 -- anonymous access type. This is strictly necessary only for deferred 975 -- constants, but in any case will avoid out-of-scope problems in the 976 -- back-end. 977 978 elsif Nkind (Related_Nod) = N_Object_Declaration then 979 Build_Itype_Reference (Anon_Type, Related_Nod); 980 end if; 981 982 return Anon_Type; 983 end Access_Definition; 984 985 ----------------------------------- 986 -- Access_Subprogram_Declaration -- 987 ----------------------------------- 988 989 procedure Access_Subprogram_Declaration 990 (T_Name : Entity_Id; 991 T_Def : Node_Id) 992 is 993 procedure Check_For_Premature_Usage (Def : Node_Id); 994 -- Check that type T_Name is not used, directly or recursively, as a 995 -- parameter or a return type in Def. Def is either a subtype, an 996 -- access_definition, or an access_to_subprogram_definition. 997 998 ------------------------------- 999 -- Check_For_Premature_Usage -- 1000 ------------------------------- 1001 1002 procedure Check_For_Premature_Usage (Def : Node_Id) is 1003 Param : Node_Id; 1004 1005 begin 1006 -- Check for a subtype mark 1007 1008 if Nkind (Def) in N_Has_Etype then 1009 if Etype (Def) = T_Name then 1010 Error_Msg_N 1011 ("type& cannot be used before end of its declaration", Def); 1012 end if; 1013 1014 -- If this is not a subtype, then this is an access_definition 1015 1016 elsif Nkind (Def) = N_Access_Definition then 1017 if Present (Access_To_Subprogram_Definition (Def)) then 1018 Check_For_Premature_Usage 1019 (Access_To_Subprogram_Definition (Def)); 1020 else 1021 Check_For_Premature_Usage (Subtype_Mark (Def)); 1022 end if; 1023 1024 -- The only cases left are N_Access_Function_Definition and 1025 -- N_Access_Procedure_Definition. 1026 1027 else 1028 if Present (Parameter_Specifications (Def)) then 1029 Param := First (Parameter_Specifications (Def)); 1030 while Present (Param) loop 1031 Check_For_Premature_Usage (Parameter_Type (Param)); 1032 Param := Next (Param); 1033 end loop; 1034 end if; 1035 1036 if Nkind (Def) = N_Access_Function_Definition then 1037 Check_For_Premature_Usage (Result_Definition (Def)); 1038 end if; 1039 end if; 1040 end Check_For_Premature_Usage; 1041 1042 -- Local variables 1043 1044 Formals : constant List_Id := Parameter_Specifications (T_Def); 1045 Formal : Entity_Id; 1046 D_Ityp : Node_Id; 1047 Desig_Type : constant Entity_Id := 1048 Create_Itype (E_Subprogram_Type, Parent (T_Def)); 1049 1050 -- Start of processing for Access_Subprogram_Declaration 1051 1052 begin 1053 Check_SPARK_05_Restriction ("access type is not allowed", T_Def); 1054 1055 -- Associate the Itype node with the inner full-type declaration or 1056 -- subprogram spec or entry body. This is required to handle nested 1057 -- anonymous declarations. For example: 1058 1059 -- procedure P 1060 -- (X : access procedure 1061 -- (Y : access procedure 1062 -- (Z : access T))) 1063 1064 D_Ityp := Associated_Node_For_Itype (Desig_Type); 1065 while not (Nkind_In (D_Ityp, N_Full_Type_Declaration, 1066 N_Private_Type_Declaration, 1067 N_Private_Extension_Declaration, 1068 N_Procedure_Specification, 1069 N_Function_Specification, 1070 N_Entry_Body) 1071 1072 or else 1073 Nkind_In (D_Ityp, N_Object_Declaration, 1074 N_Object_Renaming_Declaration, 1075 N_Formal_Object_Declaration, 1076 N_Formal_Type_Declaration, 1077 N_Task_Type_Declaration, 1078 N_Protected_Type_Declaration)) 1079 loop 1080 D_Ityp := Parent (D_Ityp); 1081 pragma Assert (D_Ityp /= Empty); 1082 end loop; 1083 1084 Set_Associated_Node_For_Itype (Desig_Type, D_Ityp); 1085 1086 if Nkind_In (D_Ityp, N_Procedure_Specification, 1087 N_Function_Specification) 1088 then 1089 Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp))); 1090 1091 elsif Nkind_In (D_Ityp, N_Full_Type_Declaration, 1092 N_Object_Declaration, 1093 N_Object_Renaming_Declaration, 1094 N_Formal_Type_Declaration) 1095 then 1096 Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp))); 1097 end if; 1098 1099 if Nkind (T_Def) = N_Access_Function_Definition then 1100 if Nkind (Result_Definition (T_Def)) = N_Access_Definition then 1101 declare 1102 Acc : constant Node_Id := Result_Definition (T_Def); 1103 1104 begin 1105 if Present (Access_To_Subprogram_Definition (Acc)) 1106 and then 1107 Protected_Present (Access_To_Subprogram_Definition (Acc)) 1108 then 1109 Set_Etype 1110 (Desig_Type, 1111 Replace_Anonymous_Access_To_Protected_Subprogram 1112 (T_Def)); 1113 1114 else 1115 Set_Etype 1116 (Desig_Type, 1117 Access_Definition (T_Def, Result_Definition (T_Def))); 1118 end if; 1119 end; 1120 1121 else 1122 Analyze (Result_Definition (T_Def)); 1123 1124 declare 1125 Typ : constant Entity_Id := Entity (Result_Definition (T_Def)); 1126 1127 begin 1128 -- If a null exclusion is imposed on the result type, then 1129 -- create a null-excluding itype (an access subtype) and use 1130 -- it as the function's Etype. 1131 1132 if Is_Access_Type (Typ) 1133 and then Null_Exclusion_In_Return_Present (T_Def) 1134 then 1135 Set_Etype (Desig_Type, 1136 Create_Null_Excluding_Itype 1137 (T => Typ, 1138 Related_Nod => T_Def, 1139 Scope_Id => Current_Scope)); 1140 1141 else 1142 if From_Limited_With (Typ) then 1143 1144 -- AI05-151: Incomplete types are allowed in all basic 1145 -- declarations, including access to subprograms. 1146 1147 if Ada_Version >= Ada_2012 then 1148 null; 1149 1150 else 1151 Error_Msg_NE 1152 ("illegal use of incomplete type&", 1153 Result_Definition (T_Def), Typ); 1154 end if; 1155 1156 elsif Ekind (Current_Scope) = E_Package 1157 and then In_Private_Part (Current_Scope) 1158 then 1159 if Ekind (Typ) = E_Incomplete_Type then 1160 Append_Elmt (Desig_Type, Private_Dependents (Typ)); 1161 1162 elsif Is_Class_Wide_Type (Typ) 1163 and then Ekind (Etype (Typ)) = E_Incomplete_Type 1164 then 1165 Append_Elmt 1166 (Desig_Type, Private_Dependents (Etype (Typ))); 1167 end if; 1168 end if; 1169 1170 Set_Etype (Desig_Type, Typ); 1171 end if; 1172 end; 1173 end if; 1174 1175 if not (Is_Type (Etype (Desig_Type))) then 1176 Error_Msg_N 1177 ("expect type in function specification", 1178 Result_Definition (T_Def)); 1179 end if; 1180 1181 else 1182 Set_Etype (Desig_Type, Standard_Void_Type); 1183 end if; 1184 1185 if Present (Formals) then 1186 Push_Scope (Desig_Type); 1187 1188 -- Some special tests here. These special tests can be removed 1189 -- if and when Itypes always have proper parent pointers to their 1190 -- declarations??? 1191 1192 -- Special test 1) Link defining_identifier of formals. Required by 1193 -- First_Formal to provide its functionality. 1194 1195 declare 1196 F : Node_Id; 1197 1198 begin 1199 F := First (Formals); 1200 1201 -- In ASIS mode, the access_to_subprogram may be analyzed twice, 1202 -- when it is part of an unconstrained type and subtype expansion 1203 -- is disabled. To avoid back-end problems with shared profiles, 1204 -- use previous subprogram type as the designated type, and then 1205 -- remove scope added above. 1206 1207 if ASIS_Mode and then Present (Scope (Defining_Identifier (F))) 1208 then 1209 Set_Etype (T_Name, T_Name); 1210 Init_Size_Align (T_Name); 1211 Set_Directly_Designated_Type (T_Name, 1212 Scope (Defining_Identifier (F))); 1213 End_Scope; 1214 return; 1215 end if; 1216 1217 while Present (F) loop 1218 if No (Parent (Defining_Identifier (F))) then 1219 Set_Parent (Defining_Identifier (F), F); 1220 end if; 1221 1222 Next (F); 1223 end loop; 1224 end; 1225 1226 Process_Formals (Formals, Parent (T_Def)); 1227 1228 -- Special test 2) End_Scope requires that the parent pointer be set 1229 -- to something reasonable, but Itypes don't have parent pointers. So 1230 -- we set it and then unset it ??? 1231 1232 Set_Parent (Desig_Type, T_Name); 1233 End_Scope; 1234 Set_Parent (Desig_Type, Empty); 1235 end if; 1236 1237 -- Check for premature usage of the type being defined 1238 1239 Check_For_Premature_Usage (T_Def); 1240 1241 -- The return type and/or any parameter type may be incomplete. Mark the 1242 -- subprogram_type as depending on the incomplete type, so that it can 1243 -- be updated when the full type declaration is seen. This only applies 1244 -- to incomplete types declared in some enclosing scope, not to limited 1245 -- views from other packages. 1246 1247 -- Prior to Ada 2012, access to functions can only have in_parameters. 1248 1249 if Present (Formals) then 1250 Formal := First_Formal (Desig_Type); 1251 while Present (Formal) loop 1252 if Ekind (Formal) /= E_In_Parameter 1253 and then Nkind (T_Def) = N_Access_Function_Definition 1254 and then Ada_Version < Ada_2012 1255 then 1256 Error_Msg_N ("functions can only have IN parameters", Formal); 1257 end if; 1258 1259 if Ekind (Etype (Formal)) = E_Incomplete_Type 1260 and then In_Open_Scopes (Scope (Etype (Formal))) 1261 then 1262 Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal))); 1263 Set_Has_Delayed_Freeze (Desig_Type); 1264 end if; 1265 1266 Next_Formal (Formal); 1267 end loop; 1268 end if; 1269 1270 -- Check whether an indirect call without actuals may be possible. This 1271 -- is used when resolving calls whose result is then indexed. 1272 1273 May_Need_Actuals (Desig_Type); 1274 1275 -- If the return type is incomplete, this is legal as long as the type 1276 -- is declared in the current scope and will be completed in it (rather 1277 -- than being part of limited view). 1278 1279 if Ekind (Etype (Desig_Type)) = E_Incomplete_Type 1280 and then not Has_Delayed_Freeze (Desig_Type) 1281 and then In_Open_Scopes (Scope (Etype (Desig_Type))) 1282 then 1283 Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type))); 1284 Set_Has_Delayed_Freeze (Desig_Type); 1285 end if; 1286 1287 Check_Delayed_Subprogram (Desig_Type); 1288 1289 if Protected_Present (T_Def) then 1290 Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type); 1291 Set_Convention (Desig_Type, Convention_Protected); 1292 else 1293 Set_Ekind (T_Name, E_Access_Subprogram_Type); 1294 end if; 1295 1296 Set_Can_Use_Internal_Rep (T_Name, 1297 not Always_Compatible_Rep_On_Target); 1298 Set_Etype (T_Name, T_Name); 1299 Init_Size_Align (T_Name); 1300 Set_Directly_Designated_Type (T_Name, Desig_Type); 1301 1302 -- If the access_to_subprogram is not declared at the library level, 1303 -- it can only point to subprograms that are at the same or deeper 1304 -- accessibility level. The corresponding subprogram type might 1305 -- require an activation record when compiling for C. 1306 1307 Set_Needs_Activation_Record (Desig_Type, 1308 not Is_Library_Level_Entity (T_Name)); 1309 1310 Generate_Reference_To_Formals (T_Name); 1311 1312 -- Ada 2005 (AI-231): Propagate the null-excluding attribute 1313 1314 Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def)); 1315 1316 Check_Restriction (No_Access_Subprograms, T_Def); 1317 end Access_Subprogram_Declaration; 1318 1319 ---------------------------- 1320 -- Access_Type_Declaration -- 1321 ---------------------------- 1322 1323 procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is 1324 P : constant Node_Id := Parent (Def); 1325 S : constant Node_Id := Subtype_Indication (Def); 1326 1327 Full_Desig : Entity_Id; 1328 1329 begin 1330 Check_SPARK_05_Restriction ("access type is not allowed", Def); 1331 1332 -- Check for permissible use of incomplete type 1333 1334 if Nkind (S) /= N_Subtype_Indication then 1335 Analyze (S); 1336 1337 if Present (Entity (S)) 1338 and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type 1339 then 1340 Set_Directly_Designated_Type (T, Entity (S)); 1341 1342 -- If the designated type is a limited view, we cannot tell if 1343 -- the full view contains tasks, and there is no way to handle 1344 -- that full view in a client. We create a master entity for the 1345 -- scope, which will be used when a client determines that one 1346 -- is needed. 1347 1348 if From_Limited_With (Entity (S)) 1349 and then not Is_Class_Wide_Type (Entity (S)) 1350 then 1351 Set_Ekind (T, E_Access_Type); 1352 Build_Master_Entity (T); 1353 Build_Master_Renaming (T); 1354 end if; 1355 1356 else 1357 Set_Directly_Designated_Type (T, Process_Subtype (S, P, T, 'P')); 1358 end if; 1359 1360 -- If the access definition is of the form: ACCESS NOT NULL .. 1361 -- the subtype indication must be of an access type. Create 1362 -- a null-excluding subtype of it. 1363 1364 if Null_Excluding_Subtype (Def) then 1365 if not Is_Access_Type (Entity (S)) then 1366 Error_Msg_N ("null exclusion must apply to access type", Def); 1367 1368 else 1369 declare 1370 Loc : constant Source_Ptr := Sloc (S); 1371 Decl : Node_Id; 1372 Nam : constant Entity_Id := Make_Temporary (Loc, 'S'); 1373 1374 begin 1375 Decl := 1376 Make_Subtype_Declaration (Loc, 1377 Defining_Identifier => Nam, 1378 Subtype_Indication => 1379 New_Occurrence_Of (Entity (S), Loc)); 1380 Set_Null_Exclusion_Present (Decl); 1381 Insert_Before (Parent (Def), Decl); 1382 Analyze (Decl); 1383 Set_Entity (S, Nam); 1384 end; 1385 end if; 1386 end if; 1387 1388 else 1389 Set_Directly_Designated_Type (T, 1390 Process_Subtype (S, P, T, 'P')); 1391 end if; 1392 1393 if All_Present (Def) or Constant_Present (Def) then 1394 Set_Ekind (T, E_General_Access_Type); 1395 else 1396 Set_Ekind (T, E_Access_Type); 1397 end if; 1398 1399 Full_Desig := Designated_Type (T); 1400 1401 if Base_Type (Full_Desig) = T then 1402 Error_Msg_N ("access type cannot designate itself", S); 1403 1404 -- In Ada 2005, the type may have a limited view through some unit in 1405 -- its own context, allowing the following circularity that cannot be 1406 -- detected earlier. 1407 1408 elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T 1409 then 1410 Error_Msg_N 1411 ("access type cannot designate its own class-wide type", S); 1412 1413 -- Clean up indication of tagged status to prevent cascaded errors 1414 1415 Set_Is_Tagged_Type (T, False); 1416 end if; 1417 1418 Set_Etype (T, T); 1419 1420 -- If the type has appeared already in a with_type clause, it is frozen 1421 -- and the pointer size is already set. Else, initialize. 1422 1423 if not From_Limited_With (T) then 1424 Init_Size_Align (T); 1425 end if; 1426 1427 -- Note that Has_Task is always false, since the access type itself 1428 -- is not a task type. See Einfo for more description on this point. 1429 -- Exactly the same consideration applies to Has_Controlled_Component 1430 -- and to Has_Protected. 1431 1432 Set_Has_Task (T, False); 1433 Set_Has_Protected (T, False); 1434 Set_Has_Timing_Event (T, False); 1435 Set_Has_Controlled_Component (T, False); 1436 1437 -- Initialize field Finalization_Master explicitly to Empty, to avoid 1438 -- problems where an incomplete view of this entity has been previously 1439 -- established by a limited with and an overlaid version of this field 1440 -- (Stored_Constraint) was initialized for the incomplete view. 1441 1442 -- This reset is performed in most cases except where the access type 1443 -- has been created for the purposes of allocating or deallocating a 1444 -- build-in-place object. Such access types have explicitly set pools 1445 -- and finalization masters. 1446 1447 if No (Associated_Storage_Pool (T)) then 1448 Set_Finalization_Master (T, Empty); 1449 end if; 1450 1451 -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant 1452 -- attributes 1453 1454 Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def)); 1455 Set_Is_Access_Constant (T, Constant_Present (Def)); 1456 end Access_Type_Declaration; 1457 1458 ---------------------------------- 1459 -- Add_Interface_Tag_Components -- 1460 ---------------------------------- 1461 1462 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is 1463 Loc : constant Source_Ptr := Sloc (N); 1464 L : List_Id; 1465 Last_Tag : Node_Id; 1466 1467 procedure Add_Tag (Iface : Entity_Id); 1468 -- Add tag for one of the progenitor interfaces 1469 1470 ------------- 1471 -- Add_Tag -- 1472 ------------- 1473 1474 procedure Add_Tag (Iface : Entity_Id) is 1475 Decl : Node_Id; 1476 Def : Node_Id; 1477 Tag : Entity_Id; 1478 Offset : Entity_Id; 1479 1480 begin 1481 pragma Assert (Is_Tagged_Type (Iface) and then Is_Interface (Iface)); 1482 1483 -- This is a reasonable place to propagate predicates 1484 1485 if Has_Predicates (Iface) then 1486 Set_Has_Predicates (Typ); 1487 end if; 1488 1489 Def := 1490 Make_Component_Definition (Loc, 1491 Aliased_Present => True, 1492 Subtype_Indication => 1493 New_Occurrence_Of (RTE (RE_Interface_Tag), Loc)); 1494 1495 Tag := Make_Temporary (Loc, 'V'); 1496 1497 Decl := 1498 Make_Component_Declaration (Loc, 1499 Defining_Identifier => Tag, 1500 Component_Definition => Def); 1501 1502 Analyze_Component_Declaration (Decl); 1503 1504 Set_Analyzed (Decl); 1505 Set_Ekind (Tag, E_Component); 1506 Set_Is_Tag (Tag); 1507 Set_Is_Aliased (Tag); 1508 Set_Is_Independent (Tag); 1509 Set_Related_Type (Tag, Iface); 1510 Init_Component_Location (Tag); 1511 1512 pragma Assert (Is_Frozen (Iface)); 1513 1514 Set_DT_Entry_Count (Tag, 1515 DT_Entry_Count (First_Entity (Iface))); 1516 1517 if No (Last_Tag) then 1518 Prepend (Decl, L); 1519 else 1520 Insert_After (Last_Tag, Decl); 1521 end if; 1522 1523 Last_Tag := Decl; 1524 1525 -- If the ancestor has discriminants we need to give special support 1526 -- to store the offset_to_top value of the secondary dispatch tables. 1527 -- For this purpose we add a supplementary component just after the 1528 -- field that contains the tag associated with each secondary DT. 1529 1530 if Typ /= Etype (Typ) and then Has_Discriminants (Etype (Typ)) then 1531 Def := 1532 Make_Component_Definition (Loc, 1533 Subtype_Indication => 1534 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); 1535 1536 Offset := Make_Temporary (Loc, 'V'); 1537 1538 Decl := 1539 Make_Component_Declaration (Loc, 1540 Defining_Identifier => Offset, 1541 Component_Definition => Def); 1542 1543 Analyze_Component_Declaration (Decl); 1544 1545 Set_Analyzed (Decl); 1546 Set_Ekind (Offset, E_Component); 1547 Set_Is_Aliased (Offset); 1548 Set_Is_Independent (Offset); 1549 Set_Related_Type (Offset, Iface); 1550 Init_Component_Location (Offset); 1551 Insert_After (Last_Tag, Decl); 1552 Last_Tag := Decl; 1553 end if; 1554 end Add_Tag; 1555 1556 -- Local variables 1557 1558 Elmt : Elmt_Id; 1559 Ext : Node_Id; 1560 Comp : Node_Id; 1561 1562 -- Start of processing for Add_Interface_Tag_Components 1563 1564 begin 1565 if not RTE_Available (RE_Interface_Tag) then 1566 Error_Msg 1567 ("(Ada 2005) interface types not supported by this run-time!", 1568 Sloc (N)); 1569 return; 1570 end if; 1571 1572 if Ekind (Typ) /= E_Record_Type 1573 or else (Is_Concurrent_Record_Type (Typ) 1574 and then Is_Empty_List (Abstract_Interface_List (Typ))) 1575 or else (not Is_Concurrent_Record_Type (Typ) 1576 and then No (Interfaces (Typ)) 1577 and then Is_Empty_Elmt_List (Interfaces (Typ))) 1578 then 1579 return; 1580 end if; 1581 1582 -- Find the current last tag 1583 1584 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 1585 Ext := Record_Extension_Part (Type_Definition (N)); 1586 else 1587 pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition); 1588 Ext := Type_Definition (N); 1589 end if; 1590 1591 Last_Tag := Empty; 1592 1593 if not (Present (Component_List (Ext))) then 1594 Set_Null_Present (Ext, False); 1595 L := New_List; 1596 Set_Component_List (Ext, 1597 Make_Component_List (Loc, 1598 Component_Items => L, 1599 Null_Present => False)); 1600 else 1601 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 1602 L := Component_Items 1603 (Component_List 1604 (Record_Extension_Part 1605 (Type_Definition (N)))); 1606 else 1607 L := Component_Items 1608 (Component_List 1609 (Type_Definition (N))); 1610 end if; 1611 1612 -- Find the last tag component 1613 1614 Comp := First (L); 1615 while Present (Comp) loop 1616 if Nkind (Comp) = N_Component_Declaration 1617 and then Is_Tag (Defining_Identifier (Comp)) 1618 then 1619 Last_Tag := Comp; 1620 end if; 1621 1622 Next (Comp); 1623 end loop; 1624 end if; 1625 1626 -- At this point L references the list of components and Last_Tag 1627 -- references the current last tag (if any). Now we add the tag 1628 -- corresponding with all the interfaces that are not implemented 1629 -- by the parent. 1630 1631 if Present (Interfaces (Typ)) then 1632 Elmt := First_Elmt (Interfaces (Typ)); 1633 while Present (Elmt) loop 1634 Add_Tag (Node (Elmt)); 1635 Next_Elmt (Elmt); 1636 end loop; 1637 end if; 1638 end Add_Interface_Tag_Components; 1639 1640 ------------------------------------- 1641 -- Add_Internal_Interface_Entities -- 1642 ------------------------------------- 1643 1644 procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is 1645 Elmt : Elmt_Id; 1646 Iface : Entity_Id; 1647 Iface_Elmt : Elmt_Id; 1648 Iface_Prim : Entity_Id; 1649 Ifaces_List : Elist_Id; 1650 New_Subp : Entity_Id := Empty; 1651 Prim : Entity_Id; 1652 Restore_Scope : Boolean := False; 1653 1654 begin 1655 pragma Assert (Ada_Version >= Ada_2005 1656 and then Is_Record_Type (Tagged_Type) 1657 and then Is_Tagged_Type (Tagged_Type) 1658 and then Has_Interfaces (Tagged_Type) 1659 and then not Is_Interface (Tagged_Type)); 1660 1661 -- Ensure that the internal entities are added to the scope of the type 1662 1663 if Scope (Tagged_Type) /= Current_Scope then 1664 Push_Scope (Scope (Tagged_Type)); 1665 Restore_Scope := True; 1666 end if; 1667 1668 Collect_Interfaces (Tagged_Type, Ifaces_List); 1669 1670 Iface_Elmt := First_Elmt (Ifaces_List); 1671 while Present (Iface_Elmt) loop 1672 Iface := Node (Iface_Elmt); 1673 1674 -- Originally we excluded here from this processing interfaces that 1675 -- are parents of Tagged_Type because their primitives are located 1676 -- in the primary dispatch table (and hence no auxiliary internal 1677 -- entities are required to handle secondary dispatch tables in such 1678 -- case). However, these auxiliary entities are also required to 1679 -- handle derivations of interfaces in formals of generics (see 1680 -- Derive_Subprograms). 1681 1682 Elmt := First_Elmt (Primitive_Operations (Iface)); 1683 while Present (Elmt) loop 1684 Iface_Prim := Node (Elmt); 1685 1686 if not Is_Predefined_Dispatching_Operation (Iface_Prim) then 1687 Prim := 1688 Find_Primitive_Covering_Interface 1689 (Tagged_Type => Tagged_Type, 1690 Iface_Prim => Iface_Prim); 1691 1692 if No (Prim) and then Serious_Errors_Detected > 0 then 1693 goto Continue; 1694 end if; 1695 1696 pragma Assert (Present (Prim)); 1697 1698 -- Ada 2012 (AI05-0197): If the name of the covering primitive 1699 -- differs from the name of the interface primitive then it is 1700 -- a private primitive inherited from a parent type. In such 1701 -- case, given that Tagged_Type covers the interface, the 1702 -- inherited private primitive becomes visible. For such 1703 -- purpose we add a new entity that renames the inherited 1704 -- private primitive. 1705 1706 if Chars (Prim) /= Chars (Iface_Prim) then 1707 pragma Assert (Has_Suffix (Prim, 'P')); 1708 Derive_Subprogram 1709 (New_Subp => New_Subp, 1710 Parent_Subp => Iface_Prim, 1711 Derived_Type => Tagged_Type, 1712 Parent_Type => Iface); 1713 Set_Alias (New_Subp, Prim); 1714 Set_Is_Abstract_Subprogram 1715 (New_Subp, Is_Abstract_Subprogram (Prim)); 1716 end if; 1717 1718 Derive_Subprogram 1719 (New_Subp => New_Subp, 1720 Parent_Subp => Iface_Prim, 1721 Derived_Type => Tagged_Type, 1722 Parent_Type => Iface); 1723 1724 declare 1725 Anc : Entity_Id; 1726 begin 1727 if Is_Inherited_Operation (Prim) 1728 and then Present (Alias (Prim)) 1729 then 1730 Anc := Alias (Prim); 1731 else 1732 Anc := Overridden_Operation (Prim); 1733 end if; 1734 1735 -- Apply legality checks in RM 6.1.1 (10-13) concerning 1736 -- nonconforming preconditions in both an ancestor and 1737 -- a progenitor operation. 1738 1739 -- If the operation is a primitive wrapper it is an explicit 1740 -- (overriding) operqtion and all is fine. 1741 1742 if Present (Anc) 1743 and then Has_Non_Trivial_Precondition (Anc) 1744 and then Has_Non_Trivial_Precondition (Iface_Prim) 1745 then 1746 if Is_Abstract_Subprogram (Prim) 1747 or else 1748 (Ekind (Prim) = E_Procedure 1749 and then Nkind (Parent (Prim)) = 1750 N_Procedure_Specification 1751 and then Null_Present (Parent (Prim))) 1752 or else Is_Primitive_Wrapper (Prim) 1753 then 1754 null; 1755 1756 -- The operation is inherited and must be overridden 1757 1758 elsif not Comes_From_Source (Prim) then 1759 Error_Msg_NE 1760 ("&inherits non-conforming preconditions and must " 1761 & "be overridden (RM 6.1.1 (10-16)", 1762 Parent (Tagged_Type), Prim); 1763 end if; 1764 end if; 1765 end; 1766 1767 -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp 1768 -- associated with interface types. These entities are 1769 -- only registered in the list of primitives of its 1770 -- corresponding tagged type because they are only used 1771 -- to fill the contents of the secondary dispatch tables. 1772 -- Therefore they are removed from the homonym chains. 1773 1774 Set_Is_Hidden (New_Subp); 1775 Set_Is_Internal (New_Subp); 1776 Set_Alias (New_Subp, Prim); 1777 Set_Is_Abstract_Subprogram 1778 (New_Subp, Is_Abstract_Subprogram (Prim)); 1779 Set_Interface_Alias (New_Subp, Iface_Prim); 1780 1781 -- If the returned type is an interface then propagate it to 1782 -- the returned type. Needed by the thunk to generate the code 1783 -- which displaces "this" to reference the corresponding 1784 -- secondary dispatch table in the returned object. 1785 1786 if Is_Interface (Etype (Iface_Prim)) then 1787 Set_Etype (New_Subp, Etype (Iface_Prim)); 1788 end if; 1789 1790 -- Internal entities associated with interface types are only 1791 -- registered in the list of primitives of the tagged type. 1792 -- They are only used to fill the contents of the secondary 1793 -- dispatch tables. Therefore they are not needed in the 1794 -- homonym chains. 1795 1796 Remove_Homonym (New_Subp); 1797 1798 -- Hidden entities associated with interfaces must have set 1799 -- the Has_Delay_Freeze attribute to ensure that, in case 1800 -- of locally defined tagged types (or compiling with static 1801 -- dispatch tables generation disabled) the corresponding 1802 -- entry of the secondary dispatch table is filled when such 1803 -- an entity is frozen. This is an expansion activity that must 1804 -- be suppressed for ASIS because it leads to gigi elaboration 1805 -- issues in annotate mode. 1806 1807 if not ASIS_Mode then 1808 Set_Has_Delayed_Freeze (New_Subp); 1809 end if; 1810 end if; 1811 1812 <<Continue>> 1813 Next_Elmt (Elmt); 1814 end loop; 1815 1816 Next_Elmt (Iface_Elmt); 1817 end loop; 1818 1819 if Restore_Scope then 1820 Pop_Scope; 1821 end if; 1822 end Add_Internal_Interface_Entities; 1823 1824 ----------------------------------- 1825 -- Analyze_Component_Declaration -- 1826 ----------------------------------- 1827 1828 procedure Analyze_Component_Declaration (N : Node_Id) is 1829 Loc : constant Source_Ptr := Sloc (Component_Definition (N)); 1830 Id : constant Entity_Id := Defining_Identifier (N); 1831 E : constant Node_Id := Expression (N); 1832 Typ : constant Node_Id := 1833 Subtype_Indication (Component_Definition (N)); 1834 T : Entity_Id; 1835 P : Entity_Id; 1836 1837 function Contains_POC (Constr : Node_Id) return Boolean; 1838 -- Determines whether a constraint uses the discriminant of a record 1839 -- type thus becoming a per-object constraint (POC). 1840 1841 function Is_Known_Limited (Typ : Entity_Id) return Boolean; 1842 -- Typ is the type of the current component, check whether this type is 1843 -- a limited type. Used to validate declaration against that of 1844 -- enclosing record. 1845 1846 ------------------ 1847 -- Contains_POC -- 1848 ------------------ 1849 1850 function Contains_POC (Constr : Node_Id) return Boolean is 1851 begin 1852 -- Prevent cascaded errors 1853 1854 if Error_Posted (Constr) then 1855 return False; 1856 end if; 1857 1858 case Nkind (Constr) is 1859 when N_Attribute_Reference => 1860 return Attribute_Name (Constr) = Name_Access 1861 and then Prefix (Constr) = Scope (Entity (Prefix (Constr))); 1862 1863 when N_Discriminant_Association => 1864 return Denotes_Discriminant (Expression (Constr)); 1865 1866 when N_Identifier => 1867 return Denotes_Discriminant (Constr); 1868 1869 when N_Index_Or_Discriminant_Constraint => 1870 declare 1871 IDC : Node_Id; 1872 1873 begin 1874 IDC := First (Constraints (Constr)); 1875 while Present (IDC) loop 1876 1877 -- One per-object constraint is sufficient 1878 1879 if Contains_POC (IDC) then 1880 return True; 1881 end if; 1882 1883 Next (IDC); 1884 end loop; 1885 1886 return False; 1887 end; 1888 1889 when N_Range => 1890 return Denotes_Discriminant (Low_Bound (Constr)) 1891 or else 1892 Denotes_Discriminant (High_Bound (Constr)); 1893 1894 when N_Range_Constraint => 1895 return Denotes_Discriminant (Range_Expression (Constr)); 1896 1897 when others => 1898 return False; 1899 end case; 1900 end Contains_POC; 1901 1902 ---------------------- 1903 -- Is_Known_Limited -- 1904 ---------------------- 1905 1906 function Is_Known_Limited (Typ : Entity_Id) return Boolean is 1907 P : constant Entity_Id := Etype (Typ); 1908 R : constant Entity_Id := Root_Type (Typ); 1909 1910 begin 1911 if Is_Limited_Record (Typ) then 1912 return True; 1913 1914 -- If the root type is limited (and not a limited interface) so is 1915 -- the current type. 1916 1917 elsif Is_Limited_Record (R) 1918 and then (not Is_Interface (R) or else not Is_Limited_Interface (R)) 1919 then 1920 return True; 1921 1922 -- Else the type may have a limited interface progenitor, but a 1923 -- limited record parent that is not an interface. 1924 1925 elsif R /= P 1926 and then Is_Limited_Record (P) 1927 and then not Is_Interface (P) 1928 then 1929 return True; 1930 1931 else 1932 return False; 1933 end if; 1934 end Is_Known_Limited; 1935 1936 -- Start of processing for Analyze_Component_Declaration 1937 1938 begin 1939 Generate_Definition (Id); 1940 Enter_Name (Id); 1941 1942 if Present (Typ) then 1943 T := Find_Type_Of_Object 1944 (Subtype_Indication (Component_Definition (N)), N); 1945 1946 if not Nkind_In (Typ, N_Identifier, N_Expanded_Name) then 1947 Check_SPARK_05_Restriction ("subtype mark required", Typ); 1948 end if; 1949 1950 -- Ada 2005 (AI-230): Access Definition case 1951 1952 else 1953 pragma Assert (Present 1954 (Access_Definition (Component_Definition (N)))); 1955 1956 T := Access_Definition 1957 (Related_Nod => N, 1958 N => Access_Definition (Component_Definition (N))); 1959 Set_Is_Local_Anonymous_Access (T); 1960 1961 -- Ada 2005 (AI-254) 1962 1963 if Present (Access_To_Subprogram_Definition 1964 (Access_Definition (Component_Definition (N)))) 1965 and then Protected_Present (Access_To_Subprogram_Definition 1966 (Access_Definition 1967 (Component_Definition (N)))) 1968 then 1969 T := Replace_Anonymous_Access_To_Protected_Subprogram (N); 1970 end if; 1971 end if; 1972 1973 -- If the subtype is a constrained subtype of the enclosing record, 1974 -- (which must have a partial view) the back-end does not properly 1975 -- handle the recursion. Rewrite the component declaration with an 1976 -- explicit subtype indication, which is acceptable to Gigi. We can copy 1977 -- the tree directly because side effects have already been removed from 1978 -- discriminant constraints. 1979 1980 if Ekind (T) = E_Access_Subtype 1981 and then Is_Entity_Name (Subtype_Indication (Component_Definition (N))) 1982 and then Comes_From_Source (T) 1983 and then Nkind (Parent (T)) = N_Subtype_Declaration 1984 and then Etype (Directly_Designated_Type (T)) = Current_Scope 1985 then 1986 Rewrite 1987 (Subtype_Indication (Component_Definition (N)), 1988 New_Copy_Tree (Subtype_Indication (Parent (T)))); 1989 T := Find_Type_Of_Object 1990 (Subtype_Indication (Component_Definition (N)), N); 1991 end if; 1992 1993 -- If the component declaration includes a default expression, then we 1994 -- check that the component is not of a limited type (RM 3.7(5)), 1995 -- and do the special preanalysis of the expression (see section on 1996 -- "Handling of Default and Per-Object Expressions" in the spec of 1997 -- package Sem). 1998 1999 if Present (E) then 2000 Check_SPARK_05_Restriction ("default expression is not allowed", E); 2001 Preanalyze_Default_Expression (E, T); 2002 Check_Initialization (T, E); 2003 2004 if Ada_Version >= Ada_2005 2005 and then Ekind (T) = E_Anonymous_Access_Type 2006 and then Etype (E) /= Any_Type 2007 then 2008 -- Check RM 3.9.2(9): "if the expected type for an expression is 2009 -- an anonymous access-to-specific tagged type, then the object 2010 -- designated by the expression shall not be dynamically tagged 2011 -- unless it is a controlling operand in a call on a dispatching 2012 -- operation" 2013 2014 if Is_Tagged_Type (Directly_Designated_Type (T)) 2015 and then 2016 Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type 2017 and then 2018 Ekind (Directly_Designated_Type (Etype (E))) = 2019 E_Class_Wide_Type 2020 then 2021 Error_Msg_N 2022 ("access to specific tagged type required (RM 3.9.2(9))", E); 2023 end if; 2024 2025 -- (Ada 2005: AI-230): Accessibility check for anonymous 2026 -- components 2027 2028 if Type_Access_Level (Etype (E)) > 2029 Deepest_Type_Access_Level (T) 2030 then 2031 Error_Msg_N 2032 ("expression has deeper access level than component " & 2033 "(RM 3.10.2 (12.2))", E); 2034 end if; 2035 2036 -- The initialization expression is a reference to an access 2037 -- discriminant. The type of the discriminant is always deeper 2038 -- than any access type. 2039 2040 if Ekind (Etype (E)) = E_Anonymous_Access_Type 2041 and then Is_Entity_Name (E) 2042 and then Ekind (Entity (E)) = E_In_Parameter 2043 and then Present (Discriminal_Link (Entity (E))) 2044 then 2045 Error_Msg_N 2046 ("discriminant has deeper accessibility level than target", 2047 E); 2048 end if; 2049 end if; 2050 end if; 2051 2052 -- Avoid reporting spurious errors if the component is initialized with 2053 -- a raise expression (which is legal in any expression context) 2054 2055 if Present (E) 2056 and then 2057 (Nkind (E) = N_Raise_Expression 2058 or else (Nkind (E) = N_Qualified_Expression 2059 and then Nkind (Expression (E)) = N_Raise_Expression)) 2060 then 2061 null; 2062 2063 -- The parent type may be a private view with unknown discriminants, 2064 -- and thus unconstrained. Regular components must be constrained. 2065 2066 elsif not Is_Definite_Subtype (T) 2067 and then Chars (Id) /= Name_uParent 2068 then 2069 if Is_Class_Wide_Type (T) then 2070 Error_Msg_N 2071 ("class-wide subtype with unknown discriminants" & 2072 " in component declaration", 2073 Subtype_Indication (Component_Definition (N))); 2074 else 2075 Error_Msg_N 2076 ("unconstrained subtype in component declaration", 2077 Subtype_Indication (Component_Definition (N))); 2078 end if; 2079 2080 -- Components cannot be abstract, except for the special case of 2081 -- the _Parent field (case of extending an abstract tagged type) 2082 2083 elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then 2084 Error_Msg_N ("type of a component cannot be abstract", N); 2085 end if; 2086 2087 Set_Etype (Id, T); 2088 2089 if Aliased_Present (Component_Definition (N)) then 2090 Set_Is_Aliased (Id); 2091 2092 -- AI12-001: All aliased objects are considered to be specified as 2093 -- independently addressable (RM C.6(8.1/4)). 2094 2095 Set_Is_Independent (Id); 2096 end if; 2097 2098 -- The component declaration may have a per-object constraint, set 2099 -- the appropriate flag in the defining identifier of the subtype. 2100 2101 if Present (Subtype_Indication (Component_Definition (N))) then 2102 declare 2103 Sindic : constant Node_Id := 2104 Subtype_Indication (Component_Definition (N)); 2105 begin 2106 if Nkind (Sindic) = N_Subtype_Indication 2107 and then Present (Constraint (Sindic)) 2108 and then Contains_POC (Constraint (Sindic)) 2109 then 2110 Set_Has_Per_Object_Constraint (Id); 2111 end if; 2112 end; 2113 end if; 2114 2115 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry 2116 -- out some static checks. 2117 2118 if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then 2119 Null_Exclusion_Static_Checks (N); 2120 end if; 2121 2122 -- If this component is private (or depends on a private type), flag the 2123 -- record type to indicate that some operations are not available. 2124 2125 P := Private_Component (T); 2126 2127 if Present (P) then 2128 2129 -- Check for circular definitions 2130 2131 if P = Any_Type then 2132 Set_Etype (Id, Any_Type); 2133 2134 -- There is a gap in the visibility of operations only if the 2135 -- component type is not defined in the scope of the record type. 2136 2137 elsif Scope (P) = Scope (Current_Scope) then 2138 null; 2139 2140 elsif Is_Limited_Type (P) then 2141 Set_Is_Limited_Composite (Current_Scope); 2142 2143 else 2144 Set_Is_Private_Composite (Current_Scope); 2145 end if; 2146 end if; 2147 2148 if P /= Any_Type 2149 and then Is_Limited_Type (T) 2150 and then Chars (Id) /= Name_uParent 2151 and then Is_Tagged_Type (Current_Scope) 2152 then 2153 if Is_Derived_Type (Current_Scope) 2154 and then not Is_Known_Limited (Current_Scope) 2155 then 2156 Error_Msg_N 2157 ("extension of nonlimited type cannot have limited components", 2158 N); 2159 2160 if Is_Interface (Root_Type (Current_Scope)) then 2161 Error_Msg_N 2162 ("\limitedness is not inherited from limited interface", N); 2163 Error_Msg_N ("\add LIMITED to type indication", N); 2164 end if; 2165 2166 Explain_Limited_Type (T, N); 2167 Set_Etype (Id, Any_Type); 2168 Set_Is_Limited_Composite (Current_Scope, False); 2169 2170 elsif not Is_Derived_Type (Current_Scope) 2171 and then not Is_Limited_Record (Current_Scope) 2172 and then not Is_Concurrent_Type (Current_Scope) 2173 then 2174 Error_Msg_N 2175 ("nonlimited tagged type cannot have limited components", N); 2176 Explain_Limited_Type (T, N); 2177 Set_Etype (Id, Any_Type); 2178 Set_Is_Limited_Composite (Current_Scope, False); 2179 end if; 2180 end if; 2181 2182 -- If the component is an unconstrained task or protected type with 2183 -- discriminants, the component and the enclosing record are limited 2184 -- and the component is constrained by its default values. Compute 2185 -- its actual subtype, else it may be allocated the maximum size by 2186 -- the backend, and possibly overflow. 2187 2188 if Is_Concurrent_Type (T) 2189 and then not Is_Constrained (T) 2190 and then Has_Discriminants (T) 2191 and then not Has_Discriminants (Current_Scope) 2192 then 2193 declare 2194 Act_T : constant Entity_Id := Build_Default_Subtype (T, N); 2195 2196 begin 2197 Set_Etype (Id, Act_T); 2198 2199 -- Rewrite component definition to use the constrained subtype 2200 2201 Rewrite (Component_Definition (N), 2202 Make_Component_Definition (Loc, 2203 Subtype_Indication => New_Occurrence_Of (Act_T, Loc))); 2204 end; 2205 end if; 2206 2207 Set_Original_Record_Component (Id, Id); 2208 2209 if Has_Aspects (N) then 2210 Analyze_Aspect_Specifications (N, Id); 2211 end if; 2212 2213 Analyze_Dimension (N); 2214 end Analyze_Component_Declaration; 2215 2216 -------------------------- 2217 -- Analyze_Declarations -- 2218 -------------------------- 2219 2220 procedure Analyze_Declarations (L : List_Id) is 2221 Decl : Node_Id; 2222 2223 procedure Adjust_Decl; 2224 -- Adjust Decl not to include implicit label declarations, since these 2225 -- have strange Sloc values that result in elaboration check problems. 2226 -- (They have the sloc of the label as found in the source, and that 2227 -- is ahead of the current declarative part). 2228 2229 procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id); 2230 -- Create the subprogram bodies which verify the run-time semantics of 2231 -- the pragmas listed below for each elibigle type found in declarative 2232 -- list Decls. The pragmas are: 2233 -- 2234 -- Default_Initial_Condition 2235 -- Invariant 2236 -- Type_Invariant 2237 -- 2238 -- Context denotes the owner of the declarative list. 2239 2240 procedure Check_Entry_Contracts; 2241 -- Perform a preanalysis of the pre- and postconditions of an entry 2242 -- declaration. This must be done before full resolution and creation 2243 -- of the parameter block, etc. to catch illegal uses within the 2244 -- contract expression. Full analysis of the expression is done when 2245 -- the contract is processed. 2246 2247 function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean; 2248 -- Check if a nested package has entities within it that rely on library 2249 -- level private types where the full view has not been completed for 2250 -- the purposes of checking if it is acceptable to freeze an expression 2251 -- function at the point of declaration. 2252 2253 procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id); 2254 -- Determine whether Body_Decl denotes the body of a late controlled 2255 -- primitive (either Initialize, Adjust or Finalize). If this is the 2256 -- case, add a proper spec if the body lacks one. The spec is inserted 2257 -- before Body_Decl and immediately analyzed. 2258 2259 procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id); 2260 -- Spec_Id is the entity of a package that may define abstract states, 2261 -- and in the case of a child unit, whose ancestors may define abstract 2262 -- states. If the states have partial visible refinement, remove the 2263 -- partial visibility of each constituent at the end of the package 2264 -- spec and body declarations. 2265 2266 procedure Remove_Visible_Refinements (Spec_Id : Entity_Id); 2267 -- Spec_Id is the entity of a package that may define abstract states. 2268 -- If the states have visible refinement, remove the visibility of each 2269 -- constituent at the end of the package body declaration. 2270 2271 procedure Resolve_Aspects; 2272 -- Utility to resolve the expressions of aspects at the end of a list of 2273 -- declarations, or before a declaration that freezes previous entities, 2274 -- such as in a subprogram body. 2275 2276 ----------------- 2277 -- Adjust_Decl -- 2278 ----------------- 2279 2280 procedure Adjust_Decl is 2281 begin 2282 while Present (Prev (Decl)) 2283 and then Nkind (Decl) = N_Implicit_Label_Declaration 2284 loop 2285 Prev (Decl); 2286 end loop; 2287 end Adjust_Decl; 2288 2289 ---------------------------- 2290 -- Build_Assertion_Bodies -- 2291 ---------------------------- 2292 2293 procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id) is 2294 procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id); 2295 -- Create the subprogram bodies which verify the run-time semantics 2296 -- of the pragmas listed below for type Typ. The pragmas are: 2297 -- 2298 -- Default_Initial_Condition 2299 -- Invariant 2300 -- Type_Invariant 2301 2302 ------------------------------------- 2303 -- Build_Assertion_Bodies_For_Type -- 2304 ------------------------------------- 2305 2306 procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id) is 2307 begin 2308 -- Preanalyze and resolve the Default_Initial_Condition assertion 2309 -- expression at the end of the declarations to catch any errors. 2310 2311 if Has_DIC (Typ) then 2312 Build_DIC_Procedure_Body (Typ); 2313 end if; 2314 2315 if Nkind (Context) = N_Package_Specification then 2316 2317 -- Preanalyze and resolve the class-wide invariants of an 2318 -- interface at the end of whichever declarative part has the 2319 -- interface type. Note that an interface may be declared in 2320 -- any non-package declarative part, but reaching the end of 2321 -- such a declarative part will always freeze the type and 2322 -- generate the invariant procedure (see Freeze_Type). 2323 2324 if Is_Interface (Typ) then 2325 2326 -- Interfaces are treated as the partial view of a private 2327 -- type, in order to achieve uniformity with the general 2328 -- case. As a result, an interface receives only a "partial" 2329 -- invariant procedure, which is never called. 2330 2331 if Has_Own_Invariants (Typ) then 2332 Build_Invariant_Procedure_Body 2333 (Typ => Typ, 2334 Partial_Invariant => True); 2335 end if; 2336 2337 -- Preanalyze and resolve the invariants of a private type 2338 -- at the end of the visible declarations to catch potential 2339 -- errors. Inherited class-wide invariants are not included 2340 -- because they have already been resolved. 2341 2342 elsif Decls = Visible_Declarations (Context) 2343 and then Ekind_In (Typ, E_Limited_Private_Type, 2344 E_Private_Type, 2345 E_Record_Type_With_Private) 2346 and then Has_Own_Invariants (Typ) 2347 then 2348 Build_Invariant_Procedure_Body 2349 (Typ => Typ, 2350 Partial_Invariant => True); 2351 2352 -- Preanalyze and resolve the invariants of a private type's 2353 -- full view at the end of the private declarations to catch 2354 -- potential errors. 2355 2356 elsif Decls = Private_Declarations (Context) 2357 and then not Is_Private_Type (Typ) 2358 and then Has_Private_Declaration (Typ) 2359 and then Has_Invariants (Typ) 2360 then 2361 Build_Invariant_Procedure_Body (Typ); 2362 end if; 2363 end if; 2364 end Build_Assertion_Bodies_For_Type; 2365 2366 -- Local variables 2367 2368 Decl : Node_Id; 2369 Decl_Id : Entity_Id; 2370 2371 -- Start of processing for Build_Assertion_Bodies 2372 2373 begin 2374 Decl := First (Decls); 2375 while Present (Decl) loop 2376 if Is_Declaration (Decl) then 2377 Decl_Id := Defining_Entity (Decl); 2378 2379 if Is_Type (Decl_Id) then 2380 Build_Assertion_Bodies_For_Type (Decl_Id); 2381 end if; 2382 end if; 2383 2384 Next (Decl); 2385 end loop; 2386 end Build_Assertion_Bodies; 2387 2388 --------------------------- 2389 -- Check_Entry_Contracts -- 2390 --------------------------- 2391 2392 procedure Check_Entry_Contracts is 2393 ASN : Node_Id; 2394 Ent : Entity_Id; 2395 Exp : Node_Id; 2396 2397 begin 2398 Ent := First_Entity (Current_Scope); 2399 while Present (Ent) loop 2400 2401 -- This only concerns entries with pre/postconditions 2402 2403 if Ekind (Ent) = E_Entry 2404 and then Present (Contract (Ent)) 2405 and then Present (Pre_Post_Conditions (Contract (Ent))) 2406 then 2407 ASN := Pre_Post_Conditions (Contract (Ent)); 2408 Push_Scope (Ent); 2409 Install_Formals (Ent); 2410 2411 -- Pre/postconditions are rewritten as Check pragmas. Analysis 2412 -- is performed on a copy of the pragma expression, to prevent 2413 -- modifying the original expression. 2414 2415 while Present (ASN) loop 2416 if Nkind (ASN) = N_Pragma then 2417 Exp := 2418 New_Copy_Tree 2419 (Expression 2420 (First (Pragma_Argument_Associations (ASN)))); 2421 Set_Parent (Exp, ASN); 2422 2423 Preanalyze_Assert_Expression (Exp, Standard_Boolean); 2424 end if; 2425 2426 ASN := Next_Pragma (ASN); 2427 end loop; 2428 2429 End_Scope; 2430 end if; 2431 2432 Next_Entity (Ent); 2433 end loop; 2434 end Check_Entry_Contracts; 2435 2436 ---------------------------------- 2437 -- Contains_Lib_Incomplete_Type -- 2438 ---------------------------------- 2439 2440 function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean is 2441 Curr : Entity_Id; 2442 2443 begin 2444 -- Avoid looking through scopes that do not meet the precondition of 2445 -- Pkg not being within a library unit spec. 2446 2447 if not Is_Compilation_Unit (Pkg) 2448 and then not Is_Generic_Instance (Pkg) 2449 and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg)) 2450 then 2451 -- Loop through all entities in the current scope to identify 2452 -- an entity that depends on a private type. 2453 2454 Curr := First_Entity (Pkg); 2455 loop 2456 if Nkind (Curr) in N_Entity 2457 and then Depends_On_Private (Curr) 2458 then 2459 return True; 2460 end if; 2461 2462 exit when Last_Entity (Current_Scope) = Curr; 2463 Curr := Next_Entity (Curr); 2464 end loop; 2465 end if; 2466 2467 return False; 2468 end Contains_Lib_Incomplete_Type; 2469 2470 -------------------------------------- 2471 -- Handle_Late_Controlled_Primitive -- 2472 -------------------------------------- 2473 2474 procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id) is 2475 Body_Spec : constant Node_Id := Specification (Body_Decl); 2476 Body_Id : constant Entity_Id := Defining_Entity (Body_Spec); 2477 Loc : constant Source_Ptr := Sloc (Body_Id); 2478 Params : constant List_Id := 2479 Parameter_Specifications (Body_Spec); 2480 Spec : Node_Id; 2481 Spec_Id : Entity_Id; 2482 Typ : Node_Id; 2483 2484 begin 2485 -- Consider only procedure bodies whose name matches one of the three 2486 -- controlled primitives. 2487 2488 if Nkind (Body_Spec) /= N_Procedure_Specification 2489 or else not Nam_In (Chars (Body_Id), Name_Adjust, 2490 Name_Finalize, 2491 Name_Initialize) 2492 then 2493 return; 2494 2495 -- A controlled primitive must have exactly one formal which is not 2496 -- an anonymous access type. 2497 2498 elsif List_Length (Params) /= 1 then 2499 return; 2500 end if; 2501 2502 Typ := Parameter_Type (First (Params)); 2503 2504 if Nkind (Typ) = N_Access_Definition then 2505 return; 2506 end if; 2507 2508 Find_Type (Typ); 2509 2510 -- The type of the formal must be derived from [Limited_]Controlled 2511 2512 if not Is_Controlled (Entity (Typ)) then 2513 return; 2514 end if; 2515 2516 -- Check whether a specification exists for this body. We do not 2517 -- analyze the spec of the body in full, because it will be analyzed 2518 -- again when the body is properly analyzed, and we cannot create 2519 -- duplicate entries in the formals chain. We look for an explicit 2520 -- specification because the body may be an overriding operation and 2521 -- an inherited spec may be present. 2522 2523 Spec_Id := Current_Entity (Body_Id); 2524 2525 while Present (Spec_Id) loop 2526 if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) 2527 and then Scope (Spec_Id) = Current_Scope 2528 and then Present (First_Formal (Spec_Id)) 2529 and then No (Next_Formal (First_Formal (Spec_Id))) 2530 and then Etype (First_Formal (Spec_Id)) = Entity (Typ) 2531 and then Comes_From_Source (Spec_Id) 2532 then 2533 return; 2534 end if; 2535 2536 Spec_Id := Homonym (Spec_Id); 2537 end loop; 2538 2539 -- At this point the body is known to be a late controlled primitive. 2540 -- Generate a matching spec and insert it before the body. Note the 2541 -- use of Copy_Separate_Tree - we want an entirely separate semantic 2542 -- tree in this case. 2543 2544 Spec := Copy_Separate_Tree (Body_Spec); 2545 2546 -- Ensure that the subprogram declaration does not inherit the null 2547 -- indicator from the body as we now have a proper spec/body pair. 2548 2549 Set_Null_Present (Spec, False); 2550 2551 -- Ensure that the freeze node is inserted after the declaration of 2552 -- the primitive since its expansion will freeze the primitive. 2553 2554 Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); 2555 2556 Insert_Before_And_Analyze (Body_Decl, Decl); 2557 end Handle_Late_Controlled_Primitive; 2558 2559 ---------------------------------------- 2560 -- Remove_Partial_Visible_Refinements -- 2561 ---------------------------------------- 2562 2563 procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id) is 2564 State_Elmt : Elmt_Id; 2565 begin 2566 if Present (Abstract_States (Spec_Id)) then 2567 State_Elmt := First_Elmt (Abstract_States (Spec_Id)); 2568 while Present (State_Elmt) loop 2569 Set_Has_Partial_Visible_Refinement (Node (State_Elmt), False); 2570 Next_Elmt (State_Elmt); 2571 end loop; 2572 end if; 2573 2574 -- For a child unit, also hide the partial state refinement from 2575 -- ancestor packages. 2576 2577 if Is_Child_Unit (Spec_Id) then 2578 Remove_Partial_Visible_Refinements (Scope (Spec_Id)); 2579 end if; 2580 end Remove_Partial_Visible_Refinements; 2581 2582 -------------------------------- 2583 -- Remove_Visible_Refinements -- 2584 -------------------------------- 2585 2586 procedure Remove_Visible_Refinements (Spec_Id : Entity_Id) is 2587 State_Elmt : Elmt_Id; 2588 begin 2589 if Present (Abstract_States (Spec_Id)) then 2590 State_Elmt := First_Elmt (Abstract_States (Spec_Id)); 2591 while Present (State_Elmt) loop 2592 Set_Has_Visible_Refinement (Node (State_Elmt), False); 2593 Next_Elmt (State_Elmt); 2594 end loop; 2595 end if; 2596 end Remove_Visible_Refinements; 2597 2598 --------------------- 2599 -- Resolve_Aspects -- 2600 --------------------- 2601 2602 procedure Resolve_Aspects is 2603 E : Entity_Id; 2604 2605 begin 2606 E := First_Entity (Current_Scope); 2607 while Present (E) loop 2608 Resolve_Aspect_Expressions (E); 2609 Next_Entity (E); 2610 end loop; 2611 end Resolve_Aspects; 2612 2613 -- Local variables 2614 2615 Context : Node_Id := Empty; 2616 Freeze_From : Entity_Id := Empty; 2617 Next_Decl : Node_Id; 2618 2619 Body_Seen : Boolean := False; 2620 -- Flag set when the first body [stub] is encountered 2621 2622 -- Start of processing for Analyze_Declarations 2623 2624 begin 2625 if Restriction_Check_Required (SPARK_05) then 2626 Check_Later_Vs_Basic_Declarations (L, During_Parsing => False); 2627 end if; 2628 2629 Decl := First (L); 2630 while Present (Decl) loop 2631 2632 -- Package spec cannot contain a package declaration in SPARK 2633 2634 if Nkind (Decl) = N_Package_Declaration 2635 and then Nkind (Parent (L)) = N_Package_Specification 2636 then 2637 Check_SPARK_05_Restriction 2638 ("package specification cannot contain a package declaration", 2639 Decl); 2640 end if; 2641 2642 -- Complete analysis of declaration 2643 2644 Analyze (Decl); 2645 Next_Decl := Next (Decl); 2646 2647 if No (Freeze_From) then 2648 Freeze_From := First_Entity (Current_Scope); 2649 end if; 2650 2651 -- At the end of a declarative part, freeze remaining entities 2652 -- declared in it. The end of the visible declarations of package 2653 -- specification is not the end of a declarative part if private 2654 -- declarations are present. The end of a package declaration is a 2655 -- freezing point only if it a library package. A task definition or 2656 -- protected type definition is not a freeze point either. Finally, 2657 -- we do not freeze entities in generic scopes, because there is no 2658 -- code generated for them and freeze nodes will be generated for 2659 -- the instance. 2660 2661 -- The end of a package instantiation is not a freeze point, but 2662 -- for now we make it one, because the generic body is inserted 2663 -- (currently) immediately after. Generic instantiations will not 2664 -- be a freeze point once delayed freezing of bodies is implemented. 2665 -- (This is needed in any case for early instantiations ???). 2666 2667 if No (Next_Decl) then 2668 if Nkind (Parent (L)) = N_Component_List then 2669 null; 2670 2671 elsif Nkind_In (Parent (L), N_Protected_Definition, 2672 N_Task_Definition) 2673 then 2674 Check_Entry_Contracts; 2675 2676 elsif Nkind (Parent (L)) /= N_Package_Specification then 2677 if Nkind (Parent (L)) = N_Package_Body then 2678 Freeze_From := First_Entity (Current_Scope); 2679 end if; 2680 2681 -- There may have been several freezing points previously, 2682 -- for example object declarations or subprogram bodies, but 2683 -- at the end of a declarative part we check freezing from 2684 -- the beginning, even though entities may already be frozen, 2685 -- in order to perform visibility checks on delayed aspects. 2686 2687 Adjust_Decl; 2688 2689 -- If the current scope is a generic subprogram body. Skip the 2690 -- generic formal parameters that are not frozen here. 2691 2692 if Is_Subprogram (Current_Scope) 2693 and then Nkind (Unit_Declaration_Node (Current_Scope)) = 2694 N_Generic_Subprogram_Declaration 2695 and then Present (First_Entity (Current_Scope)) 2696 then 2697 while Is_Generic_Formal (Freeze_From) loop 2698 Freeze_From := Next_Entity (Freeze_From); 2699 end loop; 2700 2701 Freeze_All (Freeze_From, Decl); 2702 Freeze_From := Last_Entity (Current_Scope); 2703 2704 else 2705 -- For declarations in a subprogram body there is no issue 2706 -- with name resolution in aspect specifications, but in 2707 -- ASIS mode we need to preanalyze aspect specifications 2708 -- that may otherwise only be analyzed during expansion 2709 -- (e.g. during generation of a related subprogram). 2710 2711 if ASIS_Mode then 2712 Resolve_Aspects; 2713 end if; 2714 2715 Freeze_All (First_Entity (Current_Scope), Decl); 2716 Freeze_From := Last_Entity (Current_Scope); 2717 end if; 2718 2719 -- Current scope is a package specification 2720 2721 elsif Scope (Current_Scope) /= Standard_Standard 2722 and then not Is_Child_Unit (Current_Scope) 2723 and then No (Generic_Parent (Parent (L))) 2724 then 2725 -- ARM rule 13.1.1(11/3): usage names in aspect definitions are 2726 -- resolved at the end of the immediately enclosing declaration 2727 -- list (AI05-0183-1). 2728 2729 Resolve_Aspects; 2730 2731 elsif L /= Visible_Declarations (Parent (L)) 2732 or else No (Private_Declarations (Parent (L))) 2733 or else Is_Empty_List (Private_Declarations (Parent (L))) 2734 then 2735 Adjust_Decl; 2736 2737 -- End of a package declaration 2738 2739 -- In compilation mode the expansion of freeze node takes care 2740 -- of resolving expressions of all aspects in the list. In ASIS 2741 -- mode this must be done explicitly. 2742 2743 if ASIS_Mode 2744 and then Scope (Current_Scope) = Standard_Standard 2745 then 2746 Resolve_Aspects; 2747 end if; 2748 2749 -- This is a freeze point because it is the end of a 2750 -- compilation unit. 2751 2752 Freeze_All (First_Entity (Current_Scope), Decl); 2753 Freeze_From := Last_Entity (Current_Scope); 2754 2755 -- At the end of the visible declarations the expressions in 2756 -- aspects of all entities declared so far must be resolved. 2757 -- The entities themselves might be frozen later, and the 2758 -- generated pragmas and attribute definition clauses analyzed 2759 -- in full at that point, but name resolution must take place 2760 -- now. 2761 -- In addition to being the proper semantics, this is mandatory 2762 -- within generic units, because global name capture requires 2763 -- those expressions to be analyzed, given that the generated 2764 -- pragmas do not appear in the original generic tree. 2765 2766 elsif Serious_Errors_Detected = 0 then 2767 Resolve_Aspects; 2768 end if; 2769 2770 -- If next node is a body then freeze all types before the body. 2771 -- An exception occurs for some expander-generated bodies. If these 2772 -- are generated at places where in general language rules would not 2773 -- allow a freeze point, then we assume that the expander has 2774 -- explicitly checked that all required types are properly frozen, 2775 -- and we do not cause general freezing here. This special circuit 2776 -- is used when the encountered body is marked as having already 2777 -- been analyzed. 2778 2779 -- In all other cases (bodies that come from source, and expander 2780 -- generated bodies that have not been analyzed yet), freeze all 2781 -- types now. Note that in the latter case, the expander must take 2782 -- care to attach the bodies at a proper place in the tree so as to 2783 -- not cause unwanted freezing at that point. 2784 2785 -- It is also necessary to check for a case where both an expression 2786 -- function is used and the current scope depends on an incomplete 2787 -- private type from a library unit, otherwise premature freezing of 2788 -- the private type will occur. 2789 2790 elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) 2791 and then ((Nkind (Next_Decl) /= N_Subprogram_Body 2792 or else not Was_Expression_Function (Next_Decl)) 2793 or else (not Is_Ignored_Ghost_Entity (Current_Scope) 2794 and then not Contains_Lib_Incomplete_Type 2795 (Current_Scope))) 2796 then 2797 -- When a controlled type is frozen, the expander generates stream 2798 -- and controlled-type support routines. If the freeze is caused 2799 -- by the stand-alone body of Initialize, Adjust, or Finalize, the 2800 -- expander will end up using the wrong version of these routines, 2801 -- as the body has not been processed yet. To remedy this, detect 2802 -- a late controlled primitive and create a proper spec for it. 2803 -- This ensures that the primitive will override its inherited 2804 -- counterpart before the freeze takes place. 2805 2806 -- If the declaration we just processed is a body, do not attempt 2807 -- to examine Next_Decl as the late primitive idiom can only apply 2808 -- to the first encountered body. 2809 2810 -- The spec of the late primitive is not generated in ASIS mode to 2811 -- ensure a consistent list of primitives that indicates the true 2812 -- semantic structure of the program (which is not relevant when 2813 -- generating executable code). 2814 2815 -- ??? A cleaner approach may be possible and/or this solution 2816 -- could be extended to general-purpose late primitives, TBD. 2817 2818 if not ASIS_Mode 2819 and then not Body_Seen 2820 and then not Is_Body (Decl) 2821 then 2822 Body_Seen := True; 2823 2824 if Nkind (Next_Decl) = N_Subprogram_Body then 2825 Handle_Late_Controlled_Primitive (Next_Decl); 2826 end if; 2827 2828 else 2829 -- In ASIS mode, if the next declaration is a body, complete 2830 -- the analysis of declarations so far. 2831 2832 Resolve_Aspects; 2833 end if; 2834 2835 Adjust_Decl; 2836 2837 -- The generated body of an expression function does not freeze, 2838 -- unless it is a completion, in which case only the expression 2839 -- itself freezes. This is handled when the body itself is 2840 -- analyzed (see Freeze_Expr_Types, sem_ch6.adb). 2841 2842 Freeze_All (Freeze_From, Decl); 2843 Freeze_From := Last_Entity (Current_Scope); 2844 end if; 2845 2846 Decl := Next_Decl; 2847 end loop; 2848 2849 -- Post-freezing actions 2850 2851 if Present (L) then 2852 Context := Parent (L); 2853 2854 -- Certain contract annocations have forward visibility semantics and 2855 -- must be analyzed after all declarative items have been processed. 2856 -- This timing ensures that entities referenced by such contracts are 2857 -- visible. 2858 2859 -- Analyze the contract of an immediately enclosing package spec or 2860 -- body first because other contracts may depend on its information. 2861 2862 if Nkind (Context) = N_Package_Body then 2863 Analyze_Package_Body_Contract (Defining_Entity (Context)); 2864 2865 elsif Nkind (Context) = N_Package_Specification then 2866 Analyze_Package_Contract (Defining_Entity (Context)); 2867 end if; 2868 2869 -- Analyze the contracts of various constructs in the declarative 2870 -- list. 2871 2872 Analyze_Contracts (L); 2873 2874 if Nkind (Context) = N_Package_Body then 2875 2876 -- Ensure that all abstract states and objects declared in the 2877 -- state space of a package body are utilized as constituents. 2878 2879 Check_Unused_Body_States (Defining_Entity (Context)); 2880 2881 -- State refinements are visible up to the end of the package body 2882 -- declarations. Hide the state refinements from visibility to 2883 -- restore the original state conditions. 2884 2885 Remove_Visible_Refinements (Corresponding_Spec (Context)); 2886 Remove_Partial_Visible_Refinements (Corresponding_Spec (Context)); 2887 2888 elsif Nkind (Context) = N_Package_Specification then 2889 2890 -- Partial state refinements are visible up to the end of the 2891 -- package spec declarations. Hide the partial state refinements 2892 -- from visibility to restore the original state conditions. 2893 2894 Remove_Partial_Visible_Refinements (Defining_Entity (Context)); 2895 end if; 2896 2897 -- Verify that all abstract states found in any package declared in 2898 -- the input declarative list have proper refinements. The check is 2899 -- performed only when the context denotes a block, entry, package, 2900 -- protected, subprogram, or task body (SPARK RM 7.2.2(3)). 2901 2902 Check_State_Refinements (Context); 2903 2904 -- Create the subprogram bodies which verify the run-time semantics 2905 -- of pragmas Default_Initial_Condition and [Type_]Invariant for all 2906 -- types within the current declarative list. This ensures that all 2907 -- assertion expressions are preanalyzed and resolved at the end of 2908 -- the declarative part. Note that the resolution happens even when 2909 -- freezing does not take place. 2910 2911 Build_Assertion_Bodies (L, Context); 2912 end if; 2913 end Analyze_Declarations; 2914 2915 ----------------------------------- 2916 -- Analyze_Full_Type_Declaration -- 2917 ----------------------------------- 2918 2919 procedure Analyze_Full_Type_Declaration (N : Node_Id) is 2920 Def : constant Node_Id := Type_Definition (N); 2921 Def_Id : constant Entity_Id := Defining_Identifier (N); 2922 T : Entity_Id; 2923 Prev : Entity_Id; 2924 2925 Is_Remote : constant Boolean := 2926 (Is_Remote_Types (Current_Scope) 2927 or else Is_Remote_Call_Interface (Current_Scope)) 2928 and then not (In_Private_Part (Current_Scope) 2929 or else In_Package_Body (Current_Scope)); 2930 2931 procedure Check_Nonoverridable_Aspects; 2932 -- Apply the rule in RM 13.1.1(18.4/4) on iterator aspects that cannot 2933 -- be overridden, and can only be confirmed on derivation. 2934 2935 procedure Check_Ops_From_Incomplete_Type; 2936 -- If there is a tagged incomplete partial view of the type, traverse 2937 -- the primitives of the incomplete view and change the type of any 2938 -- controlling formals and result to indicate the full view. The 2939 -- primitives will be added to the full type's primitive operations 2940 -- list later in Sem_Disp.Check_Operation_From_Incomplete_Type (which 2941 -- is called from Process_Incomplete_Dependents). 2942 2943 ---------------------------------- 2944 -- Check_Nonoverridable_Aspects -- 2945 ---------------------------------- 2946 2947 procedure Check_Nonoverridable_Aspects is 2948 function Get_Aspect_Spec 2949 (Specs : List_Id; 2950 Aspect_Name : Name_Id) return Node_Id; 2951 -- Check whether a list of aspect specifications includes an entry 2952 -- for a specific aspect. The list is either that of a partial or 2953 -- a full view. 2954 2955 --------------------- 2956 -- Get_Aspect_Spec -- 2957 --------------------- 2958 2959 function Get_Aspect_Spec 2960 (Specs : List_Id; 2961 Aspect_Name : Name_Id) return Node_Id 2962 is 2963 Spec : Node_Id; 2964 2965 begin 2966 Spec := First (Specs); 2967 while Present (Spec) loop 2968 if Chars (Identifier (Spec)) = Aspect_Name then 2969 return Spec; 2970 end if; 2971 Next (Spec); 2972 end loop; 2973 2974 return Empty; 2975 end Get_Aspect_Spec; 2976 2977 -- Local variables 2978 2979 Prev_Aspects : constant List_Id := 2980 Aspect_Specifications (Parent (Def_Id)); 2981 Par_Type : Entity_Id; 2982 Prev_Aspect : Node_Id; 2983 2984 -- Start of processing for Check_Nonoverridable_Aspects 2985 2986 begin 2987 -- Get parent type of derived type. Note that Prev is the entity in 2988 -- the partial declaration, but its contents are now those of full 2989 -- view, while Def_Id reflects the partial view. 2990 2991 if Is_Private_Type (Def_Id) then 2992 Par_Type := Etype (Full_View (Def_Id)); 2993 else 2994 Par_Type := Etype (Def_Id); 2995 end if; 2996 2997 -- If there is an inherited Implicit_Dereference, verify that it is 2998 -- made explicit in the partial view. 2999 3000 if Has_Discriminants (Base_Type (Par_Type)) 3001 and then Nkind (Parent (Prev)) = N_Full_Type_Declaration 3002 and then Present (Discriminant_Specifications (Parent (Prev))) 3003 and then Present (Get_Reference_Discriminant (Par_Type)) 3004 then 3005 Prev_Aspect := 3006 Get_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference); 3007 3008 if No (Prev_Aspect) 3009 and then Present 3010 (Discriminant_Specifications 3011 (Original_Node (Parent (Prev)))) 3012 then 3013 Error_Msg_N 3014 ("type does not inherit implicit dereference", Prev); 3015 3016 else 3017 -- If one of the views has the aspect specified, verify that it 3018 -- is consistent with that of the parent. 3019 3020 declare 3021 Cur_Discr : constant Entity_Id := 3022 Get_Reference_Discriminant (Prev); 3023 Par_Discr : constant Entity_Id := 3024 Get_Reference_Discriminant (Par_Type); 3025 3026 begin 3027 if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then 3028 Error_Msg_N 3029 ("aspect inconsistent with that of parent", N); 3030 end if; 3031 3032 -- Check that specification in partial view matches the 3033 -- inherited aspect. Compare names directly because aspect 3034 -- expression may not be analyzed. 3035 3036 if Present (Prev_Aspect) 3037 and then Nkind (Expression (Prev_Aspect)) = N_Identifier 3038 and then Chars (Expression (Prev_Aspect)) /= 3039 Chars (Cur_Discr) 3040 then 3041 Error_Msg_N 3042 ("aspect inconsistent with that of parent", N); 3043 end if; 3044 end; 3045 end if; 3046 end if; 3047 3048 -- TBD : other nonoverridable aspects. 3049 end Check_Nonoverridable_Aspects; 3050 3051 ------------------------------------ 3052 -- Check_Ops_From_Incomplete_Type -- 3053 ------------------------------------ 3054 3055 procedure Check_Ops_From_Incomplete_Type is 3056 Elmt : Elmt_Id; 3057 Formal : Entity_Id; 3058 Op : Entity_Id; 3059 3060 begin 3061 if Prev /= T 3062 and then Ekind (Prev) = E_Incomplete_Type 3063 and then Is_Tagged_Type (Prev) 3064 and then Is_Tagged_Type (T) 3065 then 3066 Elmt := First_Elmt (Primitive_Operations (Prev)); 3067 while Present (Elmt) loop 3068 Op := Node (Elmt); 3069 3070 Formal := First_Formal (Op); 3071 while Present (Formal) loop 3072 if Etype (Formal) = Prev then 3073 Set_Etype (Formal, T); 3074 end if; 3075 3076 Next_Formal (Formal); 3077 end loop; 3078 3079 if Etype (Op) = Prev then 3080 Set_Etype (Op, T); 3081 end if; 3082 3083 Next_Elmt (Elmt); 3084 end loop; 3085 end if; 3086 end Check_Ops_From_Incomplete_Type; 3087 3088 -- Start of processing for Analyze_Full_Type_Declaration 3089 3090 begin 3091 Prev := Find_Type_Name (N); 3092 3093 -- The full view, if present, now points to the current type. If there 3094 -- is an incomplete partial view, set a link to it, to simplify the 3095 -- retrieval of primitive operations of the type. 3096 3097 -- Ada 2005 (AI-50217): If the type was previously decorated when 3098 -- imported through a LIMITED WITH clause, it appears as incomplete 3099 -- but has no full view. 3100 3101 if Ekind (Prev) = E_Incomplete_Type 3102 and then Present (Full_View (Prev)) 3103 then 3104 T := Full_View (Prev); 3105 Set_Incomplete_View (N, Parent (Prev)); 3106 else 3107 T := Prev; 3108 end if; 3109 3110 Set_Is_Pure (T, Is_Pure (Current_Scope)); 3111 3112 -- We set the flag Is_First_Subtype here. It is needed to set the 3113 -- corresponding flag for the Implicit class-wide-type created 3114 -- during tagged types processing. 3115 3116 Set_Is_First_Subtype (T, True); 3117 3118 -- Only composite types other than array types are allowed to have 3119 -- discriminants. 3120 3121 case Nkind (Def) is 3122 3123 -- For derived types, the rule will be checked once we've figured 3124 -- out the parent type. 3125 3126 when N_Derived_Type_Definition => 3127 null; 3128 3129 -- For record types, discriminants are allowed, unless we are in 3130 -- SPARK. 3131 3132 when N_Record_Definition => 3133 if Present (Discriminant_Specifications (N)) then 3134 Check_SPARK_05_Restriction 3135 ("discriminant type is not allowed", 3136 Defining_Identifier 3137 (First (Discriminant_Specifications (N)))); 3138 end if; 3139 3140 when others => 3141 if Present (Discriminant_Specifications (N)) then 3142 Error_Msg_N 3143 ("elementary or array type cannot have discriminants", 3144 Defining_Identifier 3145 (First (Discriminant_Specifications (N)))); 3146 end if; 3147 end case; 3148 3149 -- Elaborate the type definition according to kind, and generate 3150 -- subsidiary (implicit) subtypes where needed. We skip this if it was 3151 -- already done (this happens during the reanalysis that follows a call 3152 -- to the high level optimizer). 3153 3154 if not Analyzed (T) then 3155 Set_Analyzed (T); 3156 3157 -- Set the SPARK mode from the current context 3158 3159 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 3160 Set_SPARK_Pragma_Inherited (T); 3161 3162 case Nkind (Def) is 3163 when N_Access_To_Subprogram_Definition => 3164 Access_Subprogram_Declaration (T, Def); 3165 3166 -- If this is a remote access to subprogram, we must create the 3167 -- equivalent fat pointer type, and related subprograms. 3168 3169 if Is_Remote then 3170 Process_Remote_AST_Declaration (N); 3171 end if; 3172 3173 -- Validate categorization rule against access type declaration 3174 -- usually a violation in Pure unit, Shared_Passive unit. 3175 3176 Validate_Access_Type_Declaration (T, N); 3177 3178 when N_Access_To_Object_Definition => 3179 Access_Type_Declaration (T, Def); 3180 3181 -- Validate categorization rule against access type declaration 3182 -- usually a violation in Pure unit, Shared_Passive unit. 3183 3184 Validate_Access_Type_Declaration (T, N); 3185 3186 -- If we are in a Remote_Call_Interface package and define a 3187 -- RACW, then calling stubs and specific stream attributes 3188 -- must be added. 3189 3190 if Is_Remote 3191 and then Is_Remote_Access_To_Class_Wide_Type (Def_Id) 3192 then 3193 Add_RACW_Features (Def_Id); 3194 end if; 3195 3196 when N_Array_Type_Definition => 3197 Array_Type_Declaration (T, Def); 3198 3199 when N_Derived_Type_Definition => 3200 Derived_Type_Declaration (T, N, T /= Def_Id); 3201 3202 -- Inherit predicates from parent, and protect against illegal 3203 -- derivations. 3204 3205 if Is_Type (T) and then Has_Predicates (T) then 3206 Set_Has_Predicates (Def_Id); 3207 end if; 3208 3209 -- Save the scenario for examination by the ABE Processing 3210 -- phase. 3211 3212 Record_Elaboration_Scenario (N); 3213 3214 when N_Enumeration_Type_Definition => 3215 Enumeration_Type_Declaration (T, Def); 3216 3217 when N_Floating_Point_Definition => 3218 Floating_Point_Type_Declaration (T, Def); 3219 3220 when N_Decimal_Fixed_Point_Definition => 3221 Decimal_Fixed_Point_Type_Declaration (T, Def); 3222 3223 when N_Ordinary_Fixed_Point_Definition => 3224 Ordinary_Fixed_Point_Type_Declaration (T, Def); 3225 3226 when N_Signed_Integer_Type_Definition => 3227 Signed_Integer_Type_Declaration (T, Def); 3228 3229 when N_Modular_Type_Definition => 3230 Modular_Type_Declaration (T, Def); 3231 3232 when N_Record_Definition => 3233 Record_Type_Declaration (T, N, Prev); 3234 3235 -- If declaration has a parse error, nothing to elaborate. 3236 3237 when N_Error => 3238 null; 3239 3240 when others => 3241 raise Program_Error; 3242 end case; 3243 end if; 3244 3245 if Etype (T) = Any_Type then 3246 return; 3247 end if; 3248 3249 -- Controlled type is not allowed in SPARK 3250 3251 if Is_Visibly_Controlled (T) then 3252 Check_SPARK_05_Restriction ("controlled type is not allowed", N); 3253 end if; 3254 3255 -- Some common processing for all types 3256 3257 Set_Depends_On_Private (T, Has_Private_Component (T)); 3258 Check_Ops_From_Incomplete_Type; 3259 3260 -- Both the declared entity, and its anonymous base type if one was 3261 -- created, need freeze nodes allocated. 3262 3263 declare 3264 B : constant Entity_Id := Base_Type (T); 3265 3266 begin 3267 -- In the case where the base type differs from the first subtype, we 3268 -- pre-allocate a freeze node, and set the proper link to the first 3269 -- subtype. Freeze_Entity will use this preallocated freeze node when 3270 -- it freezes the entity. 3271 3272 -- This does not apply if the base type is a generic type, whose 3273 -- declaration is independent of the current derived definition. 3274 3275 if B /= T and then not Is_Generic_Type (B) then 3276 Ensure_Freeze_Node (B); 3277 Set_First_Subtype_Link (Freeze_Node (B), T); 3278 end if; 3279 3280 -- A type that is imported through a limited_with clause cannot 3281 -- generate any code, and thus need not be frozen. However, an access 3282 -- type with an imported designated type needs a finalization list, 3283 -- which may be referenced in some other package that has non-limited 3284 -- visibility on the designated type. Thus we must create the 3285 -- finalization list at the point the access type is frozen, to 3286 -- prevent unsatisfied references at link time. 3287 3288 if not From_Limited_With (T) or else Is_Access_Type (T) then 3289 Set_Has_Delayed_Freeze (T); 3290 end if; 3291 end; 3292 3293 -- Case where T is the full declaration of some private type which has 3294 -- been swapped in Defining_Identifier (N). 3295 3296 if T /= Def_Id and then Is_Private_Type (Def_Id) then 3297 Process_Full_View (N, T, Def_Id); 3298 3299 -- Record the reference. The form of this is a little strange, since 3300 -- the full declaration has been swapped in. So the first parameter 3301 -- here represents the entity to which a reference is made which is 3302 -- the "real" entity, i.e. the one swapped in, and the second 3303 -- parameter provides the reference location. 3304 3305 -- Also, we want to kill Has_Pragma_Unreferenced temporarily here 3306 -- since we don't want a complaint about the full type being an 3307 -- unwanted reference to the private type 3308 3309 declare 3310 B : constant Boolean := Has_Pragma_Unreferenced (T); 3311 begin 3312 Set_Has_Pragma_Unreferenced (T, False); 3313 Generate_Reference (T, T, 'c'); 3314 Set_Has_Pragma_Unreferenced (T, B); 3315 end; 3316 3317 Set_Completion_Referenced (Def_Id); 3318 3319 -- For completion of incomplete type, process incomplete dependents 3320 -- and always mark the full type as referenced (it is the incomplete 3321 -- type that we get for any real reference). 3322 3323 elsif Ekind (Prev) = E_Incomplete_Type then 3324 Process_Incomplete_Dependents (N, T, Prev); 3325 Generate_Reference (Prev, Def_Id, 'c'); 3326 Set_Completion_Referenced (Def_Id); 3327 3328 -- If not private type or incomplete type completion, this is a real 3329 -- definition of a new entity, so record it. 3330 3331 else 3332 Generate_Definition (Def_Id); 3333 end if; 3334 3335 -- Propagate any pending access types whose finalization masters need to 3336 -- be fully initialized from the partial to the full view. Guard against 3337 -- an illegal full view that remains unanalyzed. 3338 3339 if Is_Type (Def_Id) and then Is_Incomplete_Or_Private_Type (Prev) then 3340 Set_Pending_Access_Types (Def_Id, Pending_Access_Types (Prev)); 3341 end if; 3342 3343 if Chars (Scope (Def_Id)) = Name_System 3344 and then Chars (Def_Id) = Name_Address 3345 and then In_Predefined_Unit (N) 3346 then 3347 Set_Is_Descendant_Of_Address (Def_Id); 3348 Set_Is_Descendant_Of_Address (Base_Type (Def_Id)); 3349 Set_Is_Descendant_Of_Address (Prev); 3350 end if; 3351 3352 Set_Optimize_Alignment_Flags (Def_Id); 3353 Check_Eliminated (Def_Id); 3354 3355 -- If the declaration is a completion and aspects are present, apply 3356 -- them to the entity for the type which is currently the partial 3357 -- view, but which is the one that will be frozen. 3358 3359 if Has_Aspects (N) then 3360 3361 -- In most cases the partial view is a private type, and both views 3362 -- appear in different declarative parts. In the unusual case where 3363 -- the partial view is incomplete, perform the analysis on the 3364 -- full view, to prevent freezing anomalies with the corresponding 3365 -- class-wide type, which otherwise might be frozen before the 3366 -- dispatch table is built. 3367 3368 if Prev /= Def_Id 3369 and then Ekind (Prev) /= E_Incomplete_Type 3370 then 3371 Analyze_Aspect_Specifications (N, Prev); 3372 3373 -- Normal case 3374 3375 else 3376 Analyze_Aspect_Specifications (N, Def_Id); 3377 end if; 3378 end if; 3379 3380 if Is_Derived_Type (Prev) 3381 and then Def_Id /= Prev 3382 then 3383 Check_Nonoverridable_Aspects; 3384 end if; 3385 end Analyze_Full_Type_Declaration; 3386 3387 ---------------------------------- 3388 -- Analyze_Incomplete_Type_Decl -- 3389 ---------------------------------- 3390 3391 procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is 3392 F : constant Boolean := Is_Pure (Current_Scope); 3393 T : Entity_Id; 3394 3395 begin 3396 Check_SPARK_05_Restriction ("incomplete type is not allowed", N); 3397 3398 Generate_Definition (Defining_Identifier (N)); 3399 3400 -- Process an incomplete declaration. The identifier must not have been 3401 -- declared already in the scope. However, an incomplete declaration may 3402 -- appear in the private part of a package, for a private type that has 3403 -- already been declared. 3404 3405 -- In this case, the discriminants (if any) must match 3406 3407 T := Find_Type_Name (N); 3408 3409 Set_Ekind (T, E_Incomplete_Type); 3410 Set_Etype (T, T); 3411 Set_Is_First_Subtype (T); 3412 Init_Size_Align (T); 3413 3414 -- Set the SPARK mode from the current context 3415 3416 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 3417 Set_SPARK_Pragma_Inherited (T); 3418 3419 -- Ada 2005 (AI-326): Minimum decoration to give support to tagged 3420 -- incomplete types. 3421 3422 if Tagged_Present (N) then 3423 Set_Is_Tagged_Type (T, True); 3424 Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); 3425 Make_Class_Wide_Type (T); 3426 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3427 end if; 3428 3429 Set_Stored_Constraint (T, No_Elist); 3430 3431 if Present (Discriminant_Specifications (N)) then 3432 Push_Scope (T); 3433 Process_Discriminants (N); 3434 End_Scope; 3435 end if; 3436 3437 -- If the type has discriminants, nontrivial subtypes may be declared 3438 -- before the full view of the type. The full views of those subtypes 3439 -- will be built after the full view of the type. 3440 3441 Set_Private_Dependents (T, New_Elmt_List); 3442 Set_Is_Pure (T, F); 3443 end Analyze_Incomplete_Type_Decl; 3444 3445 ----------------------------------- 3446 -- Analyze_Interface_Declaration -- 3447 ----------------------------------- 3448 3449 procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is 3450 CW : constant Entity_Id := Class_Wide_Type (T); 3451 3452 begin 3453 Set_Is_Tagged_Type (T); 3454 Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); 3455 3456 Set_Is_Limited_Record (T, Limited_Present (Def) 3457 or else Task_Present (Def) 3458 or else Protected_Present (Def) 3459 or else Synchronized_Present (Def)); 3460 3461 -- Type is abstract if full declaration carries keyword, or if previous 3462 -- partial view did. 3463 3464 Set_Is_Abstract_Type (T); 3465 Set_Is_Interface (T); 3466 3467 -- Type is a limited interface if it includes the keyword limited, task, 3468 -- protected, or synchronized. 3469 3470 Set_Is_Limited_Interface 3471 (T, Limited_Present (Def) 3472 or else Protected_Present (Def) 3473 or else Synchronized_Present (Def) 3474 or else Task_Present (Def)); 3475 3476 Set_Interfaces (T, New_Elmt_List); 3477 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3478 3479 -- Complete the decoration of the class-wide entity if it was already 3480 -- built (i.e. during the creation of the limited view) 3481 3482 if Present (CW) then 3483 Set_Is_Interface (CW); 3484 Set_Is_Limited_Interface (CW, Is_Limited_Interface (T)); 3485 end if; 3486 3487 -- Check runtime support for synchronized interfaces 3488 3489 if (Is_Task_Interface (T) 3490 or else Is_Protected_Interface (T) 3491 or else Is_Synchronized_Interface (T)) 3492 and then not RTE_Available (RE_Select_Specific_Data) 3493 then 3494 Error_Msg_CRT ("synchronized interfaces", T); 3495 end if; 3496 end Analyze_Interface_Declaration; 3497 3498 ----------------------------- 3499 -- Analyze_Itype_Reference -- 3500 ----------------------------- 3501 3502 -- Nothing to do. This node is placed in the tree only for the benefit of 3503 -- back end processing, and has no effect on the semantic processing. 3504 3505 procedure Analyze_Itype_Reference (N : Node_Id) is 3506 begin 3507 pragma Assert (Is_Itype (Itype (N))); 3508 null; 3509 end Analyze_Itype_Reference; 3510 3511 -------------------------------- 3512 -- Analyze_Number_Declaration -- 3513 -------------------------------- 3514 3515 procedure Analyze_Number_Declaration (N : Node_Id) is 3516 E : constant Node_Id := Expression (N); 3517 Id : constant Entity_Id := Defining_Identifier (N); 3518 Index : Interp_Index; 3519 It : Interp; 3520 T : Entity_Id; 3521 3522 begin 3523 Generate_Definition (Id); 3524 Enter_Name (Id); 3525 3526 -- This is an optimization of a common case of an integer literal 3527 3528 if Nkind (E) = N_Integer_Literal then 3529 Set_Is_Static_Expression (E, True); 3530 Set_Etype (E, Universal_Integer); 3531 3532 Set_Etype (Id, Universal_Integer); 3533 Set_Ekind (Id, E_Named_Integer); 3534 Set_Is_Frozen (Id, True); 3535 3536 Set_Debug_Info_Needed (Id); 3537 return; 3538 end if; 3539 3540 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3541 3542 -- Process expression, replacing error by integer zero, to avoid 3543 -- cascaded errors or aborts further along in the processing 3544 3545 -- Replace Error by integer zero, which seems least likely to cause 3546 -- cascaded errors. 3547 3548 if E = Error then 3549 Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0)); 3550 Set_Error_Posted (E); 3551 end if; 3552 3553 Analyze (E); 3554 3555 -- Verify that the expression is static and numeric. If 3556 -- the expression is overloaded, we apply the preference 3557 -- rule that favors root numeric types. 3558 3559 if not Is_Overloaded (E) then 3560 T := Etype (E); 3561 if Has_Dynamic_Predicate_Aspect (T) then 3562 Error_Msg_N 3563 ("subtype has dynamic predicate, " 3564 & "not allowed in number declaration", N); 3565 end if; 3566 3567 else 3568 T := Any_Type; 3569 3570 Get_First_Interp (E, Index, It); 3571 while Present (It.Typ) loop 3572 if (Is_Integer_Type (It.Typ) or else Is_Real_Type (It.Typ)) 3573 and then (Scope (Base_Type (It.Typ))) = Standard_Standard 3574 then 3575 if T = Any_Type then 3576 T := It.Typ; 3577 3578 elsif It.Typ = Universal_Real 3579 or else 3580 It.Typ = Universal_Integer 3581 then 3582 -- Choose universal interpretation over any other 3583 3584 T := It.Typ; 3585 exit; 3586 end if; 3587 end if; 3588 3589 Get_Next_Interp (Index, It); 3590 end loop; 3591 end if; 3592 3593 if Is_Integer_Type (T) then 3594 Resolve (E, T); 3595 Set_Etype (Id, Universal_Integer); 3596 Set_Ekind (Id, E_Named_Integer); 3597 3598 elsif Is_Real_Type (T) then 3599 3600 -- Because the real value is converted to universal_real, this is a 3601 -- legal context for a universal fixed expression. 3602 3603 if T = Universal_Fixed then 3604 declare 3605 Loc : constant Source_Ptr := Sloc (N); 3606 Conv : constant Node_Id := Make_Type_Conversion (Loc, 3607 Subtype_Mark => 3608 New_Occurrence_Of (Universal_Real, Loc), 3609 Expression => Relocate_Node (E)); 3610 3611 begin 3612 Rewrite (E, Conv); 3613 Analyze (E); 3614 end; 3615 3616 elsif T = Any_Fixed then 3617 Error_Msg_N ("illegal context for mixed mode operation", E); 3618 3619 -- Expression is of the form : universal_fixed * integer. Try to 3620 -- resolve as universal_real. 3621 3622 T := Universal_Real; 3623 Set_Etype (E, T); 3624 end if; 3625 3626 Resolve (E, T); 3627 Set_Etype (Id, Universal_Real); 3628 Set_Ekind (Id, E_Named_Real); 3629 3630 else 3631 Wrong_Type (E, Any_Numeric); 3632 Resolve (E, T); 3633 3634 Set_Etype (Id, T); 3635 Set_Ekind (Id, E_Constant); 3636 Set_Never_Set_In_Source (Id, True); 3637 Set_Is_True_Constant (Id, True); 3638 return; 3639 end if; 3640 3641 if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then 3642 Set_Etype (E, Etype (Id)); 3643 end if; 3644 3645 if not Is_OK_Static_Expression (E) then 3646 Flag_Non_Static_Expr 3647 ("non-static expression used in number declaration!", E); 3648 Rewrite (E, Make_Integer_Literal (Sloc (N), 1)); 3649 Set_Etype (E, Any_Type); 3650 end if; 3651 3652 Analyze_Dimension (N); 3653 end Analyze_Number_Declaration; 3654 3655 -------------------------------- 3656 -- Analyze_Object_Declaration -- 3657 -------------------------------- 3658 3659 -- WARNING: This routine manages Ghost regions. Return statements must be 3660 -- replaced by gotos which jump to the end of the routine and restore the 3661 -- Ghost mode. 3662 3663 procedure Analyze_Object_Declaration (N : Node_Id) is 3664 Loc : constant Source_Ptr := Sloc (N); 3665 Id : constant Entity_Id := Defining_Identifier (N); 3666 Next_Decl : constant Node_Id := Next (N); 3667 3668 Act_T : Entity_Id; 3669 T : Entity_Id; 3670 3671 E : Node_Id := Expression (N); 3672 -- E is set to Expression (N) throughout this routine. When Expression 3673 -- (N) is modified, E is changed accordingly. 3674 3675 Prev_Entity : Entity_Id := Empty; 3676 3677 procedure Check_Dynamic_Object (Typ : Entity_Id); 3678 -- A library-level object with nonstatic discriminant constraints may 3679 -- require dynamic allocation. The declaration is illegal if the 3680 -- profile includes the restriction No_Implicit_Heap_Allocations. 3681 3682 procedure Check_For_Null_Excluding_Components 3683 (Obj_Typ : Entity_Id; 3684 Obj_Decl : Node_Id); 3685 -- Verify that each null-excluding component of object declaration 3686 -- Obj_Decl carrying type Obj_Typ has explicit initialization. Emit 3687 -- a compile-time warning if this is not the case. 3688 3689 function Count_Tasks (T : Entity_Id) return Uint; 3690 -- This function is called when a non-generic library level object of a 3691 -- task type is declared. Its function is to count the static number of 3692 -- tasks declared within the type (it is only called if Has_Task is set 3693 -- for T). As a side effect, if an array of tasks with nonstatic bounds 3694 -- or a variant record type is encountered, Check_Restriction is called 3695 -- indicating the count is unknown. 3696 3697 function Delayed_Aspect_Present return Boolean; 3698 -- If the declaration has an expression that is an aggregate, and it 3699 -- has aspects that require delayed analysis, the resolution of the 3700 -- aggregate must be deferred to the freeze point of the object. This 3701 -- special processing was created for address clauses, but it must 3702 -- also apply to Alignment. This must be done before the aspect 3703 -- specifications are analyzed because we must handle the aggregate 3704 -- before the analysis of the object declaration is complete. 3705 3706 -- Any other relevant delayed aspects on object declarations ??? 3707 3708 -------------------------- 3709 -- Check_Dynamic_Object -- 3710 -------------------------- 3711 3712 procedure Check_Dynamic_Object (Typ : Entity_Id) is 3713 Comp : Entity_Id; 3714 Obj_Type : Entity_Id; 3715 3716 begin 3717 Obj_Type := Typ; 3718 3719 if Is_Private_Type (Obj_Type) 3720 and then Present (Full_View (Obj_Type)) 3721 then 3722 Obj_Type := Full_View (Obj_Type); 3723 end if; 3724 3725 if Known_Static_Esize (Obj_Type) then 3726 return; 3727 end if; 3728 3729 if Restriction_Active (No_Implicit_Heap_Allocations) 3730 and then Expander_Active 3731 and then Has_Discriminants (Obj_Type) 3732 then 3733 Comp := First_Component (Obj_Type); 3734 while Present (Comp) loop 3735 if Known_Static_Esize (Etype (Comp)) 3736 or else Size_Known_At_Compile_Time (Etype (Comp)) 3737 then 3738 null; 3739 3740 elsif not Discriminated_Size (Comp) 3741 and then Comes_From_Source (Comp) 3742 then 3743 Error_Msg_NE 3744 ("component& of non-static size will violate restriction " 3745 & "No_Implicit_Heap_Allocation?", N, Comp); 3746 3747 elsif Is_Record_Type (Etype (Comp)) then 3748 Check_Dynamic_Object (Etype (Comp)); 3749 end if; 3750 3751 Next_Component (Comp); 3752 end loop; 3753 end if; 3754 end Check_Dynamic_Object; 3755 3756 ----------------------------------------- 3757 -- Check_For_Null_Excluding_Components -- 3758 ----------------------------------------- 3759 3760 procedure Check_For_Null_Excluding_Components 3761 (Obj_Typ : Entity_Id; 3762 Obj_Decl : Node_Id) 3763 is 3764 procedure Check_Component 3765 (Comp_Typ : Entity_Id; 3766 Comp_Decl : Node_Id := Empty; 3767 Array_Comp : Boolean := False); 3768 -- Apply a compile-time null-exclusion check on a component denoted 3769 -- by its declaration Comp_Decl and type Comp_Typ, and all of its 3770 -- subcomponents (if any). 3771 3772 --------------------- 3773 -- Check_Component -- 3774 --------------------- 3775 3776 procedure Check_Component 3777 (Comp_Typ : Entity_Id; 3778 Comp_Decl : Node_Id := Empty; 3779 Array_Comp : Boolean := False) 3780 is 3781 Comp : Entity_Id; 3782 T : Entity_Id; 3783 3784 begin 3785 -- Do not consider internally-generated components or those that 3786 -- are already initialized. 3787 3788 if Present (Comp_Decl) 3789 and then (not Comes_From_Source (Comp_Decl) 3790 or else Present (Expression (Comp_Decl))) 3791 then 3792 return; 3793 end if; 3794 3795 if Is_Incomplete_Or_Private_Type (Comp_Typ) 3796 and then Present (Full_View (Comp_Typ)) 3797 then 3798 T := Full_View (Comp_Typ); 3799 else 3800 T := Comp_Typ; 3801 end if; 3802 3803 -- Verify a component of a null-excluding access type 3804 3805 if Is_Access_Type (T) 3806 and then Can_Never_Be_Null (T) 3807 then 3808 if Comp_Decl = Obj_Decl then 3809 Null_Exclusion_Static_Checks 3810 (N => Obj_Decl, 3811 Comp => Empty, 3812 Array_Comp => Array_Comp); 3813 3814 else 3815 Null_Exclusion_Static_Checks 3816 (N => Obj_Decl, 3817 Comp => Comp_Decl, 3818 Array_Comp => Array_Comp); 3819 end if; 3820 3821 -- Check array components 3822 3823 elsif Is_Array_Type (T) then 3824 3825 -- There is no suitable component when the object is of an 3826 -- array type. However, a namable component may appear at some 3827 -- point during the recursive inspection, but not at the top 3828 -- level. At the top level just indicate array component case. 3829 3830 if Comp_Decl = Obj_Decl then 3831 Check_Component (Component_Type (T), Array_Comp => True); 3832 else 3833 Check_Component (Component_Type (T), Comp_Decl); 3834 end if; 3835 3836 -- Verify all components of type T 3837 3838 -- Note: No checks are performed on types with discriminants due 3839 -- to complexities involving variants. ??? 3840 3841 elsif (Is_Concurrent_Type (T) 3842 or else Is_Incomplete_Or_Private_Type (T) 3843 or else Is_Record_Type (T)) 3844 and then not Has_Discriminants (T) 3845 then 3846 Comp := First_Component (T); 3847 while Present (Comp) loop 3848 Check_Component (Etype (Comp), Parent (Comp)); 3849 3850 Comp := Next_Component (Comp); 3851 end loop; 3852 end if; 3853 end Check_Component; 3854 3855 -- Start processing for Check_For_Null_Excluding_Components 3856 3857 begin 3858 Check_Component (Obj_Typ, Obj_Decl); 3859 end Check_For_Null_Excluding_Components; 3860 3861 ----------------- 3862 -- Count_Tasks -- 3863 ----------------- 3864 3865 function Count_Tasks (T : Entity_Id) return Uint is 3866 C : Entity_Id; 3867 X : Node_Id; 3868 V : Uint; 3869 3870 begin 3871 if Is_Task_Type (T) then 3872 return Uint_1; 3873 3874 elsif Is_Record_Type (T) then 3875 if Has_Discriminants (T) then 3876 Check_Restriction (Max_Tasks, N); 3877 return Uint_0; 3878 3879 else 3880 V := Uint_0; 3881 C := First_Component (T); 3882 while Present (C) loop 3883 V := V + Count_Tasks (Etype (C)); 3884 Next_Component (C); 3885 end loop; 3886 3887 return V; 3888 end if; 3889 3890 elsif Is_Array_Type (T) then 3891 X := First_Index (T); 3892 V := Count_Tasks (Component_Type (T)); 3893 while Present (X) loop 3894 C := Etype (X); 3895 3896 if not Is_OK_Static_Subtype (C) then 3897 Check_Restriction (Max_Tasks, N); 3898 return Uint_0; 3899 else 3900 V := V * (UI_Max (Uint_0, 3901 Expr_Value (Type_High_Bound (C)) - 3902 Expr_Value (Type_Low_Bound (C)) + Uint_1)); 3903 end if; 3904 3905 Next_Index (X); 3906 end loop; 3907 3908 return V; 3909 3910 else 3911 return Uint_0; 3912 end if; 3913 end Count_Tasks; 3914 3915 ---------------------------- 3916 -- Delayed_Aspect_Present -- 3917 ---------------------------- 3918 3919 function Delayed_Aspect_Present return Boolean is 3920 A : Node_Id; 3921 A_Id : Aspect_Id; 3922 3923 begin 3924 if Present (Aspect_Specifications (N)) then 3925 A := First (Aspect_Specifications (N)); 3926 A_Id := Get_Aspect_Id (Chars (Identifier (A))); 3927 while Present (A) loop 3928 if A_Id = Aspect_Alignment or else A_Id = Aspect_Address then 3929 3930 -- Set flag on object entity, for later processing at 3931 -- the freeze point. 3932 3933 Set_Has_Delayed_Aspects (Id); 3934 return True; 3935 end if; 3936 3937 Next (A); 3938 end loop; 3939 end if; 3940 3941 return False; 3942 end Delayed_Aspect_Present; 3943 3944 -- Local variables 3945 3946 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 3947 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 3948 -- Save the Ghost-related attributes to restore on exit 3949 3950 Related_Id : Entity_Id; 3951 Full_View_Present : Boolean := False; 3952 3953 -- Start of processing for Analyze_Object_Declaration 3954 3955 begin 3956 -- There are three kinds of implicit types generated by an 3957 -- object declaration: 3958 3959 -- 1. Those generated by the original Object Definition 3960 3961 -- 2. Those generated by the Expression 3962 3963 -- 3. Those used to constrain the Object Definition with the 3964 -- expression constraints when the definition is unconstrained. 3965 3966 -- They must be generated in this order to avoid order of elaboration 3967 -- issues. Thus the first step (after entering the name) is to analyze 3968 -- the object definition. 3969 3970 if Constant_Present (N) then 3971 Prev_Entity := Current_Entity_In_Scope (Id); 3972 3973 if Present (Prev_Entity) 3974 and then 3975 -- If the homograph is an implicit subprogram, it is overridden 3976 -- by the current declaration. 3977 3978 ((Is_Overloadable (Prev_Entity) 3979 and then Is_Inherited_Operation (Prev_Entity)) 3980 3981 -- The current object is a discriminal generated for an entry 3982 -- family index. Even though the index is a constant, in this 3983 -- particular context there is no true constant redeclaration. 3984 -- Enter_Name will handle the visibility. 3985 3986 or else 3987 (Is_Discriminal (Id) 3988 and then Ekind (Discriminal_Link (Id)) = 3989 E_Entry_Index_Parameter) 3990 3991 -- The current object is the renaming for a generic declared 3992 -- within the instance. 3993 3994 or else 3995 (Ekind (Prev_Entity) = E_Package 3996 and then Nkind (Parent (Prev_Entity)) = 3997 N_Package_Renaming_Declaration 3998 and then not Comes_From_Source (Prev_Entity) 3999 and then 4000 Is_Generic_Instance (Renamed_Entity (Prev_Entity))) 4001 4002 -- The entity may be a homonym of a private component of the 4003 -- enclosing protected object, for which we create a local 4004 -- renaming declaration. The declaration is legal, even if 4005 -- useless when it just captures that component. 4006 4007 or else 4008 (Ekind (Scope (Current_Scope)) = E_Protected_Type 4009 and then Nkind (Parent (Prev_Entity)) = 4010 N_Object_Renaming_Declaration)) 4011 then 4012 Prev_Entity := Empty; 4013 end if; 4014 end if; 4015 4016 if Present (Prev_Entity) then 4017 4018 -- The object declaration is Ghost when it completes a deferred Ghost 4019 -- constant. 4020 4021 Mark_And_Set_Ghost_Completion (N, Prev_Entity); 4022 4023 Constant_Redeclaration (Id, N, T); 4024 4025 Generate_Reference (Prev_Entity, Id, 'c'); 4026 Set_Completion_Referenced (Id); 4027 4028 if Error_Posted (N) then 4029 4030 -- Type mismatch or illegal redeclaration; do not analyze 4031 -- expression to avoid cascaded errors. 4032 4033 T := Find_Type_Of_Object (Object_Definition (N), N); 4034 Set_Etype (Id, T); 4035 Set_Ekind (Id, E_Variable); 4036 goto Leave; 4037 end if; 4038 4039 -- In the normal case, enter identifier at the start to catch premature 4040 -- usage in the initialization expression. 4041 4042 else 4043 Generate_Definition (Id); 4044 Enter_Name (Id); 4045 4046 Mark_Coextensions (N, Object_Definition (N)); 4047 4048 T := Find_Type_Of_Object (Object_Definition (N), N); 4049 4050 if Nkind (Object_Definition (N)) = N_Access_Definition 4051 and then Present 4052 (Access_To_Subprogram_Definition (Object_Definition (N))) 4053 and then Protected_Present 4054 (Access_To_Subprogram_Definition (Object_Definition (N))) 4055 then 4056 T := Replace_Anonymous_Access_To_Protected_Subprogram (N); 4057 end if; 4058 4059 if Error_Posted (Id) then 4060 Set_Etype (Id, T); 4061 Set_Ekind (Id, E_Variable); 4062 goto Leave; 4063 end if; 4064 end if; 4065 4066 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry 4067 -- out some static checks. 4068 4069 if Ada_Version >= Ada_2005 then 4070 4071 -- In case of aggregates we must also take care of the correct 4072 -- initialization of nested aggregates bug this is done at the 4073 -- point of the analysis of the aggregate (see sem_aggr.adb) ??? 4074 4075 if Can_Never_Be_Null (T) then 4076 if Present (Expression (N)) 4077 and then Nkind (Expression (N)) = N_Aggregate 4078 then 4079 null; 4080 4081 else 4082 declare 4083 Save_Typ : constant Entity_Id := Etype (Id); 4084 begin 4085 Set_Etype (Id, T); -- Temp. decoration for static checks 4086 Null_Exclusion_Static_Checks (N); 4087 Set_Etype (Id, Save_Typ); 4088 end; 4089 end if; 4090 4091 -- We might be dealing with an object of a composite type containing 4092 -- null-excluding components without an aggregate, so we must verify 4093 -- that such components have default initialization. 4094 4095 else 4096 Check_For_Null_Excluding_Components (T, N); 4097 end if; 4098 end if; 4099 4100 -- Object is marked pure if it is in a pure scope 4101 4102 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 4103 4104 -- If deferred constant, make sure context is appropriate. We detect 4105 -- a deferred constant as a constant declaration with no expression. 4106 -- A deferred constant can appear in a package body if its completion 4107 -- is by means of an interface pragma. 4108 4109 if Constant_Present (N) and then No (E) then 4110 4111 -- A deferred constant may appear in the declarative part of the 4112 -- following constructs: 4113 4114 -- blocks 4115 -- entry bodies 4116 -- extended return statements 4117 -- package specs 4118 -- package bodies 4119 -- subprogram bodies 4120 -- task bodies 4121 4122 -- When declared inside a package spec, a deferred constant must be 4123 -- completed by a full constant declaration or pragma Import. In all 4124 -- other cases, the only proper completion is pragma Import. Extended 4125 -- return statements are flagged as invalid contexts because they do 4126 -- not have a declarative part and so cannot accommodate the pragma. 4127 4128 if Ekind (Current_Scope) = E_Return_Statement then 4129 Error_Msg_N 4130 ("invalid context for deferred constant declaration (RM 7.4)", 4131 N); 4132 Error_Msg_N 4133 ("\declaration requires an initialization expression", 4134 N); 4135 Set_Constant_Present (N, False); 4136 4137 -- In Ada 83, deferred constant must be of private type 4138 4139 elsif not Is_Private_Type (T) then 4140 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 4141 Error_Msg_N 4142 ("(Ada 83) deferred constant must be private type", N); 4143 end if; 4144 end if; 4145 4146 -- If not a deferred constant, then the object declaration freezes 4147 -- its type, unless the object is of an anonymous type and has delayed 4148 -- aspects. In that case the type is frozen when the object itself is. 4149 4150 else 4151 Check_Fully_Declared (T, N); 4152 4153 if Has_Delayed_Aspects (Id) 4154 and then Is_Array_Type (T) 4155 and then Is_Itype (T) 4156 then 4157 Set_Has_Delayed_Freeze (T); 4158 else 4159 Freeze_Before (N, T); 4160 end if; 4161 end if; 4162 4163 -- If the object was created by a constrained array definition, then 4164 -- set the link in both the anonymous base type and anonymous subtype 4165 -- that are built to represent the array type to point to the object. 4166 4167 if Nkind (Object_Definition (Declaration_Node (Id))) = 4168 N_Constrained_Array_Definition 4169 then 4170 Set_Related_Array_Object (T, Id); 4171 Set_Related_Array_Object (Base_Type (T), Id); 4172 end if; 4173 4174 -- Special checks for protected objects not at library level 4175 4176 if Has_Protected (T) and then not Is_Library_Level_Entity (Id) then 4177 Check_Restriction (No_Local_Protected_Objects, Id); 4178 4179 -- Protected objects with interrupt handlers must be at library level 4180 4181 -- Ada 2005: This test is not needed (and the corresponding clause 4182 -- in the RM is removed) because accessibility checks are sufficient 4183 -- to make handlers not at the library level illegal. 4184 4185 -- AI05-0303: The AI is in fact a binding interpretation, and thus 4186 -- applies to the '95 version of the language as well. 4187 4188 if Is_Protected_Type (T) 4189 and then Has_Interrupt_Handler (T) 4190 and then Ada_Version < Ada_95 4191 then 4192 Error_Msg_N 4193 ("interrupt object can only be declared at library level", Id); 4194 end if; 4195 end if; 4196 4197 -- Check for violation of No_Local_Timing_Events 4198 4199 if Has_Timing_Event (T) and then not Is_Library_Level_Entity (Id) then 4200 Check_Restriction (No_Local_Timing_Events, Id); 4201 end if; 4202 4203 -- The actual subtype of the object is the nominal subtype, unless 4204 -- the nominal one is unconstrained and obtained from the expression. 4205 4206 Act_T := T; 4207 4208 -- These checks should be performed before the initialization expression 4209 -- is considered, so that the Object_Definition node is still the same 4210 -- as in source code. 4211 4212 -- In SPARK, the nominal subtype is always given by a subtype mark 4213 -- and must not be unconstrained. (The only exception to this is the 4214 -- acceptance of declarations of constants of type String.) 4215 4216 if not Nkind_In (Object_Definition (N), N_Expanded_Name, N_Identifier) 4217 then 4218 Check_SPARK_05_Restriction 4219 ("subtype mark required", Object_Definition (N)); 4220 4221 elsif Is_Array_Type (T) 4222 and then not Is_Constrained (T) 4223 and then T /= Standard_String 4224 then 4225 Check_SPARK_05_Restriction 4226 ("subtype mark of constrained type expected", 4227 Object_Definition (N)); 4228 end if; 4229 4230 if Is_Library_Level_Entity (Id) then 4231 Check_Dynamic_Object (T); 4232 end if; 4233 4234 -- There are no aliased objects in SPARK 4235 4236 if Aliased_Present (N) then 4237 Check_SPARK_05_Restriction ("aliased object is not allowed", N); 4238 end if; 4239 4240 -- Process initialization expression if present and not in error 4241 4242 if Present (E) and then E /= Error then 4243 4244 -- Generate an error in case of CPP class-wide object initialization. 4245 -- Required because otherwise the expansion of the class-wide 4246 -- assignment would try to use 'size to initialize the object 4247 -- (primitive that is not available in CPP tagged types). 4248 4249 if Is_Class_Wide_Type (Act_T) 4250 and then 4251 (Is_CPP_Class (Root_Type (Etype (Act_T))) 4252 or else 4253 (Present (Full_View (Root_Type (Etype (Act_T)))) 4254 and then 4255 Is_CPP_Class (Full_View (Root_Type (Etype (Act_T)))))) 4256 then 4257 Error_Msg_N 4258 ("predefined assignment not available for 'C'P'P tagged types", 4259 E); 4260 end if; 4261 4262 Mark_Coextensions (N, E); 4263 Analyze (E); 4264 4265 -- In case of errors detected in the analysis of the expression, 4266 -- decorate it with the expected type to avoid cascaded errors 4267 4268 if No (Etype (E)) then 4269 Set_Etype (E, T); 4270 end if; 4271 4272 -- If an initialization expression is present, then we set the 4273 -- Is_True_Constant flag. It will be reset if this is a variable 4274 -- and it is indeed modified. 4275 4276 Set_Is_True_Constant (Id, True); 4277 4278 -- If we are analyzing a constant declaration, set its completion 4279 -- flag after analyzing and resolving the expression. 4280 4281 if Constant_Present (N) then 4282 Set_Has_Completion (Id); 4283 end if; 4284 4285 -- Set type and resolve (type may be overridden later on). Note: 4286 -- Ekind (Id) must still be E_Void at this point so that incorrect 4287 -- early usage within E is properly diagnosed. 4288 4289 Set_Etype (Id, T); 4290 4291 -- If the expression is an aggregate we must look ahead to detect 4292 -- the possible presence of an address clause, and defer resolution 4293 -- and expansion of the aggregate to the freeze point of the entity. 4294 4295 -- This is not always legal because the aggregate may contain other 4296 -- references that need freezing, e.g. references to other entities 4297 -- with address clauses. In any case, when compiling with -gnatI the 4298 -- presence of the address clause must be ignored. 4299 4300 if Comes_From_Source (N) 4301 and then Expander_Active 4302 and then Nkind (E) = N_Aggregate 4303 and then 4304 ((Present (Following_Address_Clause (N)) 4305 and then not Ignore_Rep_Clauses) 4306 or else Delayed_Aspect_Present) 4307 then 4308 Set_Etype (E, T); 4309 4310 -- If the aggregate is limited it will be built in place, and its 4311 -- expansion is deferred until the object declaration is expanded. 4312 4313 if Is_Limited_Type (T) then 4314 Set_Expansion_Delayed (E); 4315 end if; 4316 4317 else 4318 -- If the expression is a formal that is a "subprogram pointer" 4319 -- this is illegal in accessibility terms (see RM 3.10.2 (13.1/2) 4320 -- and AARM 3.10.2 (13.b/2)). Add an explicit conversion to force 4321 -- the corresponding check, as is done for assignments. 4322 4323 if Is_Entity_Name (E) 4324 and then Present (Entity (E)) 4325 and then Is_Formal (Entity (E)) 4326 and then 4327 Ekind (Etype (Entity (E))) = E_Anonymous_Access_Subprogram_Type 4328 and then Ekind (T) /= E_Anonymous_Access_Subprogram_Type 4329 then 4330 Rewrite (E, Convert_To (T, Relocate_Node (E))); 4331 end if; 4332 4333 Resolve (E, T); 4334 end if; 4335 4336 -- No further action needed if E is a call to an inlined function 4337 -- which returns an unconstrained type and it has been expanded into 4338 -- a procedure call. In that case N has been replaced by an object 4339 -- declaration without initializing expression and it has been 4340 -- analyzed (see Expand_Inlined_Call). 4341 4342 if Back_End_Inlining 4343 and then Expander_Active 4344 and then Nkind (E) = N_Function_Call 4345 and then Nkind (Name (E)) in N_Has_Entity 4346 and then Is_Inlined (Entity (Name (E))) 4347 and then not Is_Constrained (Etype (E)) 4348 and then Analyzed (N) 4349 and then No (Expression (N)) 4350 then 4351 goto Leave; 4352 end if; 4353 4354 -- If E is null and has been replaced by an N_Raise_Constraint_Error 4355 -- node (which was marked already-analyzed), we need to set the type 4356 -- to something other than Any_Access in order to keep gigi happy. 4357 4358 if Etype (E) = Any_Access then 4359 Set_Etype (E, T); 4360 end if; 4361 4362 -- If the object is an access to variable, the initialization 4363 -- expression cannot be an access to constant. 4364 4365 if Is_Access_Type (T) 4366 and then not Is_Access_Constant (T) 4367 and then Is_Access_Type (Etype (E)) 4368 and then Is_Access_Constant (Etype (E)) 4369 then 4370 Error_Msg_N 4371 ("access to variable cannot be initialized with an " 4372 & "access-to-constant expression", E); 4373 end if; 4374 4375 if not Assignment_OK (N) then 4376 Check_Initialization (T, E); 4377 end if; 4378 4379 Check_Unset_Reference (E); 4380 4381 -- If this is a variable, then set current value. If this is a 4382 -- declared constant of a scalar type with a static expression, 4383 -- indicate that it is always valid. 4384 4385 if not Constant_Present (N) then 4386 if Compile_Time_Known_Value (E) then 4387 Set_Current_Value (Id, E); 4388 end if; 4389 4390 elsif Is_Scalar_Type (T) and then Is_OK_Static_Expression (E) then 4391 Set_Is_Known_Valid (Id); 4392 4393 -- If it is a constant initialized with a valid nonstatic entity, 4394 -- the constant is known valid as well, and can inherit the subtype 4395 -- of the entity if it is a subtype of the given type. This info 4396 -- is preserved on the actual subtype of the constant. 4397 4398 elsif Is_Scalar_Type (T) 4399 and then Is_Entity_Name (E) 4400 and then Is_Known_Valid (Entity (E)) 4401 and then In_Subrange_Of (Etype (Entity (E)), T) 4402 then 4403 Set_Is_Known_Valid (Id); 4404 Set_Ekind (Id, E_Constant); 4405 Set_Actual_Subtype (Id, Etype (Entity (E))); 4406 end if; 4407 4408 -- Deal with setting of null flags 4409 4410 if Is_Access_Type (T) then 4411 if Known_Non_Null (E) then 4412 Set_Is_Known_Non_Null (Id, True); 4413 elsif Known_Null (E) and then not Can_Never_Be_Null (Id) then 4414 Set_Is_Known_Null (Id, True); 4415 end if; 4416 end if; 4417 4418 -- Check incorrect use of dynamically tagged expressions 4419 4420 if Is_Tagged_Type (T) then 4421 Check_Dynamically_Tagged_Expression 4422 (Expr => E, 4423 Typ => T, 4424 Related_Nod => N); 4425 end if; 4426 4427 Apply_Scalar_Range_Check (E, T); 4428 Apply_Static_Length_Check (E, T); 4429 4430 if Nkind (Original_Node (N)) = N_Object_Declaration 4431 and then Comes_From_Source (Original_Node (N)) 4432 4433 -- Only call test if needed 4434 4435 and then Restriction_Check_Required (SPARK_05) 4436 and then not Is_SPARK_05_Initialization_Expr (Original_Node (E)) 4437 then 4438 Check_SPARK_05_Restriction 4439 ("initialization expression is not appropriate", E); 4440 end if; 4441 4442 -- A formal parameter of a specific tagged type whose related 4443 -- subprogram is subject to pragma Extensions_Visible with value 4444 -- "False" cannot be implicitly converted to a class-wide type by 4445 -- means of an initialization expression (SPARK RM 6.1.7(3)). Do 4446 -- not consider internally generated expressions. 4447 4448 if Is_Class_Wide_Type (T) 4449 and then Comes_From_Source (E) 4450 and then Is_EVF_Expression (E) 4451 then 4452 Error_Msg_N 4453 ("formal parameter cannot be implicitly converted to " 4454 & "class-wide type when Extensions_Visible is False", E); 4455 end if; 4456 end if; 4457 4458 -- If the No_Streams restriction is set, check that the type of the 4459 -- object is not, and does not contain, any subtype derived from 4460 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to 4461 -- Has_Stream just for efficiency reasons. There is no point in 4462 -- spending time on a Has_Stream check if the restriction is not set. 4463 4464 if Restriction_Check_Required (No_Streams) then 4465 if Has_Stream (T) then 4466 Check_Restriction (No_Streams, N); 4467 end if; 4468 end if; 4469 4470 -- Deal with predicate check before we start to do major rewriting. It 4471 -- is OK to initialize and then check the initialized value, since the 4472 -- object goes out of scope if we get a predicate failure. Note that we 4473 -- do this in the analyzer and not the expander because the analyzer 4474 -- does some substantial rewriting in some cases. 4475 4476 -- We need a predicate check if the type has predicates that are not 4477 -- ignored, and if either there is an initializing expression, or for 4478 -- default initialization when we have at least one case of an explicit 4479 -- default initial value and then this is not an internal declaration 4480 -- whose initialization comes later (as for an aggregate expansion). 4481 -- If expression is an aggregate it may be expanded into assignments 4482 -- and the declaration itself is marked with No_Initialization, but 4483 -- the predicate still applies. 4484 4485 if not Suppress_Assignment_Checks (N) 4486 and then Present (Predicate_Function (T)) 4487 and then not Predicates_Ignored (T) 4488 and then 4489 (not No_Initialization (N) 4490 or else (Present (E) and then Nkind (E) = N_Aggregate)) 4491 and then 4492 (Present (E) 4493 or else 4494 Is_Partially_Initialized_Type (T, Include_Implicit => False)) 4495 then 4496 -- If the type has a static predicate and the expression is known at 4497 -- compile time, see if the expression satisfies the predicate. 4498 4499 if Present (E) then 4500 Check_Expression_Against_Static_Predicate (E, T); 4501 end if; 4502 4503 -- If the type is a null record and there is no explicit initial 4504 -- expression, no predicate check applies. 4505 4506 if No (E) and then Is_Null_Record_Type (T) then 4507 null; 4508 4509 -- Do not generate a predicate check if the initialization expression 4510 -- is a type conversion because the conversion has been subjected to 4511 -- the same check. This is a small optimization which avoid redundant 4512 -- checks. 4513 4514 elsif Present (E) and then Nkind (E) = N_Type_Conversion then 4515 null; 4516 4517 else 4518 -- The check must be inserted after the expanded aggregate 4519 -- expansion code, if any. 4520 4521 declare 4522 Check : constant Node_Id := 4523 Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)); 4524 4525 begin 4526 if No (Next_Decl) then 4527 Append_To (List_Containing (N), Check); 4528 else 4529 Insert_Before (Next_Decl, Check); 4530 end if; 4531 end; 4532 end if; 4533 end if; 4534 4535 -- Case of unconstrained type 4536 4537 if not Is_Definite_Subtype (T) then 4538 4539 -- In SPARK, a declaration of unconstrained type is allowed 4540 -- only for constants of type string. 4541 4542 if Is_String_Type (T) and then not Constant_Present (N) then 4543 Check_SPARK_05_Restriction 4544 ("declaration of object of unconstrained type not allowed", N); 4545 end if; 4546 4547 -- Nothing to do in deferred constant case 4548 4549 if Constant_Present (N) and then No (E) then 4550 null; 4551 4552 -- Case of no initialization present 4553 4554 elsif No (E) then 4555 if No_Initialization (N) then 4556 null; 4557 4558 elsif Is_Class_Wide_Type (T) then 4559 Error_Msg_N 4560 ("initialization required in class-wide declaration ", N); 4561 4562 else 4563 Error_Msg_N 4564 ("unconstrained subtype not allowed (need initialization)", 4565 Object_Definition (N)); 4566 4567 if Is_Record_Type (T) and then Has_Discriminants (T) then 4568 Error_Msg_N 4569 ("\provide initial value or explicit discriminant values", 4570 Object_Definition (N)); 4571 4572 Error_Msg_NE 4573 ("\or give default discriminant values for type&", 4574 Object_Definition (N), T); 4575 4576 elsif Is_Array_Type (T) then 4577 Error_Msg_N 4578 ("\provide initial value or explicit array bounds", 4579 Object_Definition (N)); 4580 end if; 4581 end if; 4582 4583 -- Case of initialization present but in error. Set initial 4584 -- expression as absent (but do not make above complaints) 4585 4586 elsif E = Error then 4587 Set_Expression (N, Empty); 4588 E := Empty; 4589 4590 -- Case of initialization present 4591 4592 else 4593 -- Check restrictions in Ada 83 4594 4595 if not Constant_Present (N) then 4596 4597 -- Unconstrained variables not allowed in Ada 83 mode 4598 4599 if Ada_Version = Ada_83 4600 and then Comes_From_Source (Object_Definition (N)) 4601 then 4602 Error_Msg_N 4603 ("(Ada 83) unconstrained variable not allowed", 4604 Object_Definition (N)); 4605 end if; 4606 end if; 4607 4608 -- Now we constrain the variable from the initializing expression 4609 4610 -- If the expression is an aggregate, it has been expanded into 4611 -- individual assignments. Retrieve the actual type from the 4612 -- expanded construct. 4613 4614 if Is_Array_Type (T) 4615 and then No_Initialization (N) 4616 and then Nkind (Original_Node (E)) = N_Aggregate 4617 then 4618 Act_T := Etype (E); 4619 4620 -- In case of class-wide interface object declarations we delay 4621 -- the generation of the equivalent record type declarations until 4622 -- its expansion because there are cases in they are not required. 4623 4624 elsif Is_Interface (T) then 4625 null; 4626 4627 -- If the type is an unchecked union, no subtype can be built from 4628 -- the expression. Rewrite declaration as a renaming, which the 4629 -- back-end can handle properly. This is a rather unusual case, 4630 -- because most unchecked_union declarations have default values 4631 -- for discriminants and are thus not indefinite. 4632 4633 elsif Is_Unchecked_Union (T) then 4634 if Constant_Present (N) or else Nkind (E) = N_Function_Call then 4635 Set_Ekind (Id, E_Constant); 4636 else 4637 Set_Ekind (Id, E_Variable); 4638 end if; 4639 4640 Rewrite (N, 4641 Make_Object_Renaming_Declaration (Loc, 4642 Defining_Identifier => Id, 4643 Subtype_Mark => New_Occurrence_Of (T, Loc), 4644 Name => E)); 4645 4646 Set_Renamed_Object (Id, E); 4647 Freeze_Before (N, T); 4648 Set_Is_Frozen (Id); 4649 goto Leave; 4650 4651 else 4652 -- Ensure that the generated subtype has a unique external name 4653 -- when the related object is public. This guarantees that the 4654 -- subtype and its bounds will not be affected by switches or 4655 -- pragmas that may offset the internal counter due to extra 4656 -- generated code. 4657 4658 if Is_Public (Id) then 4659 Related_Id := Id; 4660 else 4661 Related_Id := Empty; 4662 end if; 4663 4664 Expand_Subtype_From_Expr 4665 (N => N, 4666 Unc_Type => T, 4667 Subtype_Indic => Object_Definition (N), 4668 Exp => E, 4669 Related_Id => Related_Id); 4670 4671 Act_T := Find_Type_Of_Object (Object_Definition (N), N); 4672 end if; 4673 4674 -- Propagate attributes to full view when needed. 4675 4676 Set_Is_Constr_Subt_For_U_Nominal (Act_T); 4677 4678 if Is_Private_Type (Act_T) and then Present (Full_View (Act_T)) 4679 then 4680 Full_View_Present := True; 4681 end if; 4682 4683 if Full_View_Present then 4684 Set_Is_Constr_Subt_For_U_Nominal (Full_View (Act_T)); 4685 end if; 4686 4687 if Aliased_Present (N) then 4688 Set_Is_Constr_Subt_For_UN_Aliased (Act_T); 4689 4690 if Full_View_Present then 4691 Set_Is_Constr_Subt_For_UN_Aliased (Full_View (Act_T)); 4692 end if; 4693 end if; 4694 4695 Freeze_Before (N, Act_T); 4696 Freeze_Before (N, T); 4697 end if; 4698 4699 elsif Is_Array_Type (T) 4700 and then No_Initialization (N) 4701 and then (Nkind (Original_Node (E)) = N_Aggregate 4702 or else (Nkind (Original_Node (E)) = N_Qualified_Expression 4703 and then Nkind (Original_Node (Expression 4704 (Original_Node (E)))) = N_Aggregate)) 4705 then 4706 if not Is_Entity_Name (Object_Definition (N)) then 4707 Act_T := Etype (E); 4708 Check_Compile_Time_Size (Act_T); 4709 4710 if Aliased_Present (N) then 4711 Set_Is_Constr_Subt_For_UN_Aliased (Act_T); 4712 end if; 4713 end if; 4714 4715 -- When the given object definition and the aggregate are specified 4716 -- independently, and their lengths might differ do a length check. 4717 -- This cannot happen if the aggregate is of the form (others =>...) 4718 4719 if not Is_Constrained (T) then 4720 null; 4721 4722 elsif Nkind (E) = N_Raise_Constraint_Error then 4723 4724 -- Aggregate is statically illegal. Place back in declaration 4725 4726 Set_Expression (N, E); 4727 Set_No_Initialization (N, False); 4728 4729 elsif T = Etype (E) then 4730 null; 4731 4732 elsif Nkind (E) = N_Aggregate 4733 and then Present (Component_Associations (E)) 4734 and then Present (Choice_List (First (Component_Associations (E)))) 4735 and then 4736 Nkind (First (Choice_List (First (Component_Associations (E))))) = 4737 N_Others_Choice 4738 then 4739 null; 4740 4741 else 4742 Apply_Length_Check (E, T); 4743 end if; 4744 4745 -- If the type is limited unconstrained with defaulted discriminants and 4746 -- there is no expression, then the object is constrained by the 4747 -- defaults, so it is worthwhile building the corresponding subtype. 4748 4749 elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T)) 4750 and then not Is_Constrained (T) 4751 and then Has_Discriminants (T) 4752 then 4753 if No (E) then 4754 Act_T := Build_Default_Subtype (T, N); 4755 else 4756 -- Ada 2005: A limited object may be initialized by means of an 4757 -- aggregate. If the type has default discriminants it has an 4758 -- unconstrained nominal type, Its actual subtype will be obtained 4759 -- from the aggregate, and not from the default discriminants. 4760 4761 Act_T := Etype (E); 4762 end if; 4763 4764 Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc)); 4765 4766 elsif Nkind (E) = N_Function_Call 4767 and then Constant_Present (N) 4768 and then Has_Unconstrained_Elements (Etype (E)) 4769 then 4770 -- The back-end has problems with constants of a discriminated type 4771 -- with defaults, if the initial value is a function call. We 4772 -- generate an intermediate temporary that will receive a reference 4773 -- to the result of the call. The initialization expression then 4774 -- becomes a dereference of that temporary. 4775 4776 Remove_Side_Effects (E); 4777 4778 -- If this is a constant declaration of an unconstrained type and 4779 -- the initialization is an aggregate, we can use the subtype of the 4780 -- aggregate for the declared entity because it is immutable. 4781 4782 elsif not Is_Constrained (T) 4783 and then Has_Discriminants (T) 4784 and then Constant_Present (N) 4785 and then not Has_Unchecked_Union (T) 4786 and then Nkind (E) = N_Aggregate 4787 then 4788 Act_T := Etype (E); 4789 end if; 4790 4791 -- Check No_Wide_Characters restriction 4792 4793 Check_Wide_Character_Restriction (T, Object_Definition (N)); 4794 4795 -- Indicate this is not set in source. Certainly true for constants, and 4796 -- true for variables so far (will be reset for a variable if and when 4797 -- we encounter a modification in the source). 4798 4799 Set_Never_Set_In_Source (Id); 4800 4801 -- Now establish the proper kind and type of the object 4802 4803 if Constant_Present (N) then 4804 Set_Ekind (Id, E_Constant); 4805 Set_Is_True_Constant (Id); 4806 4807 else 4808 Set_Ekind (Id, E_Variable); 4809 4810 -- A variable is set as shared passive if it appears in a shared 4811 -- passive package, and is at the outer level. This is not done for 4812 -- entities generated during expansion, because those are always 4813 -- manipulated locally. 4814 4815 if Is_Shared_Passive (Current_Scope) 4816 and then Is_Library_Level_Entity (Id) 4817 and then Comes_From_Source (Id) 4818 then 4819 Set_Is_Shared_Passive (Id); 4820 Check_Shared_Var (Id, T, N); 4821 end if; 4822 4823 -- Set Has_Initial_Value if initializing expression present. Note 4824 -- that if there is no initializing expression, we leave the state 4825 -- of this flag unchanged (usually it will be False, but notably in 4826 -- the case of exception choice variables, it will already be true). 4827 4828 if Present (E) then 4829 Set_Has_Initial_Value (Id); 4830 end if; 4831 end if; 4832 4833 -- Set the SPARK mode from the current context (may be overwritten later 4834 -- with explicit pragma). 4835 4836 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); 4837 Set_SPARK_Pragma_Inherited (Id); 4838 4839 -- Preserve relevant elaboration-related attributes of the context which 4840 -- are no longer available or very expensive to recompute once analysis, 4841 -- resolution, and expansion are over. 4842 4843 Mark_Elaboration_Attributes 4844 (N_Id => Id, 4845 Checks => True, 4846 Warnings => True); 4847 4848 -- Initialize alignment and size and capture alignment setting 4849 4850 Init_Alignment (Id); 4851 Init_Esize (Id); 4852 Set_Optimize_Alignment_Flags (Id); 4853 4854 -- Deal with aliased case 4855 4856 if Aliased_Present (N) then 4857 Set_Is_Aliased (Id); 4858 4859 -- AI12-001: All aliased objects are considered to be specified as 4860 -- independently addressable (RM C.6(8.1/4)). 4861 4862 Set_Is_Independent (Id); 4863 4864 -- If the object is aliased and the type is unconstrained with 4865 -- defaulted discriminants and there is no expression, then the 4866 -- object is constrained by the defaults, so it is worthwhile 4867 -- building the corresponding subtype. 4868 4869 -- Ada 2005 (AI-363): If the aliased object is discriminated and 4870 -- unconstrained, then only establish an actual subtype if the 4871 -- nominal subtype is indefinite. In definite cases the object is 4872 -- unconstrained in Ada 2005. 4873 4874 if No (E) 4875 and then Is_Record_Type (T) 4876 and then not Is_Constrained (T) 4877 and then Has_Discriminants (T) 4878 and then (Ada_Version < Ada_2005 4879 or else not Is_Definite_Subtype (T)) 4880 then 4881 Set_Actual_Subtype (Id, Build_Default_Subtype (T, N)); 4882 end if; 4883 end if; 4884 4885 -- Now we can set the type of the object 4886 4887 Set_Etype (Id, Act_T); 4888 4889 -- Non-constant object is marked to be treated as volatile if type is 4890 -- volatile and we clear the Current_Value setting that may have been 4891 -- set above. Doing so for constants isn't required and might interfere 4892 -- with possible uses of the object as a static expression in contexts 4893 -- incompatible with volatility (e.g. as a case-statement alternative). 4894 4895 if Ekind (Id) /= E_Constant and then Treat_As_Volatile (Etype (Id)) then 4896 Set_Treat_As_Volatile (Id); 4897 Set_Current_Value (Id, Empty); 4898 end if; 4899 4900 -- Deal with controlled types 4901 4902 if Has_Controlled_Component (Etype (Id)) 4903 or else Is_Controlled (Etype (Id)) 4904 then 4905 if not Is_Library_Level_Entity (Id) then 4906 Check_Restriction (No_Nested_Finalization, N); 4907 else 4908 Validate_Controlled_Object (Id); 4909 end if; 4910 end if; 4911 4912 if Has_Task (Etype (Id)) then 4913 Check_Restriction (No_Tasking, N); 4914 4915 -- Deal with counting max tasks 4916 4917 -- Nothing to do if inside a generic 4918 4919 if Inside_A_Generic then 4920 null; 4921 4922 -- If library level entity, then count tasks 4923 4924 elsif Is_Library_Level_Entity (Id) then 4925 Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id))); 4926 4927 -- If not library level entity, then indicate we don't know max 4928 -- tasks and also check task hierarchy restriction and blocking 4929 -- operation (since starting a task is definitely blocking). 4930 4931 else 4932 Check_Restriction (Max_Tasks, N); 4933 Check_Restriction (No_Task_Hierarchy, N); 4934 Check_Potentially_Blocking_Operation (N); 4935 end if; 4936 4937 -- A rather specialized test. If we see two tasks being declared 4938 -- of the same type in the same object declaration, and the task 4939 -- has an entry with an address clause, we know that program error 4940 -- will be raised at run time since we can't have two tasks with 4941 -- entries at the same address. 4942 4943 if Is_Task_Type (Etype (Id)) and then More_Ids (N) then 4944 declare 4945 E : Entity_Id; 4946 4947 begin 4948 E := First_Entity (Etype (Id)); 4949 while Present (E) loop 4950 if Ekind (E) = E_Entry 4951 and then Present (Get_Attribute_Definition_Clause 4952 (E, Attribute_Address)) 4953 then 4954 Error_Msg_Warn := SPARK_Mode /= On; 4955 Error_Msg_N 4956 ("more than one task with same entry address<<", N); 4957 Error_Msg_N ("\Program_Error [<<", N); 4958 Insert_Action (N, 4959 Make_Raise_Program_Error (Loc, 4960 Reason => PE_Duplicated_Entry_Address)); 4961 exit; 4962 end if; 4963 4964 Next_Entity (E); 4965 end loop; 4966 end; 4967 end if; 4968 end if; 4969 4970 -- Some simple constant-propagation: if the expression is a constant 4971 -- string initialized with a literal, share the literal. This avoids 4972 -- a run-time copy. 4973 4974 if Present (E) 4975 and then Is_Entity_Name (E) 4976 and then Ekind (Entity (E)) = E_Constant 4977 and then Base_Type (Etype (E)) = Standard_String 4978 then 4979 declare 4980 Val : constant Node_Id := Constant_Value (Entity (E)); 4981 begin 4982 if Present (Val) and then Nkind (Val) = N_String_Literal then 4983 Rewrite (E, New_Copy (Val)); 4984 end if; 4985 end; 4986 end if; 4987 4988 -- Another optimization: if the nominal subtype is unconstrained and 4989 -- the expression is a function call that returns an unconstrained 4990 -- type, rewrite the declaration as a renaming of the result of the 4991 -- call. The exceptions below are cases where the copy is expected, 4992 -- either by the back end (Aliased case) or by the semantics, as for 4993 -- initializing controlled types or copying tags for class-wide types. 4994 4995 if Present (E) 4996 and then Nkind (E) = N_Explicit_Dereference 4997 and then Nkind (Original_Node (E)) = N_Function_Call 4998 and then not Is_Library_Level_Entity (Id) 4999 and then not Is_Constrained (Underlying_Type (T)) 5000 and then not Is_Aliased (Id) 5001 and then not Is_Class_Wide_Type (T) 5002 and then not Is_Controlled (T) 5003 and then not Has_Controlled_Component (Base_Type (T)) 5004 and then Expander_Active 5005 then 5006 Rewrite (N, 5007 Make_Object_Renaming_Declaration (Loc, 5008 Defining_Identifier => Id, 5009 Access_Definition => Empty, 5010 Subtype_Mark => New_Occurrence_Of 5011 (Base_Type (Etype (Id)), Loc), 5012 Name => E)); 5013 5014 Set_Renamed_Object (Id, E); 5015 5016 -- Force generation of debugging information for the constant and for 5017 -- the renamed function call. 5018 5019 Set_Debug_Info_Needed (Id); 5020 Set_Debug_Info_Needed (Entity (Prefix (E))); 5021 end if; 5022 5023 if Present (Prev_Entity) 5024 and then Is_Frozen (Prev_Entity) 5025 and then not Error_Posted (Id) 5026 then 5027 Error_Msg_N ("full constant declaration appears too late", N); 5028 end if; 5029 5030 Check_Eliminated (Id); 5031 5032 -- Deal with setting In_Private_Part flag if in private part 5033 5034 if Ekind (Scope (Id)) = E_Package 5035 and then In_Private_Part (Scope (Id)) 5036 then 5037 Set_In_Private_Part (Id); 5038 end if; 5039 5040 <<Leave>> 5041 -- Initialize the refined state of a variable here because this is a 5042 -- common destination for legal and illegal object declarations. 5043 5044 if Ekind (Id) = E_Variable then 5045 Set_Encapsulating_State (Id, Empty); 5046 end if; 5047 5048 if Has_Aspects (N) then 5049 Analyze_Aspect_Specifications (N, Id); 5050 end if; 5051 5052 Analyze_Dimension (N); 5053 5054 -- Verify whether the object declaration introduces an illegal hidden 5055 -- state within a package subject to a null abstract state. 5056 5057 if Ekind (Id) = E_Variable then 5058 Check_No_Hidden_State (Id); 5059 end if; 5060 5061 Restore_Ghost_Region (Saved_GM, Saved_IGR); 5062 end Analyze_Object_Declaration; 5063 5064 --------------------------- 5065 -- Analyze_Others_Choice -- 5066 --------------------------- 5067 5068 -- Nothing to do for the others choice node itself, the semantic analysis 5069 -- of the others choice will occur as part of the processing of the parent 5070 5071 procedure Analyze_Others_Choice (N : Node_Id) is 5072 pragma Warnings (Off, N); 5073 begin 5074 null; 5075 end Analyze_Others_Choice; 5076 5077 ------------------------------------------- 5078 -- Analyze_Private_Extension_Declaration -- 5079 ------------------------------------------- 5080 5081 procedure Analyze_Private_Extension_Declaration (N : Node_Id) is 5082 Indic : constant Node_Id := Subtype_Indication (N); 5083 T : constant Entity_Id := Defining_Identifier (N); 5084 Iface : Entity_Id; 5085 Iface_Elmt : Elmt_Id; 5086 Parent_Base : Entity_Id; 5087 Parent_Type : Entity_Id; 5088 5089 begin 5090 -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces 5091 5092 if Is_Non_Empty_List (Interface_List (N)) then 5093 declare 5094 Intf : Node_Id; 5095 T : Entity_Id; 5096 5097 begin 5098 Intf := First (Interface_List (N)); 5099 while Present (Intf) loop 5100 T := Find_Type_Of_Subtype_Indic (Intf); 5101 5102 Diagnose_Interface (Intf, T); 5103 Next (Intf); 5104 end loop; 5105 end; 5106 end if; 5107 5108 Generate_Definition (T); 5109 5110 -- For other than Ada 2012, just enter the name in the current scope 5111 5112 if Ada_Version < Ada_2012 then 5113 Enter_Name (T); 5114 5115 -- Ada 2012 (AI05-0162): Enter the name in the current scope handling 5116 -- case of private type that completes an incomplete type. 5117 5118 else 5119 declare 5120 Prev : Entity_Id; 5121 5122 begin 5123 Prev := Find_Type_Name (N); 5124 5125 pragma Assert (Prev = T 5126 or else (Ekind (Prev) = E_Incomplete_Type 5127 and then Present (Full_View (Prev)) 5128 and then Full_View (Prev) = T)); 5129 end; 5130 end if; 5131 5132 Parent_Type := Find_Type_Of_Subtype_Indic (Indic); 5133 Parent_Base := Base_Type (Parent_Type); 5134 5135 if Parent_Type = Any_Type or else Etype (Parent_Type) = Any_Type then 5136 Set_Ekind (T, Ekind (Parent_Type)); 5137 Set_Etype (T, Any_Type); 5138 goto Leave; 5139 5140 elsif not Is_Tagged_Type (Parent_Type) then 5141 Error_Msg_N 5142 ("parent of type extension must be a tagged type ", Indic); 5143 goto Leave; 5144 5145 elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then 5146 Error_Msg_N ("premature derivation of incomplete type", Indic); 5147 goto Leave; 5148 5149 elsif Is_Concurrent_Type (Parent_Type) then 5150 Error_Msg_N 5151 ("parent type of a private extension cannot be a synchronized " 5152 & "tagged type (RM 3.9.1 (3/1))", N); 5153 5154 Set_Etype (T, Any_Type); 5155 Set_Ekind (T, E_Limited_Private_Type); 5156 Set_Private_Dependents (T, New_Elmt_List); 5157 Set_Error_Posted (T); 5158 goto Leave; 5159 end if; 5160 5161 -- Perhaps the parent type should be changed to the class-wide type's 5162 -- specific type in this case to prevent cascading errors ??? 5163 5164 if Is_Class_Wide_Type (Parent_Type) then 5165 Error_Msg_N 5166 ("parent of type extension must not be a class-wide type", Indic); 5167 goto Leave; 5168 end if; 5169 5170 if (not Is_Package_Or_Generic_Package (Current_Scope) 5171 and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration) 5172 or else In_Private_Part (Current_Scope) 5173 then 5174 Error_Msg_N ("invalid context for private extension", N); 5175 end if; 5176 5177 -- Set common attributes 5178 5179 Set_Is_Pure (T, Is_Pure (Current_Scope)); 5180 Set_Scope (T, Current_Scope); 5181 Set_Ekind (T, E_Record_Type_With_Private); 5182 Init_Size_Align (T); 5183 Set_Default_SSO (T); 5184 Set_No_Reordering (T, No_Component_Reordering); 5185 5186 Set_Etype (T, Parent_Base); 5187 Propagate_Concurrent_Flags (T, Parent_Base); 5188 5189 Set_Convention (T, Convention (Parent_Type)); 5190 Set_First_Rep_Item (T, First_Rep_Item (Parent_Type)); 5191 Set_Is_First_Subtype (T); 5192 Make_Class_Wide_Type (T); 5193 5194 -- Set the SPARK mode from the current context 5195 5196 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 5197 Set_SPARK_Pragma_Inherited (T); 5198 5199 if Unknown_Discriminants_Present (N) then 5200 Set_Discriminant_Constraint (T, No_Elist); 5201 end if; 5202 5203 Build_Derived_Record_Type (N, Parent_Type, T); 5204 5205 -- A private extension inherits the Default_Initial_Condition pragma 5206 -- coming from any parent type within the derivation chain. 5207 5208 if Has_DIC (Parent_Type) then 5209 Set_Has_Inherited_DIC (T); 5210 end if; 5211 5212 -- A private extension inherits any class-wide invariants coming from a 5213 -- parent type or an interface. Note that the invariant procedure of the 5214 -- parent type should not be inherited because the private extension may 5215 -- define invariants of its own. 5216 5217 if Has_Inherited_Invariants (Parent_Type) 5218 or else Has_Inheritable_Invariants (Parent_Type) 5219 then 5220 Set_Has_Inherited_Invariants (T); 5221 5222 elsif Present (Interfaces (T)) then 5223 Iface_Elmt := First_Elmt (Interfaces (T)); 5224 while Present (Iface_Elmt) loop 5225 Iface := Node (Iface_Elmt); 5226 5227 if Has_Inheritable_Invariants (Iface) then 5228 Set_Has_Inherited_Invariants (T); 5229 exit; 5230 end if; 5231 5232 Next_Elmt (Iface_Elmt); 5233 end loop; 5234 end if; 5235 5236 -- Ada 2005 (AI-443): Synchronized private extension or a rewritten 5237 -- synchronized formal derived type. 5238 5239 if Ada_Version >= Ada_2005 and then Synchronized_Present (N) then 5240 Set_Is_Limited_Record (T); 5241 5242 -- Formal derived type case 5243 5244 if Is_Generic_Type (T) then 5245 5246 -- The parent must be a tagged limited type or a synchronized 5247 -- interface. 5248 5249 if (not Is_Tagged_Type (Parent_Type) 5250 or else not Is_Limited_Type (Parent_Type)) 5251 and then 5252 (not Is_Interface (Parent_Type) 5253 or else not Is_Synchronized_Interface (Parent_Type)) 5254 then 5255 Error_Msg_NE 5256 ("parent type of & must be tagged limited or synchronized", 5257 N, T); 5258 end if; 5259 5260 -- The progenitors (if any) must be limited or synchronized 5261 -- interfaces. 5262 5263 if Present (Interfaces (T)) then 5264 Iface_Elmt := First_Elmt (Interfaces (T)); 5265 while Present (Iface_Elmt) loop 5266 Iface := Node (Iface_Elmt); 5267 5268 if not Is_Limited_Interface (Iface) 5269 and then not Is_Synchronized_Interface (Iface) 5270 then 5271 Error_Msg_NE 5272 ("progenitor & must be limited or synchronized", 5273 N, Iface); 5274 end if; 5275 5276 Next_Elmt (Iface_Elmt); 5277 end loop; 5278 end if; 5279 5280 -- Regular derived extension, the parent must be a limited or 5281 -- synchronized interface. 5282 5283 else 5284 if not Is_Interface (Parent_Type) 5285 or else (not Is_Limited_Interface (Parent_Type) 5286 and then not Is_Synchronized_Interface (Parent_Type)) 5287 then 5288 Error_Msg_NE 5289 ("parent type of & must be limited interface", N, T); 5290 end if; 5291 end if; 5292 5293 -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private 5294 -- extension with a synchronized parent must be explicitly declared 5295 -- synchronized, because the full view will be a synchronized type. 5296 -- This must be checked before the check for limited types below, 5297 -- to ensure that types declared limited are not allowed to extend 5298 -- synchronized interfaces. 5299 5300 elsif Is_Interface (Parent_Type) 5301 and then Is_Synchronized_Interface (Parent_Type) 5302 and then not Synchronized_Present (N) 5303 then 5304 Error_Msg_NE 5305 ("private extension of& must be explicitly synchronized", 5306 N, Parent_Type); 5307 5308 elsif Limited_Present (N) then 5309 Set_Is_Limited_Record (T); 5310 5311 if not Is_Limited_Type (Parent_Type) 5312 and then 5313 (not Is_Interface (Parent_Type) 5314 or else not Is_Limited_Interface (Parent_Type)) 5315 then 5316 Error_Msg_NE ("parent type& of limited extension must be limited", 5317 N, Parent_Type); 5318 end if; 5319 end if; 5320 5321 -- Remember that its parent type has a private extension. Used to warn 5322 -- on public primitives of the parent type defined after its private 5323 -- extensions (see Check_Dispatching_Operation). 5324 5325 Set_Has_Private_Extension (Parent_Type); 5326 5327 <<Leave>> 5328 if Has_Aspects (N) then 5329 Analyze_Aspect_Specifications (N, T); 5330 end if; 5331 end Analyze_Private_Extension_Declaration; 5332 5333 --------------------------------- 5334 -- Analyze_Subtype_Declaration -- 5335 --------------------------------- 5336 5337 procedure Analyze_Subtype_Declaration 5338 (N : Node_Id; 5339 Skip : Boolean := False) 5340 is 5341 Id : constant Entity_Id := Defining_Identifier (N); 5342 R_Checks : Check_Result; 5343 T : Entity_Id; 5344 5345 begin 5346 Generate_Definition (Id); 5347 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 5348 Init_Size_Align (Id); 5349 5350 -- The following guard condition on Enter_Name is to handle cases where 5351 -- the defining identifier has already been entered into the scope but 5352 -- the declaration as a whole needs to be analyzed. 5353 5354 -- This case in particular happens for derived enumeration types. The 5355 -- derived enumeration type is processed as an inserted enumeration type 5356 -- declaration followed by a rewritten subtype declaration. The defining 5357 -- identifier, however, is entered into the name scope very early in the 5358 -- processing of the original type declaration and therefore needs to be 5359 -- avoided here, when the created subtype declaration is analyzed. (See 5360 -- Build_Derived_Types) 5361 5362 -- This also happens when the full view of a private type is derived 5363 -- type with constraints. In this case the entity has been introduced 5364 -- in the private declaration. 5365 5366 -- Finally this happens in some complex cases when validity checks are 5367 -- enabled, where the same subtype declaration may be analyzed twice. 5368 -- This can happen if the subtype is created by the preanalysis of 5369 -- an attribute tht gives the range of a loop statement, and the loop 5370 -- itself appears within an if_statement that will be rewritten during 5371 -- expansion. 5372 5373 if Skip 5374 or else (Present (Etype (Id)) 5375 and then (Is_Private_Type (Etype (Id)) 5376 or else Is_Task_Type (Etype (Id)) 5377 or else Is_Rewrite_Substitution (N))) 5378 then 5379 null; 5380 5381 elsif Current_Entity (Id) = Id then 5382 null; 5383 5384 else 5385 Enter_Name (Id); 5386 end if; 5387 5388 T := Process_Subtype (Subtype_Indication (N), N, Id, 'P'); 5389 5390 -- Class-wide equivalent types of records with unknown discriminants 5391 -- involve the generation of an itype which serves as the private view 5392 -- of a constrained record subtype. In such cases the base type of the 5393 -- current subtype we are processing is the private itype. Use the full 5394 -- of the private itype when decorating various attributes. 5395 5396 if Is_Itype (T) 5397 and then Is_Private_Type (T) 5398 and then Present (Full_View (T)) 5399 then 5400 T := Full_View (T); 5401 end if; 5402 5403 -- Inherit common attributes 5404 5405 Set_Is_Volatile (Id, Is_Volatile (T)); 5406 Set_Treat_As_Volatile (Id, Treat_As_Volatile (T)); 5407 Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T))); 5408 Set_Convention (Id, Convention (T)); 5409 5410 -- If ancestor has predicates then so does the subtype, and in addition 5411 -- we must delay the freeze to properly arrange predicate inheritance. 5412 5413 -- The Ancestor_Type test is really unpleasant, there seem to be cases 5414 -- in which T = ID, so the above tests and assignments do nothing??? 5415 5416 if Has_Predicates (T) 5417 or else (Present (Ancestor_Subtype (T)) 5418 and then Has_Predicates (Ancestor_Subtype (T))) 5419 then 5420 Set_Has_Predicates (Id); 5421 Set_Has_Delayed_Freeze (Id); 5422 5423 -- Generated subtypes inherit the predicate function from the parent 5424 -- (no aspects to examine on the generated declaration). 5425 5426 if not Comes_From_Source (N) then 5427 Set_Ekind (Id, Ekind (T)); 5428 5429 if Present (Predicate_Function (Id)) then 5430 null; 5431 5432 elsif Present (Predicate_Function (T)) then 5433 Set_Predicate_Function (Id, Predicate_Function (T)); 5434 5435 elsif Present (Ancestor_Subtype (T)) 5436 and then Present (Predicate_Function (Ancestor_Subtype (T))) 5437 then 5438 Set_Predicate_Function (Id, 5439 Predicate_Function (Ancestor_Subtype (T))); 5440 end if; 5441 end if; 5442 end if; 5443 5444 -- Subtype of Boolean cannot have a constraint in SPARK 5445 5446 if Is_Boolean_Type (T) 5447 and then Nkind (Subtype_Indication (N)) = N_Subtype_Indication 5448 then 5449 Check_SPARK_05_Restriction 5450 ("subtype of Boolean cannot have constraint", N); 5451 end if; 5452 5453 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then 5454 declare 5455 Cstr : constant Node_Id := Constraint (Subtype_Indication (N)); 5456 One_Cstr : Node_Id; 5457 Low : Node_Id; 5458 High : Node_Id; 5459 5460 begin 5461 if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint then 5462 One_Cstr := First (Constraints (Cstr)); 5463 while Present (One_Cstr) loop 5464 5465 -- Index or discriminant constraint in SPARK must be a 5466 -- subtype mark. 5467 5468 if not 5469 Nkind_In (One_Cstr, N_Identifier, N_Expanded_Name) 5470 then 5471 Check_SPARK_05_Restriction 5472 ("subtype mark required", One_Cstr); 5473 5474 -- String subtype must have a lower bound of 1 in SPARK. 5475 -- Note that we do not need to test for the nonstatic case 5476 -- here, since that was already taken care of in 5477 -- Process_Range_Expr_In_Decl. 5478 5479 elsif Base_Type (T) = Standard_String then 5480 Get_Index_Bounds (One_Cstr, Low, High); 5481 5482 if Is_OK_Static_Expression (Low) 5483 and then Expr_Value (Low) /= 1 5484 then 5485 Check_SPARK_05_Restriction 5486 ("String subtype must have lower bound of 1", N); 5487 end if; 5488 end if; 5489 5490 Next (One_Cstr); 5491 end loop; 5492 end if; 5493 end; 5494 end if; 5495 5496 -- In the case where there is no constraint given in the subtype 5497 -- indication, Process_Subtype just returns the Subtype_Mark, so its 5498 -- semantic attributes must be established here. 5499 5500 if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then 5501 Set_Etype (Id, Base_Type (T)); 5502 5503 -- Subtype of unconstrained array without constraint is not allowed 5504 -- in SPARK. 5505 5506 if Is_Array_Type (T) and then not Is_Constrained (T) then 5507 Check_SPARK_05_Restriction 5508 ("subtype of unconstrained array must have constraint", N); 5509 end if; 5510 5511 case Ekind (T) is 5512 when Array_Kind => 5513 Set_Ekind (Id, E_Array_Subtype); 5514 Copy_Array_Subtype_Attributes (Id, T); 5515 5516 when Decimal_Fixed_Point_Kind => 5517 Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype); 5518 Set_Digits_Value (Id, Digits_Value (T)); 5519 Set_Delta_Value (Id, Delta_Value (T)); 5520 Set_Scale_Value (Id, Scale_Value (T)); 5521 Set_Small_Value (Id, Small_Value (T)); 5522 Set_Scalar_Range (Id, Scalar_Range (T)); 5523 Set_Machine_Radix_10 (Id, Machine_Radix_10 (T)); 5524 Set_Is_Constrained (Id, Is_Constrained (T)); 5525 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5526 Set_RM_Size (Id, RM_Size (T)); 5527 5528 when Enumeration_Kind => 5529 Set_Ekind (Id, E_Enumeration_Subtype); 5530 Set_First_Literal (Id, First_Literal (Base_Type (T))); 5531 Set_Scalar_Range (Id, Scalar_Range (T)); 5532 Set_Is_Character_Type (Id, Is_Character_Type (T)); 5533 Set_Is_Constrained (Id, Is_Constrained (T)); 5534 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5535 Set_RM_Size (Id, RM_Size (T)); 5536 5537 when Ordinary_Fixed_Point_Kind => 5538 Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype); 5539 Set_Scalar_Range (Id, Scalar_Range (T)); 5540 Set_Small_Value (Id, Small_Value (T)); 5541 Set_Delta_Value (Id, Delta_Value (T)); 5542 Set_Is_Constrained (Id, Is_Constrained (T)); 5543 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5544 Set_RM_Size (Id, RM_Size (T)); 5545 5546 when Float_Kind => 5547 Set_Ekind (Id, E_Floating_Point_Subtype); 5548 Set_Scalar_Range (Id, Scalar_Range (T)); 5549 Set_Digits_Value (Id, Digits_Value (T)); 5550 Set_Is_Constrained (Id, Is_Constrained (T)); 5551 5552 -- If the floating point type has dimensions, these will be 5553 -- inherited subsequently when Analyze_Dimensions is called. 5554 5555 when Signed_Integer_Kind => 5556 Set_Ekind (Id, E_Signed_Integer_Subtype); 5557 Set_Scalar_Range (Id, Scalar_Range (T)); 5558 Set_Is_Constrained (Id, Is_Constrained (T)); 5559 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5560 Set_RM_Size (Id, RM_Size (T)); 5561 5562 when Modular_Integer_Kind => 5563 Set_Ekind (Id, E_Modular_Integer_Subtype); 5564 Set_Scalar_Range (Id, Scalar_Range (T)); 5565 Set_Is_Constrained (Id, Is_Constrained (T)); 5566 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5567 Set_RM_Size (Id, RM_Size (T)); 5568 5569 when Class_Wide_Kind => 5570 Set_Ekind (Id, E_Class_Wide_Subtype); 5571 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 5572 Set_Cloned_Subtype (Id, T); 5573 Set_Is_Tagged_Type (Id, True); 5574 Set_Has_Unknown_Discriminants 5575 (Id, True); 5576 Set_No_Tagged_Streams_Pragma 5577 (Id, No_Tagged_Streams_Pragma (T)); 5578 5579 if Ekind (T) = E_Class_Wide_Subtype then 5580 Set_Equivalent_Type (Id, Equivalent_Type (T)); 5581 end if; 5582 5583 when E_Record_Subtype 5584 | E_Record_Type 5585 => 5586 Set_Ekind (Id, E_Record_Subtype); 5587 5588 -- Subtype declarations introduced for formal type parameters 5589 -- in generic instantiations should inherit the Size value of 5590 -- the type they rename. 5591 5592 if Present (Generic_Parent_Type (N)) then 5593 Set_RM_Size (Id, RM_Size (T)); 5594 end if; 5595 5596 if Ekind (T) = E_Record_Subtype 5597 and then Present (Cloned_Subtype (T)) 5598 then 5599 Set_Cloned_Subtype (Id, Cloned_Subtype (T)); 5600 else 5601 Set_Cloned_Subtype (Id, T); 5602 end if; 5603 5604 Set_First_Entity (Id, First_Entity (T)); 5605 Set_Last_Entity (Id, Last_Entity (T)); 5606 Set_Has_Discriminants (Id, Has_Discriminants (T)); 5607 Set_Is_Constrained (Id, Is_Constrained (T)); 5608 Set_Is_Limited_Record (Id, Is_Limited_Record (T)); 5609 Set_Has_Implicit_Dereference 5610 (Id, Has_Implicit_Dereference (T)); 5611 Set_Has_Unknown_Discriminants 5612 (Id, Has_Unknown_Discriminants (T)); 5613 5614 if Has_Discriminants (T) then 5615 Set_Discriminant_Constraint 5616 (Id, Discriminant_Constraint (T)); 5617 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 5618 5619 elsif Has_Unknown_Discriminants (Id) then 5620 Set_Discriminant_Constraint (Id, No_Elist); 5621 end if; 5622 5623 if Is_Tagged_Type (T) then 5624 Set_Is_Tagged_Type (Id, True); 5625 Set_No_Tagged_Streams_Pragma 5626 (Id, No_Tagged_Streams_Pragma (T)); 5627 Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); 5628 Set_Direct_Primitive_Operations 5629 (Id, Direct_Primitive_Operations (T)); 5630 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 5631 5632 if Is_Interface (T) then 5633 Set_Is_Interface (Id); 5634 Set_Is_Limited_Interface (Id, Is_Limited_Interface (T)); 5635 end if; 5636 end if; 5637 5638 when Private_Kind => 5639 Set_Ekind (Id, Subtype_Kind (Ekind (T))); 5640 Set_Has_Discriminants (Id, Has_Discriminants (T)); 5641 Set_Is_Constrained (Id, Is_Constrained (T)); 5642 Set_First_Entity (Id, First_Entity (T)); 5643 Set_Last_Entity (Id, Last_Entity (T)); 5644 Set_Private_Dependents (Id, New_Elmt_List); 5645 Set_Is_Limited_Record (Id, Is_Limited_Record (T)); 5646 Set_Has_Implicit_Dereference 5647 (Id, Has_Implicit_Dereference (T)); 5648 Set_Has_Unknown_Discriminants 5649 (Id, Has_Unknown_Discriminants (T)); 5650 Set_Known_To_Have_Preelab_Init 5651 (Id, Known_To_Have_Preelab_Init (T)); 5652 5653 if Is_Tagged_Type (T) then 5654 Set_Is_Tagged_Type (Id); 5655 Set_No_Tagged_Streams_Pragma (Id, 5656 No_Tagged_Streams_Pragma (T)); 5657 Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); 5658 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 5659 Set_Direct_Primitive_Operations (Id, 5660 Direct_Primitive_Operations (T)); 5661 end if; 5662 5663 -- In general the attributes of the subtype of a private type 5664 -- are the attributes of the partial view of parent. However, 5665 -- the full view may be a discriminated type, and the subtype 5666 -- must share the discriminant constraint to generate correct 5667 -- calls to initialization procedures. 5668 5669 if Has_Discriminants (T) then 5670 Set_Discriminant_Constraint 5671 (Id, Discriminant_Constraint (T)); 5672 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 5673 5674 elsif Present (Full_View (T)) 5675 and then Has_Discriminants (Full_View (T)) 5676 then 5677 Set_Discriminant_Constraint 5678 (Id, Discriminant_Constraint (Full_View (T))); 5679 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 5680 5681 -- This would seem semantically correct, but apparently 5682 -- generates spurious errors about missing components ??? 5683 5684 -- Set_Has_Discriminants (Id); 5685 end if; 5686 5687 Prepare_Private_Subtype_Completion (Id, N); 5688 5689 -- If this is the subtype of a constrained private type with 5690 -- discriminants that has got a full view and we also have 5691 -- built a completion just above, show that the completion 5692 -- is a clone of the full view to the back-end. 5693 5694 if Has_Discriminants (T) 5695 and then not Has_Unknown_Discriminants (T) 5696 and then not Is_Empty_Elmt_List (Discriminant_Constraint (T)) 5697 and then Present (Full_View (T)) 5698 and then Present (Full_View (Id)) 5699 then 5700 Set_Cloned_Subtype (Full_View (Id), Full_View (T)); 5701 end if; 5702 5703 when Access_Kind => 5704 Set_Ekind (Id, E_Access_Subtype); 5705 Set_Is_Constrained (Id, Is_Constrained (T)); 5706 Set_Is_Access_Constant 5707 (Id, Is_Access_Constant (T)); 5708 Set_Directly_Designated_Type 5709 (Id, Designated_Type (T)); 5710 Set_Can_Never_Be_Null (Id, Can_Never_Be_Null (T)); 5711 5712 -- A Pure library_item must not contain the declaration of a 5713 -- named access type, except within a subprogram, generic 5714 -- subprogram, task unit, or protected unit, or if it has 5715 -- a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)). 5716 5717 if Comes_From_Source (Id) 5718 and then In_Pure_Unit 5719 and then not In_Subprogram_Task_Protected_Unit 5720 and then not No_Pool_Assigned (Id) 5721 then 5722 Error_Msg_N 5723 ("named access types not allowed in pure unit", N); 5724 end if; 5725 5726 when Concurrent_Kind => 5727 Set_Ekind (Id, Subtype_Kind (Ekind (T))); 5728 Set_Corresponding_Record_Type (Id, 5729 Corresponding_Record_Type (T)); 5730 Set_First_Entity (Id, First_Entity (T)); 5731 Set_First_Private_Entity (Id, First_Private_Entity (T)); 5732 Set_Has_Discriminants (Id, Has_Discriminants (T)); 5733 Set_Is_Constrained (Id, Is_Constrained (T)); 5734 Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); 5735 Set_Last_Entity (Id, Last_Entity (T)); 5736 5737 if Is_Tagged_Type (T) then 5738 Set_No_Tagged_Streams_Pragma 5739 (Id, No_Tagged_Streams_Pragma (T)); 5740 end if; 5741 5742 if Has_Discriminants (T) then 5743 Set_Discriminant_Constraint 5744 (Id, Discriminant_Constraint (T)); 5745 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 5746 end if; 5747 5748 when Incomplete_Kind => 5749 if Ada_Version >= Ada_2005 then 5750 5751 -- In Ada 2005 an incomplete type can be explicitly tagged: 5752 -- propagate indication. Note that we also have to include 5753 -- subtypes for Ada 2012 extended use of incomplete types. 5754 5755 Set_Ekind (Id, E_Incomplete_Subtype); 5756 Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); 5757 Set_Private_Dependents (Id, New_Elmt_List); 5758 5759 if Is_Tagged_Type (Id) then 5760 Set_No_Tagged_Streams_Pragma 5761 (Id, No_Tagged_Streams_Pragma (T)); 5762 Set_Direct_Primitive_Operations (Id, New_Elmt_List); 5763 end if; 5764 5765 -- Ada 2005 (AI-412): Decorate an incomplete subtype of an 5766 -- incomplete type visible through a limited with clause. 5767 5768 if From_Limited_With (T) 5769 and then Present (Non_Limited_View (T)) 5770 then 5771 Set_From_Limited_With (Id); 5772 Set_Non_Limited_View (Id, Non_Limited_View (T)); 5773 5774 -- Ada 2005 (AI-412): Add the regular incomplete subtype 5775 -- to the private dependents of the original incomplete 5776 -- type for future transformation. 5777 5778 else 5779 Append_Elmt (Id, Private_Dependents (T)); 5780 end if; 5781 5782 -- If the subtype name denotes an incomplete type an error 5783 -- was already reported by Process_Subtype. 5784 5785 else 5786 Set_Etype (Id, Any_Type); 5787 end if; 5788 5789 when others => 5790 raise Program_Error; 5791 end case; 5792 5793 -- If there is no constraint in the subtype indication, the 5794 -- declared entity inherits predicates from the parent. 5795 5796 Inherit_Predicate_Flags (Id, T); 5797 end if; 5798 5799 if Etype (Id) = Any_Type then 5800 goto Leave; 5801 end if; 5802 5803 -- Some common processing on all types 5804 5805 Set_Size_Info (Id, T); 5806 Set_First_Rep_Item (Id, First_Rep_Item (T)); 5807 5808 -- If the parent type is a generic actual, so is the subtype. This may 5809 -- happen in a nested instance. Why Comes_From_Source test??? 5810 5811 if not Comes_From_Source (N) then 5812 Set_Is_Generic_Actual_Type (Id, Is_Generic_Actual_Type (T)); 5813 end if; 5814 5815 -- If this is a subtype declaration for an actual in an instance, 5816 -- inherit static and dynamic predicates if any. 5817 5818 -- If declaration has no aspect specifications, inherit predicate 5819 -- info as well. Unclear how to handle the case of both specified 5820 -- and inherited predicates ??? Other inherited aspects, such as 5821 -- invariants, should be OK, but the combination with later pragmas 5822 -- may also require special merging. 5823 5824 if Has_Predicates (T) 5825 and then Present (Predicate_Function (T)) 5826 and then 5827 ((In_Instance and then not Comes_From_Source (N)) 5828 or else No (Aspect_Specifications (N))) 5829 then 5830 Set_Subprograms_For_Type (Id, Subprograms_For_Type (T)); 5831 5832 if Has_Static_Predicate (T) then 5833 Set_Has_Static_Predicate (Id); 5834 Set_Static_Discrete_Predicate (Id, Static_Discrete_Predicate (T)); 5835 end if; 5836 end if; 5837 5838 -- Remaining processing depends on characteristics of base type 5839 5840 T := Etype (Id); 5841 5842 Set_Is_Immediately_Visible (Id, True); 5843 Set_Depends_On_Private (Id, Has_Private_Component (T)); 5844 Set_Is_Descendant_Of_Address (Id, Is_Descendant_Of_Address (T)); 5845 5846 if Is_Interface (T) then 5847 Set_Is_Interface (Id); 5848 end if; 5849 5850 if Present (Generic_Parent_Type (N)) 5851 and then 5852 (Nkind (Parent (Generic_Parent_Type (N))) /= 5853 N_Formal_Type_Declaration 5854 or else Nkind (Formal_Type_Definition 5855 (Parent (Generic_Parent_Type (N)))) /= 5856 N_Formal_Private_Type_Definition) 5857 then 5858 if Is_Tagged_Type (Id) then 5859 5860 -- If this is a generic actual subtype for a synchronized type, 5861 -- the primitive operations are those of the corresponding record 5862 -- for which there is a separate subtype declaration. 5863 5864 if Is_Concurrent_Type (Id) then 5865 null; 5866 elsif Is_Class_Wide_Type (Id) then 5867 Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T)); 5868 else 5869 Derive_Subprograms (Generic_Parent_Type (N), Id, T); 5870 end if; 5871 5872 elsif Scope (Etype (Id)) /= Standard_Standard then 5873 Derive_Subprograms (Generic_Parent_Type (N), Id); 5874 end if; 5875 end if; 5876 5877 if Is_Private_Type (T) and then Present (Full_View (T)) then 5878 Conditional_Delay (Id, Full_View (T)); 5879 5880 -- The subtypes of components or subcomponents of protected types 5881 -- do not need freeze nodes, which would otherwise appear in the 5882 -- wrong scope (before the freeze node for the protected type). The 5883 -- proper subtypes are those of the subcomponents of the corresponding 5884 -- record. 5885 5886 elsif Ekind (Scope (Id)) /= E_Protected_Type 5887 and then Present (Scope (Scope (Id))) -- error defense 5888 and then Ekind (Scope (Scope (Id))) /= E_Protected_Type 5889 then 5890 Conditional_Delay (Id, T); 5891 end if; 5892 5893 -- If we have a subtype of an incomplete type whose full type is a 5894 -- derived numeric type, we need to have a freeze node for the subtype. 5895 -- Otherwise gigi will complain while computing the (static) bounds of 5896 -- the subtype. 5897 5898 if Is_Itype (T) 5899 and then Is_Elementary_Type (Id) 5900 and then Etype (Id) /= Id 5901 then 5902 declare 5903 Partial : constant Entity_Id := 5904 Incomplete_Or_Partial_View (First_Subtype (Id)); 5905 begin 5906 if Present (Partial) 5907 and then Ekind (Partial) = E_Incomplete_Type 5908 then 5909 Set_Has_Delayed_Freeze (Id); 5910 end if; 5911 end; 5912 end if; 5913 5914 -- Check that Constraint_Error is raised for a scalar subtype indication 5915 -- when the lower or upper bound of a non-null range lies outside the 5916 -- range of the type mark. 5917 5918 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then 5919 if Is_Scalar_Type (Etype (Id)) 5920 and then Scalar_Range (Id) /= 5921 Scalar_Range 5922 (Etype (Subtype_Mark (Subtype_Indication (N)))) 5923 then 5924 Apply_Range_Check 5925 (Scalar_Range (Id), 5926 Etype (Subtype_Mark (Subtype_Indication (N)))); 5927 5928 -- In the array case, check compatibility for each index 5929 5930 elsif Is_Array_Type (Etype (Id)) and then Present (First_Index (Id)) 5931 then 5932 -- This really should be a subprogram that finds the indications 5933 -- to check??? 5934 5935 declare 5936 Subt_Index : Node_Id := First_Index (Id); 5937 Target_Index : Node_Id := 5938 First_Index (Etype 5939 (Subtype_Mark (Subtype_Indication (N)))); 5940 Has_Dyn_Chk : Boolean := Has_Dynamic_Range_Check (N); 5941 5942 begin 5943 while Present (Subt_Index) loop 5944 if ((Nkind (Subt_Index) = N_Identifier 5945 and then Ekind (Entity (Subt_Index)) in Scalar_Kind) 5946 or else Nkind (Subt_Index) = N_Subtype_Indication) 5947 and then 5948 Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range 5949 then 5950 declare 5951 Target_Typ : constant Entity_Id := 5952 Etype (Target_Index); 5953 begin 5954 R_Checks := 5955 Get_Range_Checks 5956 (Scalar_Range (Etype (Subt_Index)), 5957 Target_Typ, 5958 Etype (Subt_Index), 5959 Defining_Identifier (N)); 5960 5961 -- Reset Has_Dynamic_Range_Check on the subtype to 5962 -- prevent elision of the index check due to a dynamic 5963 -- check generated for a preceding index (needed since 5964 -- Insert_Range_Checks tries to avoid generating 5965 -- redundant checks on a given declaration). 5966 5967 Set_Has_Dynamic_Range_Check (N, False); 5968 5969 Insert_Range_Checks 5970 (R_Checks, 5971 N, 5972 Target_Typ, 5973 Sloc (Defining_Identifier (N))); 5974 5975 -- Record whether this index involved a dynamic check 5976 5977 Has_Dyn_Chk := 5978 Has_Dyn_Chk or else Has_Dynamic_Range_Check (N); 5979 end; 5980 end if; 5981 5982 Next_Index (Subt_Index); 5983 Next_Index (Target_Index); 5984 end loop; 5985 5986 -- Finally, mark whether the subtype involves dynamic checks 5987 5988 Set_Has_Dynamic_Range_Check (N, Has_Dyn_Chk); 5989 end; 5990 end if; 5991 end if; 5992 5993 Set_Optimize_Alignment_Flags (Id); 5994 Check_Eliminated (Id); 5995 5996 <<Leave>> 5997 if Has_Aspects (N) then 5998 Analyze_Aspect_Specifications (N, Id); 5999 end if; 6000 6001 Analyze_Dimension (N); 6002 6003 -- Check No_Dynamic_Sized_Objects restriction, which disallows subtype 6004 -- indications on composite types where the constraints are dynamic. 6005 -- Note that object declarations and aggregates generate implicit 6006 -- subtype declarations, which this covers. One special case is that the 6007 -- implicitly generated "=" for discriminated types includes an 6008 -- offending subtype declaration, which is harmless, so we ignore it 6009 -- here. 6010 6011 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then 6012 declare 6013 Cstr : constant Node_Id := Constraint (Subtype_Indication (N)); 6014 begin 6015 if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint 6016 and then not (Is_Internal (Id) 6017 and then Is_TSS (Scope (Id), 6018 TSS_Composite_Equality)) 6019 and then not Within_Init_Proc 6020 and then not All_Composite_Constraints_Static (Cstr) 6021 then 6022 Check_Restriction (No_Dynamic_Sized_Objects, Cstr); 6023 end if; 6024 end; 6025 end if; 6026 end Analyze_Subtype_Declaration; 6027 6028 -------------------------------- 6029 -- Analyze_Subtype_Indication -- 6030 -------------------------------- 6031 6032 procedure Analyze_Subtype_Indication (N : Node_Id) is 6033 T : constant Entity_Id := Subtype_Mark (N); 6034 R : constant Node_Id := Range_Expression (Constraint (N)); 6035 6036 begin 6037 Analyze (T); 6038 6039 if R /= Error then 6040 Analyze (R); 6041 Set_Etype (N, Etype (R)); 6042 Resolve (R, Entity (T)); 6043 else 6044 Set_Error_Posted (R); 6045 Set_Error_Posted (T); 6046 end if; 6047 end Analyze_Subtype_Indication; 6048 6049 -------------------------- 6050 -- Analyze_Variant_Part -- 6051 -------------------------- 6052 6053 procedure Analyze_Variant_Part (N : Node_Id) is 6054 Discr_Name : Node_Id; 6055 Discr_Type : Entity_Id; 6056 6057 procedure Process_Variant (A : Node_Id); 6058 -- Analyze declarations for a single variant 6059 6060 package Analyze_Variant_Choices is 6061 new Generic_Analyze_Choices (Process_Variant); 6062 use Analyze_Variant_Choices; 6063 6064 --------------------- 6065 -- Process_Variant -- 6066 --------------------- 6067 6068 procedure Process_Variant (A : Node_Id) is 6069 CL : constant Node_Id := Component_List (A); 6070 begin 6071 if not Null_Present (CL) then 6072 Analyze_Declarations (Component_Items (CL)); 6073 6074 if Present (Variant_Part (CL)) then 6075 Analyze (Variant_Part (CL)); 6076 end if; 6077 end if; 6078 end Process_Variant; 6079 6080 -- Start of processing for Analyze_Variant_Part 6081 6082 begin 6083 Discr_Name := Name (N); 6084 Analyze (Discr_Name); 6085 6086 -- If Discr_Name bad, get out (prevent cascaded errors) 6087 6088 if Etype (Discr_Name) = Any_Type then 6089 return; 6090 end if; 6091 6092 -- Check invalid discriminant in variant part 6093 6094 if Ekind (Entity (Discr_Name)) /= E_Discriminant then 6095 Error_Msg_N ("invalid discriminant name in variant part", Discr_Name); 6096 end if; 6097 6098 Discr_Type := Etype (Entity (Discr_Name)); 6099 6100 if not Is_Discrete_Type (Discr_Type) then 6101 Error_Msg_N 6102 ("discriminant in a variant part must be of a discrete type", 6103 Name (N)); 6104 return; 6105 end if; 6106 6107 -- Now analyze the choices, which also analyzes the declarations that 6108 -- are associated with each choice. 6109 6110 Analyze_Choices (Variants (N), Discr_Type); 6111 6112 -- Note: we used to instantiate and call Check_Choices here to check 6113 -- that the choices covered the discriminant, but it's too early to do 6114 -- that because of statically predicated subtypes, whose analysis may 6115 -- be deferred to their freeze point which may be as late as the freeze 6116 -- point of the containing record. So this call is now to be found in 6117 -- Freeze_Record_Declaration. 6118 6119 end Analyze_Variant_Part; 6120 6121 ---------------------------- 6122 -- Array_Type_Declaration -- 6123 ---------------------------- 6124 6125 procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is 6126 Component_Def : constant Node_Id := Component_Definition (Def); 6127 Component_Typ : constant Node_Id := Subtype_Indication (Component_Def); 6128 P : constant Node_Id := Parent (Def); 6129 Element_Type : Entity_Id; 6130 Implicit_Base : Entity_Id; 6131 Index : Node_Id; 6132 Nb_Index : Nat; 6133 Priv : Entity_Id; 6134 Related_Id : Entity_Id := Empty; 6135 6136 begin 6137 if Nkind (Def) = N_Constrained_Array_Definition then 6138 Index := First (Discrete_Subtype_Definitions (Def)); 6139 else 6140 Index := First (Subtype_Marks (Def)); 6141 end if; 6142 6143 -- Find proper names for the implicit types which may be public. In case 6144 -- of anonymous arrays we use the name of the first object of that type 6145 -- as prefix. 6146 6147 if No (T) then 6148 Related_Id := Defining_Identifier (P); 6149 else 6150 Related_Id := T; 6151 end if; 6152 6153 Nb_Index := 1; 6154 while Present (Index) loop 6155 Analyze (Index); 6156 6157 -- Test for odd case of trying to index a type by the type itself 6158 6159 if Is_Entity_Name (Index) and then Entity (Index) = T then 6160 Error_Msg_N ("type& cannot be indexed by itself", Index); 6161 Set_Entity (Index, Standard_Boolean); 6162 Set_Etype (Index, Standard_Boolean); 6163 end if; 6164 6165 -- Check SPARK restriction requiring a subtype mark 6166 6167 if not Nkind_In (Index, N_Identifier, N_Expanded_Name) then 6168 Check_SPARK_05_Restriction ("subtype mark required", Index); 6169 end if; 6170 6171 -- Add a subtype declaration for each index of private array type 6172 -- declaration whose etype is also private. For example: 6173 6174 -- package Pkg is 6175 -- type Index is private; 6176 -- private 6177 -- type Table is array (Index) of ... 6178 -- end; 6179 6180 -- This is currently required by the expander for the internally 6181 -- generated equality subprogram of records with variant parts in 6182 -- which the etype of some component is such private type. 6183 6184 if Ekind (Current_Scope) = E_Package 6185 and then In_Private_Part (Current_Scope) 6186 and then Has_Private_Declaration (Etype (Index)) 6187 then 6188 declare 6189 Loc : constant Source_Ptr := Sloc (Def); 6190 Decl : Entity_Id; 6191 New_E : Entity_Id; 6192 6193 begin 6194 New_E := Make_Temporary (Loc, 'T'); 6195 Set_Is_Internal (New_E); 6196 6197 Decl := 6198 Make_Subtype_Declaration (Loc, 6199 Defining_Identifier => New_E, 6200 Subtype_Indication => 6201 New_Occurrence_Of (Etype (Index), Loc)); 6202 6203 Insert_Before (Parent (Def), Decl); 6204 Analyze (Decl); 6205 Set_Etype (Index, New_E); 6206 6207 -- If the index is a range or a subtype indication it carries 6208 -- no entity. Example: 6209 6210 -- package Pkg is 6211 -- type T is private; 6212 -- private 6213 -- type T is new Natural; 6214 -- Table : array (T(1) .. T(10)) of Boolean; 6215 -- end Pkg; 6216 6217 -- Otherwise the type of the reference is its entity. 6218 6219 if Is_Entity_Name (Index) then 6220 Set_Entity (Index, New_E); 6221 end if; 6222 end; 6223 end if; 6224 6225 Make_Index (Index, P, Related_Id, Nb_Index); 6226 6227 -- Check error of subtype with predicate for index type 6228 6229 Bad_Predicated_Subtype_Use 6230 ("subtype& has predicate, not allowed as index subtype", 6231 Index, Etype (Index)); 6232 6233 -- Move to next index 6234 6235 Next_Index (Index); 6236 Nb_Index := Nb_Index + 1; 6237 end loop; 6238 6239 -- Process subtype indication if one is present 6240 6241 if Present (Component_Typ) then 6242 Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C'); 6243 6244 Set_Etype (Component_Typ, Element_Type); 6245 6246 if not Nkind_In (Component_Typ, N_Identifier, N_Expanded_Name) then 6247 Check_SPARK_05_Restriction 6248 ("subtype mark required", Component_Typ); 6249 end if; 6250 6251 -- Ada 2005 (AI-230): Access Definition case 6252 6253 else pragma Assert (Present (Access_Definition (Component_Def))); 6254 6255 -- Indicate that the anonymous access type is created by the 6256 -- array type declaration. 6257 6258 Element_Type := Access_Definition 6259 (Related_Nod => P, 6260 N => Access_Definition (Component_Def)); 6261 Set_Is_Local_Anonymous_Access (Element_Type); 6262 6263 -- Propagate the parent. This field is needed if we have to generate 6264 -- the master_id associated with an anonymous access to task type 6265 -- component (see Expand_N_Full_Type_Declaration.Build_Master) 6266 6267 Set_Parent (Element_Type, Parent (T)); 6268 6269 -- Ada 2005 (AI-230): In case of components that are anonymous access 6270 -- types the level of accessibility depends on the enclosing type 6271 -- declaration 6272 6273 Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230) 6274 6275 -- Ada 2005 (AI-254) 6276 6277 declare 6278 CD : constant Node_Id := 6279 Access_To_Subprogram_Definition 6280 (Access_Definition (Component_Def)); 6281 begin 6282 if Present (CD) and then Protected_Present (CD) then 6283 Element_Type := 6284 Replace_Anonymous_Access_To_Protected_Subprogram (Def); 6285 end if; 6286 end; 6287 end if; 6288 6289 -- Constrained array case 6290 6291 if No (T) then 6292 T := Create_Itype (E_Void, P, Related_Id, 'T'); 6293 end if; 6294 6295 if Nkind (Def) = N_Constrained_Array_Definition then 6296 6297 -- Establish Implicit_Base as unconstrained base type 6298 6299 Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B'); 6300 6301 Set_Etype (Implicit_Base, Implicit_Base); 6302 Set_Scope (Implicit_Base, Current_Scope); 6303 Set_Has_Delayed_Freeze (Implicit_Base); 6304 Set_Default_SSO (Implicit_Base); 6305 6306 -- The constrained array type is a subtype of the unconstrained one 6307 6308 Set_Ekind (T, E_Array_Subtype); 6309 Init_Size_Align (T); 6310 Set_Etype (T, Implicit_Base); 6311 Set_Scope (T, Current_Scope); 6312 Set_Is_Constrained (T); 6313 Set_First_Index (T, 6314 First (Discrete_Subtype_Definitions (Def))); 6315 Set_Has_Delayed_Freeze (T); 6316 6317 -- Complete setup of implicit base type 6318 6319 Set_Component_Size (Implicit_Base, Uint_0); 6320 Set_Component_Type (Implicit_Base, Element_Type); 6321 Set_Finalize_Storage_Only 6322 (Implicit_Base, 6323 Finalize_Storage_Only (Element_Type)); 6324 Set_First_Index (Implicit_Base, First_Index (T)); 6325 Set_Has_Controlled_Component 6326 (Implicit_Base, 6327 Has_Controlled_Component (Element_Type) 6328 or else Is_Controlled (Element_Type)); 6329 Set_Packed_Array_Impl_Type 6330 (Implicit_Base, Empty); 6331 6332 Propagate_Concurrent_Flags (Implicit_Base, Element_Type); 6333 6334 -- Unconstrained array case 6335 6336 else 6337 Set_Ekind (T, E_Array_Type); 6338 Init_Size_Align (T); 6339 Set_Etype (T, T); 6340 Set_Scope (T, Current_Scope); 6341 Set_Component_Size (T, Uint_0); 6342 Set_Is_Constrained (T, False); 6343 Set_First_Index (T, First (Subtype_Marks (Def))); 6344 Set_Has_Delayed_Freeze (T, True); 6345 Propagate_Concurrent_Flags (T, Element_Type); 6346 Set_Has_Controlled_Component (T, Has_Controlled_Component 6347 (Element_Type) 6348 or else 6349 Is_Controlled (Element_Type)); 6350 Set_Finalize_Storage_Only (T, Finalize_Storage_Only 6351 (Element_Type)); 6352 Set_Default_SSO (T); 6353 end if; 6354 6355 -- Common attributes for both cases 6356 6357 Set_Component_Type (Base_Type (T), Element_Type); 6358 Set_Packed_Array_Impl_Type (T, Empty); 6359 6360 if Aliased_Present (Component_Definition (Def)) then 6361 Check_SPARK_05_Restriction 6362 ("aliased is not allowed", Component_Definition (Def)); 6363 Set_Has_Aliased_Components (Etype (T)); 6364 6365 -- AI12-001: All aliased objects are considered to be specified as 6366 -- independently addressable (RM C.6(8.1/4)). 6367 6368 Set_Has_Independent_Components (Etype (T)); 6369 end if; 6370 6371 -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the 6372 -- array type to ensure that objects of this type are initialized. 6373 6374 if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (Element_Type) then 6375 Set_Can_Never_Be_Null (T); 6376 6377 if Null_Exclusion_Present (Component_Definition (Def)) 6378 6379 -- No need to check itypes because in their case this check was 6380 -- done at their point of creation 6381 6382 and then not Is_Itype (Element_Type) 6383 then 6384 Error_Msg_N 6385 ("`NOT NULL` not allowed (null already excluded)", 6386 Subtype_Indication (Component_Definition (Def))); 6387 end if; 6388 end if; 6389 6390 Priv := Private_Component (Element_Type); 6391 6392 if Present (Priv) then 6393 6394 -- Check for circular definitions 6395 6396 if Priv = Any_Type then 6397 Set_Component_Type (Etype (T), Any_Type); 6398 6399 -- There is a gap in the visibility of operations on the composite 6400 -- type only if the component type is defined in a different scope. 6401 6402 elsif Scope (Priv) = Current_Scope then 6403 null; 6404 6405 elsif Is_Limited_Type (Priv) then 6406 Set_Is_Limited_Composite (Etype (T)); 6407 Set_Is_Limited_Composite (T); 6408 else 6409 Set_Is_Private_Composite (Etype (T)); 6410 Set_Is_Private_Composite (T); 6411 end if; 6412 end if; 6413 6414 -- A syntax error in the declaration itself may lead to an empty index 6415 -- list, in which case do a minimal patch. 6416 6417 if No (First_Index (T)) then 6418 Error_Msg_N ("missing index definition in array type declaration", T); 6419 6420 declare 6421 Indexes : constant List_Id := 6422 New_List (New_Occurrence_Of (Any_Id, Sloc (T))); 6423 begin 6424 Set_Discrete_Subtype_Definitions (Def, Indexes); 6425 Set_First_Index (T, First (Indexes)); 6426 return; 6427 end; 6428 end if; 6429 6430 -- Create a concatenation operator for the new type. Internal array 6431 -- types created for packed entities do not need such, they are 6432 -- compatible with the user-defined type. 6433 6434 if Number_Dimensions (T) = 1 6435 and then not Is_Packed_Array_Impl_Type (T) 6436 then 6437 New_Concatenation_Op (T); 6438 end if; 6439 6440 -- In the case of an unconstrained array the parser has already verified 6441 -- that all the indexes are unconstrained but we still need to make sure 6442 -- that the element type is constrained. 6443 6444 if not Is_Definite_Subtype (Element_Type) then 6445 Error_Msg_N 6446 ("unconstrained element type in array declaration", 6447 Subtype_Indication (Component_Def)); 6448 6449 elsif Is_Abstract_Type (Element_Type) then 6450 Error_Msg_N 6451 ("the type of a component cannot be abstract", 6452 Subtype_Indication (Component_Def)); 6453 end if; 6454 6455 -- There may be an invariant declared for the component type, but 6456 -- the construction of the component invariant checking procedure 6457 -- takes place during expansion. 6458 end Array_Type_Declaration; 6459 6460 ------------------------------------------------------ 6461 -- Replace_Anonymous_Access_To_Protected_Subprogram -- 6462 ------------------------------------------------------ 6463 6464 function Replace_Anonymous_Access_To_Protected_Subprogram 6465 (N : Node_Id) return Entity_Id 6466 is 6467 Loc : constant Source_Ptr := Sloc (N); 6468 6469 Curr_Scope : constant Scope_Stack_Entry := 6470 Scope_Stack.Table (Scope_Stack.Last); 6471 6472 Anon : constant Entity_Id := Make_Temporary (Loc, 'S'); 6473 6474 Acc : Node_Id; 6475 -- Access definition in declaration 6476 6477 Comp : Node_Id; 6478 -- Object definition or formal definition with an access definition 6479 6480 Decl : Node_Id; 6481 -- Declaration of anonymous access to subprogram type 6482 6483 Spec : Node_Id; 6484 -- Original specification in access to subprogram 6485 6486 P : Node_Id; 6487 6488 begin 6489 Set_Is_Internal (Anon); 6490 6491 case Nkind (N) is 6492 when N_Constrained_Array_Definition 6493 | N_Component_Declaration 6494 | N_Unconstrained_Array_Definition 6495 => 6496 Comp := Component_Definition (N); 6497 Acc := Access_Definition (Comp); 6498 6499 when N_Discriminant_Specification => 6500 Comp := Discriminant_Type (N); 6501 Acc := Comp; 6502 6503 when N_Parameter_Specification => 6504 Comp := Parameter_Type (N); 6505 Acc := Comp; 6506 6507 when N_Access_Function_Definition => 6508 Comp := Result_Definition (N); 6509 Acc := Comp; 6510 6511 when N_Object_Declaration => 6512 Comp := Object_Definition (N); 6513 Acc := Comp; 6514 6515 when N_Function_Specification => 6516 Comp := Result_Definition (N); 6517 Acc := Comp; 6518 6519 when others => 6520 raise Program_Error; 6521 end case; 6522 6523 Spec := Access_To_Subprogram_Definition (Acc); 6524 6525 Decl := 6526 Make_Full_Type_Declaration (Loc, 6527 Defining_Identifier => Anon, 6528 Type_Definition => Copy_Separate_Tree (Spec)); 6529 6530 Mark_Rewrite_Insertion (Decl); 6531 6532 -- In ASIS mode, analyze the profile on the original node, because 6533 -- the separate copy does not provide enough links to recover the 6534 -- original tree. Analysis is limited to type annotations, within 6535 -- a temporary scope that serves as an anonymous subprogram to collect 6536 -- otherwise useless temporaries and itypes. 6537 6538 if ASIS_Mode then 6539 declare 6540 Typ : constant Entity_Id := Make_Temporary (Loc, 'S'); 6541 6542 begin 6543 if Nkind (Spec) = N_Access_Function_Definition then 6544 Set_Ekind (Typ, E_Function); 6545 else 6546 Set_Ekind (Typ, E_Procedure); 6547 end if; 6548 6549 Set_Parent (Typ, N); 6550 Set_Scope (Typ, Current_Scope); 6551 Push_Scope (Typ); 6552 6553 -- Nothing to do if procedure is parameterless 6554 6555 if Present (Parameter_Specifications (Spec)) then 6556 Process_Formals (Parameter_Specifications (Spec), Spec); 6557 end if; 6558 6559 if Nkind (Spec) = N_Access_Function_Definition then 6560 declare 6561 Def : constant Node_Id := Result_Definition (Spec); 6562 6563 begin 6564 -- The result might itself be an anonymous access type, so 6565 -- have to recurse. 6566 6567 if Nkind (Def) = N_Access_Definition then 6568 if Present (Access_To_Subprogram_Definition (Def)) then 6569 Set_Etype 6570 (Def, 6571 Replace_Anonymous_Access_To_Protected_Subprogram 6572 (Spec)); 6573 else 6574 Find_Type (Subtype_Mark (Def)); 6575 end if; 6576 6577 else 6578 Find_Type (Def); 6579 end if; 6580 end; 6581 end if; 6582 6583 End_Scope; 6584 end; 6585 end if; 6586 6587 -- Insert the new declaration in the nearest enclosing scope. If the 6588 -- parent is a body and N is its return type, the declaration belongs 6589 -- in the enclosing scope. Likewise if N is the type of a parameter. 6590 6591 P := Parent (N); 6592 6593 if Nkind (N) = N_Function_Specification 6594 and then Nkind (P) = N_Subprogram_Body 6595 then 6596 P := Parent (P); 6597 elsif Nkind (N) = N_Parameter_Specification 6598 and then Nkind (P) in N_Subprogram_Specification 6599 and then Nkind (Parent (P)) = N_Subprogram_Body 6600 then 6601 P := Parent (Parent (P)); 6602 end if; 6603 6604 while Present (P) and then not Has_Declarations (P) loop 6605 P := Parent (P); 6606 end loop; 6607 6608 pragma Assert (Present (P)); 6609 6610 if Nkind (P) = N_Package_Specification then 6611 Prepend (Decl, Visible_Declarations (P)); 6612 else 6613 Prepend (Decl, Declarations (P)); 6614 end if; 6615 6616 -- Replace the anonymous type with an occurrence of the new declaration. 6617 -- In all cases the rewritten node does not have the null-exclusion 6618 -- attribute because (if present) it was already inherited by the 6619 -- anonymous entity (Anon). Thus, in case of components we do not 6620 -- inherit this attribute. 6621 6622 if Nkind (N) = N_Parameter_Specification then 6623 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 6624 Set_Etype (Defining_Identifier (N), Anon); 6625 Set_Null_Exclusion_Present (N, False); 6626 6627 elsif Nkind (N) = N_Object_Declaration then 6628 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 6629 Set_Etype (Defining_Identifier (N), Anon); 6630 6631 elsif Nkind (N) = N_Access_Function_Definition then 6632 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 6633 6634 elsif Nkind (N) = N_Function_Specification then 6635 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 6636 Set_Etype (Defining_Unit_Name (N), Anon); 6637 6638 else 6639 Rewrite (Comp, 6640 Make_Component_Definition (Loc, 6641 Subtype_Indication => New_Occurrence_Of (Anon, Loc))); 6642 end if; 6643 6644 Mark_Rewrite_Insertion (Comp); 6645 6646 if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) 6647 or else (Nkind (Parent (N)) = N_Full_Type_Declaration 6648 and then not Is_Type (Current_Scope)) 6649 then 6650 6651 -- Declaration can be analyzed in the current scope. 6652 6653 Analyze (Decl); 6654 6655 else 6656 -- Temporarily remove the current scope (record or subprogram) from 6657 -- the stack to add the new declarations to the enclosing scope. 6658 -- The anonymous entity is an Itype with the proper attributes. 6659 6660 Scope_Stack.Decrement_Last; 6661 Analyze (Decl); 6662 Set_Is_Itype (Anon); 6663 Set_Associated_Node_For_Itype (Anon, N); 6664 Scope_Stack.Append (Curr_Scope); 6665 end if; 6666 6667 Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type); 6668 Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target); 6669 return Anon; 6670 end Replace_Anonymous_Access_To_Protected_Subprogram; 6671 6672 ------------------------------- 6673 -- Build_Derived_Access_Type -- 6674 ------------------------------- 6675 6676 procedure Build_Derived_Access_Type 6677 (N : Node_Id; 6678 Parent_Type : Entity_Id; 6679 Derived_Type : Entity_Id) 6680 is 6681 S : constant Node_Id := Subtype_Indication (Type_Definition (N)); 6682 6683 Desig_Type : Entity_Id; 6684 Discr : Entity_Id; 6685 Discr_Con_Elist : Elist_Id; 6686 Discr_Con_El : Elmt_Id; 6687 Subt : Entity_Id; 6688 6689 begin 6690 -- Set the designated type so it is available in case this is an access 6691 -- to a self-referential type, e.g. a standard list type with a next 6692 -- pointer. Will be reset after subtype is built. 6693 6694 Set_Directly_Designated_Type 6695 (Derived_Type, Designated_Type (Parent_Type)); 6696 6697 Subt := Process_Subtype (S, N); 6698 6699 if Nkind (S) /= N_Subtype_Indication 6700 and then Subt /= Base_Type (Subt) 6701 then 6702 Set_Ekind (Derived_Type, E_Access_Subtype); 6703 end if; 6704 6705 if Ekind (Derived_Type) = E_Access_Subtype then 6706 declare 6707 Pbase : constant Entity_Id := Base_Type (Parent_Type); 6708 Ibase : constant Entity_Id := 6709 Create_Itype (Ekind (Pbase), N, Derived_Type, 'B'); 6710 Svg_Chars : constant Name_Id := Chars (Ibase); 6711 Svg_Next_E : constant Entity_Id := Next_Entity (Ibase); 6712 Svg_Prev_E : constant Entity_Id := Prev_Entity (Ibase); 6713 6714 begin 6715 Copy_Node (Pbase, Ibase); 6716 6717 -- Restore Itype status after Copy_Node 6718 6719 Set_Is_Itype (Ibase); 6720 Set_Associated_Node_For_Itype (Ibase, N); 6721 6722 Set_Chars (Ibase, Svg_Chars); 6723 Set_Prev_Entity (Ibase, Svg_Prev_E); 6724 Set_Next_Entity (Ibase, Svg_Next_E); 6725 Set_Sloc (Ibase, Sloc (Derived_Type)); 6726 Set_Scope (Ibase, Scope (Derived_Type)); 6727 Set_Freeze_Node (Ibase, Empty); 6728 Set_Is_Frozen (Ibase, False); 6729 Set_Comes_From_Source (Ibase, False); 6730 Set_Is_First_Subtype (Ibase, False); 6731 6732 Set_Etype (Ibase, Pbase); 6733 Set_Etype (Derived_Type, Ibase); 6734 end; 6735 end if; 6736 6737 Set_Directly_Designated_Type 6738 (Derived_Type, Designated_Type (Subt)); 6739 6740 Set_Is_Constrained (Derived_Type, Is_Constrained (Subt)); 6741 Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type)); 6742 Set_Size_Info (Derived_Type, Parent_Type); 6743 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 6744 Set_Depends_On_Private (Derived_Type, 6745 Has_Private_Component (Derived_Type)); 6746 Conditional_Delay (Derived_Type, Subt); 6747 6748 if Is_Access_Subprogram_Type (Derived_Type) then 6749 Set_Can_Use_Internal_Rep 6750 (Derived_Type, Can_Use_Internal_Rep (Parent_Type)); 6751 end if; 6752 6753 -- Ada 2005 (AI-231): Set the null-exclusion attribute, and verify 6754 -- that it is not redundant. 6755 6756 if Null_Exclusion_Present (Type_Definition (N)) then 6757 Set_Can_Never_Be_Null (Derived_Type); 6758 6759 elsif Can_Never_Be_Null (Parent_Type) then 6760 Set_Can_Never_Be_Null (Derived_Type); 6761 end if; 6762 6763 -- Note: we do not copy the Storage_Size_Variable, since we always go to 6764 -- the root type for this information. 6765 6766 -- Apply range checks to discriminants for derived record case 6767 -- ??? THIS CODE SHOULD NOT BE HERE REALLY. 6768 6769 Desig_Type := Designated_Type (Derived_Type); 6770 6771 if Is_Composite_Type (Desig_Type) 6772 and then (not Is_Array_Type (Desig_Type)) 6773 and then Has_Discriminants (Desig_Type) 6774 and then Base_Type (Desig_Type) /= Desig_Type 6775 then 6776 Discr_Con_Elist := Discriminant_Constraint (Desig_Type); 6777 Discr_Con_El := First_Elmt (Discr_Con_Elist); 6778 6779 Discr := First_Discriminant (Base_Type (Desig_Type)); 6780 while Present (Discr_Con_El) loop 6781 Apply_Range_Check (Node (Discr_Con_El), Etype (Discr)); 6782 Next_Elmt (Discr_Con_El); 6783 Next_Discriminant (Discr); 6784 end loop; 6785 end if; 6786 end Build_Derived_Access_Type; 6787 6788 ------------------------------ 6789 -- Build_Derived_Array_Type -- 6790 ------------------------------ 6791 6792 procedure Build_Derived_Array_Type 6793 (N : Node_Id; 6794 Parent_Type : Entity_Id; 6795 Derived_Type : Entity_Id) 6796 is 6797 Loc : constant Source_Ptr := Sloc (N); 6798 Tdef : constant Node_Id := Type_Definition (N); 6799 Indic : constant Node_Id := Subtype_Indication (Tdef); 6800 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 6801 Implicit_Base : Entity_Id := Empty; 6802 New_Indic : Node_Id; 6803 6804 procedure Make_Implicit_Base; 6805 -- If the parent subtype is constrained, the derived type is a subtype 6806 -- of an implicit base type derived from the parent base. 6807 6808 ------------------------ 6809 -- Make_Implicit_Base -- 6810 ------------------------ 6811 6812 procedure Make_Implicit_Base is 6813 begin 6814 Implicit_Base := 6815 Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); 6816 6817 Set_Ekind (Implicit_Base, Ekind (Parent_Base)); 6818 Set_Etype (Implicit_Base, Parent_Base); 6819 6820 Copy_Array_Subtype_Attributes (Implicit_Base, Parent_Base); 6821 Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base); 6822 6823 Set_Has_Delayed_Freeze (Implicit_Base, True); 6824 end Make_Implicit_Base; 6825 6826 -- Start of processing for Build_Derived_Array_Type 6827 6828 begin 6829 if not Is_Constrained (Parent_Type) then 6830 if Nkind (Indic) /= N_Subtype_Indication then 6831 Set_Ekind (Derived_Type, E_Array_Type); 6832 6833 Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); 6834 Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type); 6835 6836 Set_Has_Delayed_Freeze (Derived_Type, True); 6837 6838 else 6839 Make_Implicit_Base; 6840 Set_Etype (Derived_Type, Implicit_Base); 6841 6842 New_Indic := 6843 Make_Subtype_Declaration (Loc, 6844 Defining_Identifier => Derived_Type, 6845 Subtype_Indication => 6846 Make_Subtype_Indication (Loc, 6847 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc), 6848 Constraint => Constraint (Indic))); 6849 6850 Rewrite (N, New_Indic); 6851 Analyze (N); 6852 end if; 6853 6854 else 6855 if Nkind (Indic) /= N_Subtype_Indication then 6856 Make_Implicit_Base; 6857 6858 Set_Ekind (Derived_Type, Ekind (Parent_Type)); 6859 Set_Etype (Derived_Type, Implicit_Base); 6860 Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); 6861 6862 else 6863 Error_Msg_N ("illegal constraint on constrained type", Indic); 6864 end if; 6865 end if; 6866 6867 -- If parent type is not a derived type itself, and is declared in 6868 -- closed scope (e.g. a subprogram), then we must explicitly introduce 6869 -- the new type's concatenation operator since Derive_Subprograms 6870 -- will not inherit the parent's operator. If the parent type is 6871 -- unconstrained, the operator is of the unconstrained base type. 6872 6873 if Number_Dimensions (Parent_Type) = 1 6874 and then not Is_Limited_Type (Parent_Type) 6875 and then not Is_Derived_Type (Parent_Type) 6876 and then not Is_Package_Or_Generic_Package 6877 (Scope (Base_Type (Parent_Type))) 6878 then 6879 if not Is_Constrained (Parent_Type) 6880 and then Is_Constrained (Derived_Type) 6881 then 6882 New_Concatenation_Op (Implicit_Base); 6883 else 6884 New_Concatenation_Op (Derived_Type); 6885 end if; 6886 end if; 6887 end Build_Derived_Array_Type; 6888 6889 ----------------------------------- 6890 -- Build_Derived_Concurrent_Type -- 6891 ----------------------------------- 6892 6893 procedure Build_Derived_Concurrent_Type 6894 (N : Node_Id; 6895 Parent_Type : Entity_Id; 6896 Derived_Type : Entity_Id) 6897 is 6898 Loc : constant Source_Ptr := Sloc (N); 6899 Def : constant Node_Id := Type_Definition (N); 6900 Indic : constant Node_Id := Subtype_Indication (Def); 6901 6902 Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C'); 6903 Corr_Decl : Node_Id; 6904 Corr_Decl_Needed : Boolean; 6905 -- If the derived type has fewer discriminants than its parent, the 6906 -- corresponding record is also a derived type, in order to account for 6907 -- the bound discriminants. We create a full type declaration for it in 6908 -- this case. 6909 6910 Constraint_Present : constant Boolean := 6911 Nkind (Indic) = N_Subtype_Indication; 6912 6913 D_Constraint : Node_Id; 6914 New_Constraint : Elist_Id := No_Elist; 6915 Old_Disc : Entity_Id; 6916 New_Disc : Entity_Id; 6917 New_N : Node_Id; 6918 6919 begin 6920 Set_Stored_Constraint (Derived_Type, No_Elist); 6921 Corr_Decl_Needed := False; 6922 Old_Disc := Empty; 6923 6924 if Present (Discriminant_Specifications (N)) 6925 and then Constraint_Present 6926 then 6927 Old_Disc := First_Discriminant (Parent_Type); 6928 New_Disc := First (Discriminant_Specifications (N)); 6929 while Present (New_Disc) and then Present (Old_Disc) loop 6930 Next_Discriminant (Old_Disc); 6931 Next (New_Disc); 6932 end loop; 6933 end if; 6934 6935 if Present (Old_Disc) and then Expander_Active then 6936 6937 -- The new type has fewer discriminants, so we need to create a new 6938 -- corresponding record, which is derived from the corresponding 6939 -- record of the parent, and has a stored constraint that captures 6940 -- the values of the discriminant constraints. The corresponding 6941 -- record is needed only if expander is active and code generation is 6942 -- enabled. 6943 6944 -- The type declaration for the derived corresponding record has the 6945 -- same discriminant part and constraints as the current declaration. 6946 -- Copy the unanalyzed tree to build declaration. 6947 6948 Corr_Decl_Needed := True; 6949 New_N := Copy_Separate_Tree (N); 6950 6951 Corr_Decl := 6952 Make_Full_Type_Declaration (Loc, 6953 Defining_Identifier => Corr_Record, 6954 Discriminant_Specifications => 6955 Discriminant_Specifications (New_N), 6956 Type_Definition => 6957 Make_Derived_Type_Definition (Loc, 6958 Subtype_Indication => 6959 Make_Subtype_Indication (Loc, 6960 Subtype_Mark => 6961 New_Occurrence_Of 6962 (Corresponding_Record_Type (Parent_Type), Loc), 6963 Constraint => 6964 Constraint 6965 (Subtype_Indication (Type_Definition (New_N)))))); 6966 end if; 6967 6968 -- Copy Storage_Size and Relative_Deadline variables if task case 6969 6970 if Is_Task_Type (Parent_Type) then 6971 Set_Storage_Size_Variable (Derived_Type, 6972 Storage_Size_Variable (Parent_Type)); 6973 Set_Relative_Deadline_Variable (Derived_Type, 6974 Relative_Deadline_Variable (Parent_Type)); 6975 end if; 6976 6977 if Present (Discriminant_Specifications (N)) then 6978 Push_Scope (Derived_Type); 6979 Check_Or_Process_Discriminants (N, Derived_Type); 6980 6981 if Constraint_Present then 6982 New_Constraint := 6983 Expand_To_Stored_Constraint 6984 (Parent_Type, 6985 Build_Discriminant_Constraints 6986 (Parent_Type, Indic, True)); 6987 end if; 6988 6989 End_Scope; 6990 6991 elsif Constraint_Present then 6992 6993 -- Build an unconstrained derived type and rewrite the derived type 6994 -- as a subtype of this new base type. 6995 6996 declare 6997 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 6998 New_Base : Entity_Id; 6999 New_Decl : Node_Id; 7000 New_Indic : Node_Id; 7001 7002 begin 7003 New_Base := 7004 Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B'); 7005 7006 New_Decl := 7007 Make_Full_Type_Declaration (Loc, 7008 Defining_Identifier => New_Base, 7009 Type_Definition => 7010 Make_Derived_Type_Definition (Loc, 7011 Abstract_Present => Abstract_Present (Def), 7012 Limited_Present => Limited_Present (Def), 7013 Subtype_Indication => 7014 New_Occurrence_Of (Parent_Base, Loc))); 7015 7016 Mark_Rewrite_Insertion (New_Decl); 7017 Insert_Before (N, New_Decl); 7018 Analyze (New_Decl); 7019 7020 New_Indic := 7021 Make_Subtype_Indication (Loc, 7022 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 7023 Constraint => Relocate_Node (Constraint (Indic))); 7024 7025 Rewrite (N, 7026 Make_Subtype_Declaration (Loc, 7027 Defining_Identifier => Derived_Type, 7028 Subtype_Indication => New_Indic)); 7029 7030 Analyze (N); 7031 return; 7032 end; 7033 end if; 7034 7035 -- By default, operations and private data are inherited from parent. 7036 -- However, in the presence of bound discriminants, a new corresponding 7037 -- record will be created, see below. 7038 7039 Set_Has_Discriminants 7040 (Derived_Type, Has_Discriminants (Parent_Type)); 7041 Set_Corresponding_Record_Type 7042 (Derived_Type, Corresponding_Record_Type (Parent_Type)); 7043 7044 -- Is_Constrained is set according the parent subtype, but is set to 7045 -- False if the derived type is declared with new discriminants. 7046 7047 Set_Is_Constrained 7048 (Derived_Type, 7049 (Is_Constrained (Parent_Type) or else Constraint_Present) 7050 and then not Present (Discriminant_Specifications (N))); 7051 7052 if Constraint_Present then 7053 if not Has_Discriminants (Parent_Type) then 7054 Error_Msg_N ("untagged parent must have discriminants", N); 7055 7056 elsif Present (Discriminant_Specifications (N)) then 7057 7058 -- Verify that new discriminants are used to constrain old ones 7059 7060 D_Constraint := First (Constraints (Constraint (Indic))); 7061 7062 Old_Disc := First_Discriminant (Parent_Type); 7063 7064 while Present (D_Constraint) loop 7065 if Nkind (D_Constraint) /= N_Discriminant_Association then 7066 7067 -- Positional constraint. If it is a reference to a new 7068 -- discriminant, it constrains the corresponding old one. 7069 7070 if Nkind (D_Constraint) = N_Identifier then 7071 New_Disc := First_Discriminant (Derived_Type); 7072 while Present (New_Disc) loop 7073 exit when Chars (New_Disc) = Chars (D_Constraint); 7074 Next_Discriminant (New_Disc); 7075 end loop; 7076 7077 if Present (New_Disc) then 7078 Set_Corresponding_Discriminant (New_Disc, Old_Disc); 7079 end if; 7080 end if; 7081 7082 Next_Discriminant (Old_Disc); 7083 7084 -- if this is a named constraint, search by name for the old 7085 -- discriminants constrained by the new one. 7086 7087 elsif Nkind (Expression (D_Constraint)) = N_Identifier then 7088 7089 -- Find new discriminant with that name 7090 7091 New_Disc := First_Discriminant (Derived_Type); 7092 while Present (New_Disc) loop 7093 exit when 7094 Chars (New_Disc) = Chars (Expression (D_Constraint)); 7095 Next_Discriminant (New_Disc); 7096 end loop; 7097 7098 if Present (New_Disc) then 7099 7100 -- Verify that new discriminant renames some discriminant 7101 -- of the parent type, and associate the new discriminant 7102 -- with one or more old ones that it renames. 7103 7104 declare 7105 Selector : Node_Id; 7106 7107 begin 7108 Selector := First (Selector_Names (D_Constraint)); 7109 while Present (Selector) loop 7110 Old_Disc := First_Discriminant (Parent_Type); 7111 while Present (Old_Disc) loop 7112 exit when Chars (Old_Disc) = Chars (Selector); 7113 Next_Discriminant (Old_Disc); 7114 end loop; 7115 7116 if Present (Old_Disc) then 7117 Set_Corresponding_Discriminant 7118 (New_Disc, Old_Disc); 7119 end if; 7120 7121 Next (Selector); 7122 end loop; 7123 end; 7124 end if; 7125 end if; 7126 7127 Next (D_Constraint); 7128 end loop; 7129 7130 New_Disc := First_Discriminant (Derived_Type); 7131 while Present (New_Disc) loop 7132 if No (Corresponding_Discriminant (New_Disc)) then 7133 Error_Msg_NE 7134 ("new discriminant& must constrain old one", N, New_Disc); 7135 7136 elsif not 7137 Subtypes_Statically_Compatible 7138 (Etype (New_Disc), 7139 Etype (Corresponding_Discriminant (New_Disc))) 7140 then 7141 Error_Msg_NE 7142 ("& not statically compatible with parent discriminant", 7143 N, New_Disc); 7144 end if; 7145 7146 Next_Discriminant (New_Disc); 7147 end loop; 7148 end if; 7149 7150 elsif Present (Discriminant_Specifications (N)) then 7151 Error_Msg_N 7152 ("missing discriminant constraint in untagged derivation", N); 7153 end if; 7154 7155 -- The entity chain of the derived type includes the new discriminants 7156 -- but shares operations with the parent. 7157 7158 if Present (Discriminant_Specifications (N)) then 7159 Old_Disc := First_Discriminant (Parent_Type); 7160 while Present (Old_Disc) loop 7161 if No (Next_Entity (Old_Disc)) 7162 or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant 7163 then 7164 Link_Entities 7165 (Last_Entity (Derived_Type), Next_Entity (Old_Disc)); 7166 exit; 7167 end if; 7168 7169 Next_Discriminant (Old_Disc); 7170 end loop; 7171 7172 else 7173 Set_First_Entity (Derived_Type, First_Entity (Parent_Type)); 7174 if Has_Discriminants (Parent_Type) then 7175 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 7176 Set_Discriminant_Constraint ( 7177 Derived_Type, Discriminant_Constraint (Parent_Type)); 7178 end if; 7179 end if; 7180 7181 Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type)); 7182 7183 Set_Has_Completion (Derived_Type); 7184 7185 if Corr_Decl_Needed then 7186 Set_Stored_Constraint (Derived_Type, New_Constraint); 7187 Insert_After (N, Corr_Decl); 7188 Analyze (Corr_Decl); 7189 Set_Corresponding_Record_Type (Derived_Type, Corr_Record); 7190 end if; 7191 end Build_Derived_Concurrent_Type; 7192 7193 ------------------------------------ 7194 -- Build_Derived_Enumeration_Type -- 7195 ------------------------------------ 7196 7197 procedure Build_Derived_Enumeration_Type 7198 (N : Node_Id; 7199 Parent_Type : Entity_Id; 7200 Derived_Type : Entity_Id) 7201 is 7202 function Bound_Belongs_To_Type (B : Node_Id) return Boolean; 7203 -- When the type declaration includes a constraint, we generate 7204 -- a subtype declaration of an anonymous base type, with the constraint 7205 -- given in the original type declaration. Conceptually, the bounds 7206 -- are converted to the new base type, and this conversion freezes 7207 -- (prematurely) that base type, when the bounds are simply literals. 7208 -- As a result, a representation clause for the derived type is then 7209 -- rejected or ignored. This procedure recognizes the simple case of 7210 -- literal bounds, which allows us to indicate that the conversions 7211 -- are not freeze points, and the subsequent representation clause 7212 -- can be accepted. 7213 -- A similar approach might be used to resolve the long-standing 7214 -- problem of premature freezing of derived numeric types ??? 7215 7216 function Bound_Belongs_To_Type (B : Node_Id) return Boolean is 7217 begin 7218 return Nkind (B) = N_Type_Conversion 7219 and then Is_Entity_Name (Expression (B)) 7220 and then Ekind (Entity (Expression (B))) = E_Enumeration_Literal; 7221 end Bound_Belongs_To_Type; 7222 7223 Loc : constant Source_Ptr := Sloc (N); 7224 Def : constant Node_Id := Type_Definition (N); 7225 Indic : constant Node_Id := Subtype_Indication (Def); 7226 Implicit_Base : Entity_Id; 7227 Literal : Entity_Id; 7228 New_Lit : Entity_Id; 7229 Literals_List : List_Id; 7230 Type_Decl : Node_Id; 7231 Hi, Lo : Node_Id; 7232 Rang_Expr : Node_Id; 7233 7234 begin 7235 -- Since types Standard.Character and Standard.[Wide_]Wide_Character do 7236 -- not have explicit literals lists we need to process types derived 7237 -- from them specially. This is handled by Derived_Standard_Character. 7238 -- If the parent type is a generic type, there are no literals either, 7239 -- and we construct the same skeletal representation as for the generic 7240 -- parent type. 7241 7242 if Is_Standard_Character_Type (Parent_Type) then 7243 Derived_Standard_Character (N, Parent_Type, Derived_Type); 7244 7245 elsif Is_Generic_Type (Root_Type (Parent_Type)) then 7246 declare 7247 Lo : Node_Id; 7248 Hi : Node_Id; 7249 7250 begin 7251 if Nkind (Indic) /= N_Subtype_Indication then 7252 Lo := 7253 Make_Attribute_Reference (Loc, 7254 Attribute_Name => Name_First, 7255 Prefix => New_Occurrence_Of (Derived_Type, Loc)); 7256 Set_Etype (Lo, Derived_Type); 7257 7258 Hi := 7259 Make_Attribute_Reference (Loc, 7260 Attribute_Name => Name_Last, 7261 Prefix => New_Occurrence_Of (Derived_Type, Loc)); 7262 Set_Etype (Hi, Derived_Type); 7263 7264 Set_Scalar_Range (Derived_Type, 7265 Make_Range (Loc, 7266 Low_Bound => Lo, 7267 High_Bound => Hi)); 7268 else 7269 7270 -- Analyze subtype indication and verify compatibility 7271 -- with parent type. 7272 7273 if Base_Type (Process_Subtype (Indic, N)) /= 7274 Base_Type (Parent_Type) 7275 then 7276 Error_Msg_N 7277 ("illegal constraint for formal discrete type", N); 7278 end if; 7279 end if; 7280 end; 7281 7282 else 7283 -- If a constraint is present, analyze the bounds to catch 7284 -- premature usage of the derived literals. 7285 7286 if Nkind (Indic) = N_Subtype_Indication 7287 and then Nkind (Range_Expression (Constraint (Indic))) = N_Range 7288 then 7289 Analyze (Low_Bound (Range_Expression (Constraint (Indic)))); 7290 Analyze (High_Bound (Range_Expression (Constraint (Indic)))); 7291 end if; 7292 7293 -- Introduce an implicit base type for the derived type even if there 7294 -- is no constraint attached to it, since this seems closer to the 7295 -- Ada semantics. Build a full type declaration tree for the derived 7296 -- type using the implicit base type as the defining identifier. The 7297 -- build a subtype declaration tree which applies the constraint (if 7298 -- any) have it replace the derived type declaration. 7299 7300 Literal := First_Literal (Parent_Type); 7301 Literals_List := New_List; 7302 while Present (Literal) 7303 and then Ekind (Literal) = E_Enumeration_Literal 7304 loop 7305 -- Literals of the derived type have the same representation as 7306 -- those of the parent type, but this representation can be 7307 -- overridden by an explicit representation clause. Indicate 7308 -- that there is no explicit representation given yet. These 7309 -- derived literals are implicit operations of the new type, 7310 -- and can be overridden by explicit ones. 7311 7312 if Nkind (Literal) = N_Defining_Character_Literal then 7313 New_Lit := 7314 Make_Defining_Character_Literal (Loc, Chars (Literal)); 7315 else 7316 New_Lit := Make_Defining_Identifier (Loc, Chars (Literal)); 7317 end if; 7318 7319 Set_Ekind (New_Lit, E_Enumeration_Literal); 7320 Set_Enumeration_Pos (New_Lit, Enumeration_Pos (Literal)); 7321 Set_Enumeration_Rep (New_Lit, Enumeration_Rep (Literal)); 7322 Set_Enumeration_Rep_Expr (New_Lit, Empty); 7323 Set_Alias (New_Lit, Literal); 7324 Set_Is_Known_Valid (New_Lit, True); 7325 7326 Append (New_Lit, Literals_List); 7327 Next_Literal (Literal); 7328 end loop; 7329 7330 Implicit_Base := 7331 Make_Defining_Identifier (Sloc (Derived_Type), 7332 Chars => New_External_Name (Chars (Derived_Type), 'B')); 7333 7334 -- Indicate the proper nature of the derived type. This must be done 7335 -- before analysis of the literals, to recognize cases when a literal 7336 -- may be hidden by a previous explicit function definition (cf. 7337 -- c83031a). 7338 7339 Set_Ekind (Derived_Type, E_Enumeration_Subtype); 7340 Set_Etype (Derived_Type, Implicit_Base); 7341 7342 Type_Decl := 7343 Make_Full_Type_Declaration (Loc, 7344 Defining_Identifier => Implicit_Base, 7345 Discriminant_Specifications => No_List, 7346 Type_Definition => 7347 Make_Enumeration_Type_Definition (Loc, Literals_List)); 7348 7349 Mark_Rewrite_Insertion (Type_Decl); 7350 Insert_Before (N, Type_Decl); 7351 Analyze (Type_Decl); 7352 7353 -- The anonymous base now has a full declaration, but this base 7354 -- is not a first subtype. 7355 7356 Set_Is_First_Subtype (Implicit_Base, False); 7357 7358 -- After the implicit base is analyzed its Etype needs to be changed 7359 -- to reflect the fact that it is derived from the parent type which 7360 -- was ignored during analysis. We also set the size at this point. 7361 7362 Set_Etype (Implicit_Base, Parent_Type); 7363 7364 Set_Size_Info (Implicit_Base, Parent_Type); 7365 Set_RM_Size (Implicit_Base, RM_Size (Parent_Type)); 7366 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type)); 7367 7368 -- Copy other flags from parent type 7369 7370 Set_Has_Non_Standard_Rep 7371 (Implicit_Base, Has_Non_Standard_Rep 7372 (Parent_Type)); 7373 Set_Has_Pragma_Ordered 7374 (Implicit_Base, Has_Pragma_Ordered 7375 (Parent_Type)); 7376 Set_Has_Delayed_Freeze (Implicit_Base); 7377 7378 -- Process the subtype indication including a validation check on the 7379 -- constraint, if any. If a constraint is given, its bounds must be 7380 -- implicitly converted to the new type. 7381 7382 if Nkind (Indic) = N_Subtype_Indication then 7383 declare 7384 R : constant Node_Id := 7385 Range_Expression (Constraint (Indic)); 7386 7387 begin 7388 if Nkind (R) = N_Range then 7389 Hi := Build_Scalar_Bound 7390 (High_Bound (R), Parent_Type, Implicit_Base); 7391 Lo := Build_Scalar_Bound 7392 (Low_Bound (R), Parent_Type, Implicit_Base); 7393 7394 else 7395 -- Constraint is a Range attribute. Replace with explicit 7396 -- mention of the bounds of the prefix, which must be a 7397 -- subtype. 7398 7399 Analyze (Prefix (R)); 7400 Hi := 7401 Convert_To (Implicit_Base, 7402 Make_Attribute_Reference (Loc, 7403 Attribute_Name => Name_Last, 7404 Prefix => 7405 New_Occurrence_Of (Entity (Prefix (R)), Loc))); 7406 7407 Lo := 7408 Convert_To (Implicit_Base, 7409 Make_Attribute_Reference (Loc, 7410 Attribute_Name => Name_First, 7411 Prefix => 7412 New_Occurrence_Of (Entity (Prefix (R)), Loc))); 7413 end if; 7414 end; 7415 7416 else 7417 Hi := 7418 Build_Scalar_Bound 7419 (Type_High_Bound (Parent_Type), 7420 Parent_Type, Implicit_Base); 7421 Lo := 7422 Build_Scalar_Bound 7423 (Type_Low_Bound (Parent_Type), 7424 Parent_Type, Implicit_Base); 7425 end if; 7426 7427 Rang_Expr := 7428 Make_Range (Loc, 7429 Low_Bound => Lo, 7430 High_Bound => Hi); 7431 7432 -- If we constructed a default range for the case where no range 7433 -- was given, then the expressions in the range must not freeze 7434 -- since they do not correspond to expressions in the source. 7435 -- However, if the type inherits predicates the expressions will 7436 -- be elaborated earlier and must freeze. 7437 7438 if (Nkind (Indic) /= N_Subtype_Indication 7439 or else 7440 (Bound_Belongs_To_Type (Lo) and then Bound_Belongs_To_Type (Hi))) 7441 and then not Has_Predicates (Derived_Type) 7442 then 7443 Set_Must_Not_Freeze (Lo); 7444 Set_Must_Not_Freeze (Hi); 7445 Set_Must_Not_Freeze (Rang_Expr); 7446 end if; 7447 7448 Rewrite (N, 7449 Make_Subtype_Declaration (Loc, 7450 Defining_Identifier => Derived_Type, 7451 Subtype_Indication => 7452 Make_Subtype_Indication (Loc, 7453 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc), 7454 Constraint => 7455 Make_Range_Constraint (Loc, 7456 Range_Expression => Rang_Expr)))); 7457 7458 Analyze (N); 7459 7460 -- Propagate the aspects from the original type declaration to the 7461 -- declaration of the implicit base. 7462 7463 Move_Aspects (From => Original_Node (N), To => Type_Decl); 7464 7465 -- Apply a range check. Since this range expression doesn't have an 7466 -- Etype, we have to specifically pass the Source_Typ parameter. Is 7467 -- this right??? 7468 7469 if Nkind (Indic) = N_Subtype_Indication then 7470 Apply_Range_Check 7471 (Range_Expression (Constraint (Indic)), Parent_Type, 7472 Source_Typ => Entity (Subtype_Mark (Indic))); 7473 end if; 7474 end if; 7475 end Build_Derived_Enumeration_Type; 7476 7477 -------------------------------- 7478 -- Build_Derived_Numeric_Type -- 7479 -------------------------------- 7480 7481 procedure Build_Derived_Numeric_Type 7482 (N : Node_Id; 7483 Parent_Type : Entity_Id; 7484 Derived_Type : Entity_Id) 7485 is 7486 Loc : constant Source_Ptr := Sloc (N); 7487 Tdef : constant Node_Id := Type_Definition (N); 7488 Indic : constant Node_Id := Subtype_Indication (Tdef); 7489 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 7490 No_Constraint : constant Boolean := Nkind (Indic) /= 7491 N_Subtype_Indication; 7492 Implicit_Base : Entity_Id; 7493 7494 Lo : Node_Id; 7495 Hi : Node_Id; 7496 7497 begin 7498 -- Process the subtype indication including a validation check on 7499 -- the constraint if any. 7500 7501 Discard_Node (Process_Subtype (Indic, N)); 7502 7503 -- Introduce an implicit base type for the derived type even if there 7504 -- is no constraint attached to it, since this seems closer to the Ada 7505 -- semantics. 7506 7507 Implicit_Base := 7508 Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); 7509 7510 Set_Etype (Implicit_Base, Parent_Base); 7511 Set_Ekind (Implicit_Base, Ekind (Parent_Base)); 7512 Set_Size_Info (Implicit_Base, Parent_Base); 7513 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base)); 7514 Set_Parent (Implicit_Base, Parent (Derived_Type)); 7515 Set_Is_Known_Valid (Implicit_Base, Is_Known_Valid (Parent_Base)); 7516 7517 -- Set RM Size for discrete type or decimal fixed-point type 7518 -- Ordinary fixed-point is excluded, why??? 7519 7520 if Is_Discrete_Type (Parent_Base) 7521 or else Is_Decimal_Fixed_Point_Type (Parent_Base) 7522 then 7523 Set_RM_Size (Implicit_Base, RM_Size (Parent_Base)); 7524 end if; 7525 7526 Set_Has_Delayed_Freeze (Implicit_Base); 7527 7528 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); 7529 Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); 7530 7531 Set_Scalar_Range (Implicit_Base, 7532 Make_Range (Loc, 7533 Low_Bound => Lo, 7534 High_Bound => Hi)); 7535 7536 if Has_Infinities (Parent_Base) then 7537 Set_Includes_Infinities (Scalar_Range (Implicit_Base)); 7538 end if; 7539 7540 -- The Derived_Type, which is the entity of the declaration, is a 7541 -- subtype of the implicit base. Its Ekind is a subtype, even in the 7542 -- absence of an explicit constraint. 7543 7544 Set_Etype (Derived_Type, Implicit_Base); 7545 7546 -- If we did not have a constraint, then the Ekind is set from the 7547 -- parent type (otherwise Process_Subtype has set the bounds) 7548 7549 if No_Constraint then 7550 Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type))); 7551 end if; 7552 7553 -- If we did not have a range constraint, then set the range from the 7554 -- parent type. Otherwise, the Process_Subtype call has set the bounds. 7555 7556 if No_Constraint or else not Has_Range_Constraint (Indic) then 7557 Set_Scalar_Range (Derived_Type, 7558 Make_Range (Loc, 7559 Low_Bound => New_Copy_Tree (Type_Low_Bound (Parent_Type)), 7560 High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type)))); 7561 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 7562 7563 if Has_Infinities (Parent_Type) then 7564 Set_Includes_Infinities (Scalar_Range (Derived_Type)); 7565 end if; 7566 7567 Set_Is_Known_Valid (Derived_Type, Is_Known_Valid (Parent_Type)); 7568 end if; 7569 7570 Set_Is_Descendant_Of_Address (Derived_Type, 7571 Is_Descendant_Of_Address (Parent_Type)); 7572 Set_Is_Descendant_Of_Address (Implicit_Base, 7573 Is_Descendant_Of_Address (Parent_Type)); 7574 7575 -- Set remaining type-specific fields, depending on numeric type 7576 7577 if Is_Modular_Integer_Type (Parent_Type) then 7578 Set_Modulus (Implicit_Base, Modulus (Parent_Base)); 7579 7580 Set_Non_Binary_Modulus 7581 (Implicit_Base, Non_Binary_Modulus (Parent_Base)); 7582 7583 Set_Is_Known_Valid 7584 (Implicit_Base, Is_Known_Valid (Parent_Base)); 7585 7586 elsif Is_Floating_Point_Type (Parent_Type) then 7587 7588 -- Digits of base type is always copied from the digits value of 7589 -- the parent base type, but the digits of the derived type will 7590 -- already have been set if there was a constraint present. 7591 7592 Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); 7593 Set_Float_Rep (Implicit_Base, Float_Rep (Parent_Base)); 7594 7595 if No_Constraint then 7596 Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type)); 7597 end if; 7598 7599 elsif Is_Fixed_Point_Type (Parent_Type) then 7600 7601 -- Small of base type and derived type are always copied from the 7602 -- parent base type, since smalls never change. The delta of the 7603 -- base type is also copied from the parent base type. However the 7604 -- delta of the derived type will have been set already if a 7605 -- constraint was present. 7606 7607 Set_Small_Value (Derived_Type, Small_Value (Parent_Base)); 7608 Set_Small_Value (Implicit_Base, Small_Value (Parent_Base)); 7609 Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base)); 7610 7611 if No_Constraint then 7612 Set_Delta_Value (Derived_Type, Delta_Value (Parent_Type)); 7613 end if; 7614 7615 -- The scale and machine radix in the decimal case are always 7616 -- copied from the parent base type. 7617 7618 if Is_Decimal_Fixed_Point_Type (Parent_Type) then 7619 Set_Scale_Value (Derived_Type, Scale_Value (Parent_Base)); 7620 Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base)); 7621 7622 Set_Machine_Radix_10 7623 (Derived_Type, Machine_Radix_10 (Parent_Base)); 7624 Set_Machine_Radix_10 7625 (Implicit_Base, Machine_Radix_10 (Parent_Base)); 7626 7627 Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); 7628 7629 if No_Constraint then 7630 Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base)); 7631 7632 else 7633 -- the analysis of the subtype_indication sets the 7634 -- digits value of the derived type. 7635 7636 null; 7637 end if; 7638 end if; 7639 end if; 7640 7641 if Is_Integer_Type (Parent_Type) then 7642 Set_Has_Shift_Operator 7643 (Implicit_Base, Has_Shift_Operator (Parent_Type)); 7644 end if; 7645 7646 -- The type of the bounds is that of the parent type, and they 7647 -- must be converted to the derived type. 7648 7649 Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); 7650 7651 -- The implicit_base should be frozen when the derived type is frozen, 7652 -- but note that it is used in the conversions of the bounds. For fixed 7653 -- types we delay the determination of the bounds until the proper 7654 -- freezing point. For other numeric types this is rejected by GCC, for 7655 -- reasons that are currently unclear (???), so we choose to freeze the 7656 -- implicit base now. In the case of integers and floating point types 7657 -- this is harmless because subsequent representation clauses cannot 7658 -- affect anything, but it is still baffling that we cannot use the 7659 -- same mechanism for all derived numeric types. 7660 7661 -- There is a further complication: actually some representation 7662 -- clauses can affect the implicit base type. For example, attribute 7663 -- definition clauses for stream-oriented attributes need to set the 7664 -- corresponding TSS entries on the base type, and this normally 7665 -- cannot be done after the base type is frozen, so the circuitry in 7666 -- Sem_Ch13.New_Stream_Subprogram must account for this possibility 7667 -- and not use Set_TSS in this case. 7668 7669 -- There are also consequences for the case of delayed representation 7670 -- aspects for some cases. For example, a Size aspect is delayed and 7671 -- should not be evaluated to the freeze point. This early freezing 7672 -- means that the size attribute evaluation happens too early??? 7673 7674 if Is_Fixed_Point_Type (Parent_Type) then 7675 Conditional_Delay (Implicit_Base, Parent_Type); 7676 else 7677 Freeze_Before (N, Implicit_Base); 7678 end if; 7679 end Build_Derived_Numeric_Type; 7680 7681 -------------------------------- 7682 -- Build_Derived_Private_Type -- 7683 -------------------------------- 7684 7685 procedure Build_Derived_Private_Type 7686 (N : Node_Id; 7687 Parent_Type : Entity_Id; 7688 Derived_Type : Entity_Id; 7689 Is_Completion : Boolean; 7690 Derive_Subps : Boolean := True) 7691 is 7692 Loc : constant Source_Ptr := Sloc (N); 7693 Par_Base : constant Entity_Id := Base_Type (Parent_Type); 7694 Par_Scope : constant Entity_Id := Scope (Par_Base); 7695 Full_N : constant Node_Id := New_Copy_Tree (N); 7696 Full_Der : Entity_Id := New_Copy (Derived_Type); 7697 Full_P : Entity_Id; 7698 7699 procedure Build_Full_Derivation; 7700 -- Build full derivation, i.e. derive from the full view 7701 7702 procedure Copy_And_Build; 7703 -- Copy derived type declaration, replace parent with its full view, 7704 -- and build derivation 7705 7706 --------------------------- 7707 -- Build_Full_Derivation -- 7708 --------------------------- 7709 7710 procedure Build_Full_Derivation is 7711 begin 7712 -- If parent scope is not open, install the declarations 7713 7714 if not In_Open_Scopes (Par_Scope) then 7715 Install_Private_Declarations (Par_Scope); 7716 Install_Visible_Declarations (Par_Scope); 7717 Copy_And_Build; 7718 Uninstall_Declarations (Par_Scope); 7719 7720 -- If parent scope is open and in another unit, and parent has a 7721 -- completion, then the derivation is taking place in the visible 7722 -- part of a child unit. In that case retrieve the full view of 7723 -- the parent momentarily. 7724 7725 elsif not In_Same_Source_Unit (N, Parent_Type) then 7726 Full_P := Full_View (Parent_Type); 7727 Exchange_Declarations (Parent_Type); 7728 Copy_And_Build; 7729 Exchange_Declarations (Full_P); 7730 7731 -- Otherwise it is a local derivation 7732 7733 else 7734 Copy_And_Build; 7735 end if; 7736 end Build_Full_Derivation; 7737 7738 -------------------- 7739 -- Copy_And_Build -- 7740 -------------------- 7741 7742 procedure Copy_And_Build is 7743 Full_Parent : Entity_Id := Parent_Type; 7744 7745 begin 7746 -- If the parent is itself derived from another private type, 7747 -- installing the private declarations has not affected its 7748 -- privacy status, so use its own full view explicitly. 7749 7750 if Is_Private_Type (Full_Parent) 7751 and then Present (Full_View (Full_Parent)) 7752 then 7753 Full_Parent := Full_View (Full_Parent); 7754 end if; 7755 7756 -- And its underlying full view if necessary 7757 7758 if Is_Private_Type (Full_Parent) 7759 and then Present (Underlying_Full_View (Full_Parent)) 7760 then 7761 Full_Parent := Underlying_Full_View (Full_Parent); 7762 end if; 7763 7764 -- For record, concurrent, access and most enumeration types, the 7765 -- derivation from full view requires a fully-fledged declaration. 7766 -- In the other cases, just use an itype. 7767 7768 if Is_Record_Type (Full_Parent) 7769 or else Is_Concurrent_Type (Full_Parent) 7770 or else Is_Access_Type (Full_Parent) 7771 or else 7772 (Is_Enumeration_Type (Full_Parent) 7773 and then not Is_Standard_Character_Type (Full_Parent) 7774 and then not Is_Generic_Type (Root_Type (Full_Parent))) 7775 then 7776 -- Copy and adjust declaration to provide a completion for what 7777 -- is originally a private declaration. Indicate that full view 7778 -- is internally generated. 7779 7780 Set_Comes_From_Source (Full_N, False); 7781 Set_Comes_From_Source (Full_Der, False); 7782 Set_Parent (Full_Der, Full_N); 7783 Set_Defining_Identifier (Full_N, Full_Der); 7784 7785 -- If there are no constraints, adjust the subtype mark 7786 7787 if Nkind (Subtype_Indication (Type_Definition (Full_N))) /= 7788 N_Subtype_Indication 7789 then 7790 Set_Subtype_Indication 7791 (Type_Definition (Full_N), 7792 New_Occurrence_Of (Full_Parent, Sloc (Full_N))); 7793 end if; 7794 7795 Insert_After (N, Full_N); 7796 7797 -- Build full view of derived type from full view of parent which 7798 -- is now installed. Subprograms have been derived on the partial 7799 -- view, the completion does not derive them anew. 7800 7801 if Is_Record_Type (Full_Parent) then 7802 7803 -- If parent type is tagged, the completion inherits the proper 7804 -- primitive operations. 7805 7806 if Is_Tagged_Type (Parent_Type) then 7807 Build_Derived_Record_Type 7808 (Full_N, Full_Parent, Full_Der, Derive_Subps); 7809 else 7810 Build_Derived_Record_Type 7811 (Full_N, Full_Parent, Full_Der, Derive_Subps => False); 7812 end if; 7813 7814 else 7815 Build_Derived_Type 7816 (Full_N, Full_Parent, Full_Der, 7817 Is_Completion => False, Derive_Subps => False); 7818 end if; 7819 7820 -- The full declaration has been introduced into the tree and 7821 -- processed in the step above. It should not be analyzed again 7822 -- (when encountered later in the current list of declarations) 7823 -- to prevent spurious name conflicts. The full entity remains 7824 -- invisible. 7825 7826 Set_Analyzed (Full_N); 7827 7828 else 7829 Full_Der := 7830 Make_Defining_Identifier (Sloc (Derived_Type), 7831 Chars => Chars (Derived_Type)); 7832 Set_Is_Itype (Full_Der); 7833 Set_Associated_Node_For_Itype (Full_Der, N); 7834 Set_Parent (Full_Der, N); 7835 Build_Derived_Type 7836 (N, Full_Parent, Full_Der, 7837 Is_Completion => False, Derive_Subps => False); 7838 end if; 7839 7840 Set_Has_Private_Declaration (Full_Der); 7841 Set_Has_Private_Declaration (Derived_Type); 7842 7843 Set_Scope (Full_Der, Scope (Derived_Type)); 7844 Set_Is_First_Subtype (Full_Der, Is_First_Subtype (Derived_Type)); 7845 Set_Has_Size_Clause (Full_Der, False); 7846 Set_Has_Alignment_Clause (Full_Der, False); 7847 Set_Has_Delayed_Freeze (Full_Der); 7848 Set_Is_Frozen (Full_Der, False); 7849 Set_Freeze_Node (Full_Der, Empty); 7850 Set_Depends_On_Private (Full_Der, Has_Private_Component (Full_Der)); 7851 Set_Is_Public (Full_Der, Is_Public (Derived_Type)); 7852 7853 -- The convention on the base type may be set in the private part 7854 -- and not propagated to the subtype until later, so we obtain the 7855 -- convention from the base type of the parent. 7856 7857 Set_Convention (Full_Der, Convention (Base_Type (Full_Parent))); 7858 end Copy_And_Build; 7859 7860 -- Start of processing for Build_Derived_Private_Type 7861 7862 begin 7863 if Is_Tagged_Type (Parent_Type) then 7864 Full_P := Full_View (Parent_Type); 7865 7866 -- A type extension of a type with unknown discriminants is an 7867 -- indefinite type that the back-end cannot handle directly. 7868 -- We treat it as a private type, and build a completion that is 7869 -- derived from the full view of the parent, and hopefully has 7870 -- known discriminants. 7871 7872 -- If the full view of the parent type has an underlying record view, 7873 -- use it to generate the underlying record view of this derived type 7874 -- (required for chains of derivations with unknown discriminants). 7875 7876 -- Minor optimization: we avoid the generation of useless underlying 7877 -- record view entities if the private type declaration has unknown 7878 -- discriminants but its corresponding full view has no 7879 -- discriminants. 7880 7881 if Has_Unknown_Discriminants (Parent_Type) 7882 and then Present (Full_P) 7883 and then (Has_Discriminants (Full_P) 7884 or else Present (Underlying_Record_View (Full_P))) 7885 and then not In_Open_Scopes (Par_Scope) 7886 and then Expander_Active 7887 then 7888 declare 7889 Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T'); 7890 New_Ext : constant Node_Id := 7891 Copy_Separate_Tree 7892 (Record_Extension_Part (Type_Definition (N))); 7893 Decl : Node_Id; 7894 7895 begin 7896 Build_Derived_Record_Type 7897 (N, Parent_Type, Derived_Type, Derive_Subps); 7898 7899 -- Build anonymous completion, as a derivation from the full 7900 -- view of the parent. This is not a completion in the usual 7901 -- sense, because the current type is not private. 7902 7903 Decl := 7904 Make_Full_Type_Declaration (Loc, 7905 Defining_Identifier => Full_Der, 7906 Type_Definition => 7907 Make_Derived_Type_Definition (Loc, 7908 Subtype_Indication => 7909 New_Copy_Tree 7910 (Subtype_Indication (Type_Definition (N))), 7911 Record_Extension_Part => New_Ext)); 7912 7913 -- If the parent type has an underlying record view, use it 7914 -- here to build the new underlying record view. 7915 7916 if Present (Underlying_Record_View (Full_P)) then 7917 pragma Assert 7918 (Nkind (Subtype_Indication (Type_Definition (Decl))) 7919 = N_Identifier); 7920 Set_Entity (Subtype_Indication (Type_Definition (Decl)), 7921 Underlying_Record_View (Full_P)); 7922 end if; 7923 7924 Install_Private_Declarations (Par_Scope); 7925 Install_Visible_Declarations (Par_Scope); 7926 Insert_Before (N, Decl); 7927 7928 -- Mark entity as an underlying record view before analysis, 7929 -- to avoid generating the list of its primitive operations 7930 -- (which is not really required for this entity) and thus 7931 -- prevent spurious errors associated with missing overriding 7932 -- of abstract primitives (overridden only for Derived_Type). 7933 7934 Set_Ekind (Full_Der, E_Record_Type); 7935 Set_Is_Underlying_Record_View (Full_Der); 7936 Set_Default_SSO (Full_Der); 7937 Set_No_Reordering (Full_Der, No_Component_Reordering); 7938 7939 Analyze (Decl); 7940 7941 pragma Assert (Has_Discriminants (Full_Der) 7942 and then not Has_Unknown_Discriminants (Full_Der)); 7943 7944 Uninstall_Declarations (Par_Scope); 7945 7946 -- Freeze the underlying record view, to prevent generation of 7947 -- useless dispatching information, which is simply shared with 7948 -- the real derived type. 7949 7950 Set_Is_Frozen (Full_Der); 7951 7952 -- If the derived type has access discriminants, create 7953 -- references to their anonymous types now, to prevent 7954 -- back-end problems when their first use is in generated 7955 -- bodies of primitives. 7956 7957 declare 7958 E : Entity_Id; 7959 7960 begin 7961 E := First_Entity (Full_Der); 7962 7963 while Present (E) loop 7964 if Ekind (E) = E_Discriminant 7965 and then Ekind (Etype (E)) = E_Anonymous_Access_Type 7966 then 7967 Build_Itype_Reference (Etype (E), Decl); 7968 end if; 7969 7970 Next_Entity (E); 7971 end loop; 7972 end; 7973 7974 -- Set up links between real entity and underlying record view 7975 7976 Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der)); 7977 Set_Underlying_Record_View (Base_Type (Full_Der), Derived_Type); 7978 end; 7979 7980 -- If discriminants are known, build derived record 7981 7982 else 7983 Build_Derived_Record_Type 7984 (N, Parent_Type, Derived_Type, Derive_Subps); 7985 end if; 7986 7987 return; 7988 7989 elsif Has_Discriminants (Parent_Type) then 7990 7991 -- Build partial view of derived type from partial view of parent. 7992 -- This must be done before building the full derivation because the 7993 -- second derivation will modify the discriminants of the first and 7994 -- the discriminants are chained with the rest of the components in 7995 -- the full derivation. 7996 7997 Build_Derived_Record_Type 7998 (N, Parent_Type, Derived_Type, Derive_Subps); 7999 8000 -- Build the full derivation if this is not the anonymous derived 8001 -- base type created by Build_Derived_Record_Type in the constrained 8002 -- case (see point 5. of its head comment) since we build it for the 8003 -- derived subtype. 8004 8005 if Present (Full_View (Parent_Type)) 8006 and then not Is_Itype (Derived_Type) 8007 then 8008 declare 8009 Der_Base : constant Entity_Id := Base_Type (Derived_Type); 8010 Discr : Entity_Id; 8011 Last_Discr : Entity_Id; 8012 8013 begin 8014 -- If this is not a completion, construct the implicit full 8015 -- view by deriving from the full view of the parent type. 8016 -- But if this is a completion, the derived private type 8017 -- being built is a full view and the full derivation can 8018 -- only be its underlying full view. 8019 8020 Build_Full_Derivation; 8021 8022 if not Is_Completion then 8023 Set_Full_View (Derived_Type, Full_Der); 8024 else 8025 Set_Underlying_Full_View (Derived_Type, Full_Der); 8026 Set_Is_Underlying_Full_View (Full_Der); 8027 end if; 8028 8029 if not Is_Base_Type (Derived_Type) then 8030 Set_Full_View (Der_Base, Base_Type (Full_Der)); 8031 end if; 8032 8033 -- Copy the discriminant list from full view to the partial 8034 -- view (base type and its subtype). Gigi requires that the 8035 -- partial and full views have the same discriminants. 8036 8037 -- Note that since the partial view points to discriminants 8038 -- in the full view, their scope will be that of the full 8039 -- view. This might cause some front end problems and need 8040 -- adjustment??? 8041 8042 Discr := First_Discriminant (Base_Type (Full_Der)); 8043 Set_First_Entity (Der_Base, Discr); 8044 8045 loop 8046 Last_Discr := Discr; 8047 Next_Discriminant (Discr); 8048 exit when No (Discr); 8049 end loop; 8050 8051 Set_Last_Entity (Der_Base, Last_Discr); 8052 Set_First_Entity (Derived_Type, First_Entity (Der_Base)); 8053 Set_Last_Entity (Derived_Type, Last_Entity (Der_Base)); 8054 end; 8055 end if; 8056 8057 elsif Present (Full_View (Parent_Type)) 8058 and then Has_Discriminants (Full_View (Parent_Type)) 8059 then 8060 if Has_Unknown_Discriminants (Parent_Type) 8061 and then Nkind (Subtype_Indication (Type_Definition (N))) = 8062 N_Subtype_Indication 8063 then 8064 Error_Msg_N 8065 ("cannot constrain type with unknown discriminants", 8066 Subtype_Indication (Type_Definition (N))); 8067 return; 8068 end if; 8069 8070 -- If this is not a completion, construct the implicit full view by 8071 -- deriving from the full view of the parent type. But if this is a 8072 -- completion, the derived private type being built is a full view 8073 -- and the full derivation can only be its underlying full view. 8074 8075 Build_Full_Derivation; 8076 8077 if not Is_Completion then 8078 Set_Full_View (Derived_Type, Full_Der); 8079 else 8080 Set_Underlying_Full_View (Derived_Type, Full_Der); 8081 Set_Is_Underlying_Full_View (Full_Der); 8082 end if; 8083 8084 -- In any case, the primitive operations are inherited from the 8085 -- parent type, not from the internal full view. 8086 8087 Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type)); 8088 8089 if Derive_Subps then 8090 Derive_Subprograms (Parent_Type, Derived_Type); 8091 end if; 8092 8093 Set_Stored_Constraint (Derived_Type, No_Elist); 8094 Set_Is_Constrained 8095 (Derived_Type, Is_Constrained (Full_View (Parent_Type))); 8096 8097 else 8098 -- Untagged type, No discriminants on either view 8099 8100 if Nkind (Subtype_Indication (Type_Definition (N))) = 8101 N_Subtype_Indication 8102 then 8103 Error_Msg_N 8104 ("illegal constraint on type without discriminants", N); 8105 end if; 8106 8107 if Present (Discriminant_Specifications (N)) 8108 and then Present (Full_View (Parent_Type)) 8109 and then not Is_Tagged_Type (Full_View (Parent_Type)) 8110 then 8111 Error_Msg_N ("cannot add discriminants to untagged type", N); 8112 end if; 8113 8114 Set_Stored_Constraint (Derived_Type, No_Elist); 8115 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 8116 8117 Set_Is_Controlled_Active 8118 (Derived_Type, Is_Controlled_Active (Parent_Type)); 8119 8120 Set_Disable_Controlled 8121 (Derived_Type, Disable_Controlled (Parent_Type)); 8122 8123 Set_Has_Controlled_Component 8124 (Derived_Type, Has_Controlled_Component (Parent_Type)); 8125 8126 -- Direct controlled types do not inherit Finalize_Storage_Only flag 8127 8128 if not Is_Controlled (Parent_Type) then 8129 Set_Finalize_Storage_Only 8130 (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type)); 8131 end if; 8132 8133 -- If this is not a completion, construct the implicit full view by 8134 -- deriving from the full view of the parent type. 8135 8136 -- ??? If the parent is untagged private and its completion is 8137 -- tagged, this mechanism will not work because we cannot derive from 8138 -- the tagged full view unless we have an extension. 8139 8140 if Present (Full_View (Parent_Type)) 8141 and then not Is_Tagged_Type (Full_View (Parent_Type)) 8142 and then not Is_Completion 8143 then 8144 Build_Full_Derivation; 8145 Set_Full_View (Derived_Type, Full_Der); 8146 end if; 8147 end if; 8148 8149 Set_Has_Unknown_Discriminants (Derived_Type, 8150 Has_Unknown_Discriminants (Parent_Type)); 8151 8152 if Is_Private_Type (Derived_Type) then 8153 Set_Private_Dependents (Derived_Type, New_Elmt_List); 8154 end if; 8155 8156 -- If the parent base type is in scope, add the derived type to its 8157 -- list of private dependents, because its full view may become 8158 -- visible subsequently (in a nested private part, a body, or in a 8159 -- further child unit). 8160 8161 if Is_Private_Type (Par_Base) and then In_Open_Scopes (Par_Scope) then 8162 Append_Elmt (Derived_Type, Private_Dependents (Parent_Type)); 8163 8164 -- Check for unusual case where a type completed by a private 8165 -- derivation occurs within a package nested in a child unit, and 8166 -- the parent is declared in an ancestor. 8167 8168 if Is_Child_Unit (Scope (Current_Scope)) 8169 and then Is_Completion 8170 and then In_Private_Part (Current_Scope) 8171 and then Scope (Parent_Type) /= Current_Scope 8172 8173 -- Note that if the parent has a completion in the private part, 8174 -- (which is itself a derivation from some other private type) 8175 -- it is that completion that is visible, there is no full view 8176 -- available, and no special processing is needed. 8177 8178 and then Present (Full_View (Parent_Type)) 8179 then 8180 -- In this case, the full view of the parent type will become 8181 -- visible in the body of the enclosing child, and only then will 8182 -- the current type be possibly non-private. Build an underlying 8183 -- full view that will be installed when the enclosing child body 8184 -- is compiled. 8185 8186 if Present (Underlying_Full_View (Derived_Type)) then 8187 Full_Der := Underlying_Full_View (Derived_Type); 8188 else 8189 Build_Full_Derivation; 8190 Set_Underlying_Full_View (Derived_Type, Full_Der); 8191 Set_Is_Underlying_Full_View (Full_Der); 8192 end if; 8193 8194 -- The full view will be used to swap entities on entry/exit to 8195 -- the body, and must appear in the entity list for the package. 8196 8197 Append_Entity (Full_Der, Scope (Derived_Type)); 8198 end if; 8199 end if; 8200 end Build_Derived_Private_Type; 8201 8202 ------------------------------- 8203 -- Build_Derived_Record_Type -- 8204 ------------------------------- 8205 8206 -- 1. INTRODUCTION 8207 8208 -- Ideally we would like to use the same model of type derivation for 8209 -- tagged and untagged record types. Unfortunately this is not quite 8210 -- possible because the semantics of representation clauses is different 8211 -- for tagged and untagged records under inheritance. Consider the 8212 -- following: 8213 8214 -- type R (...) is [tagged] record ... end record; 8215 -- type T (...) is new R (...) [with ...]; 8216 8217 -- The representation clauses for T can specify a completely different 8218 -- record layout from R's. Hence the same component can be placed in two 8219 -- very different positions in objects of type T and R. If R and T are 8220 -- tagged types, representation clauses for T can only specify the layout 8221 -- of non inherited components, thus components that are common in R and T 8222 -- have the same position in objects of type R and T. 8223 8224 -- This has two implications. The first is that the entire tree for R's 8225 -- declaration needs to be copied for T in the untagged case, so that T 8226 -- can be viewed as a record type of its own with its own representation 8227 -- clauses. The second implication is the way we handle discriminants. 8228 -- Specifically, in the untagged case we need a way to communicate to Gigi 8229 -- what are the real discriminants in the record, while for the semantics 8230 -- we need to consider those introduced by the user to rename the 8231 -- discriminants in the parent type. This is handled by introducing the 8232 -- notion of stored discriminants. See below for more. 8233 8234 -- Fortunately the way regular components are inherited can be handled in 8235 -- the same way in tagged and untagged types. 8236 8237 -- To complicate things a bit more the private view of a private extension 8238 -- cannot be handled in the same way as the full view (for one thing the 8239 -- semantic rules are somewhat different). We will explain what differs 8240 -- below. 8241 8242 -- 2. DISCRIMINANTS UNDER INHERITANCE 8243 8244 -- The semantic rules governing the discriminants of derived types are 8245 -- quite subtle. 8246 8247 -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new 8248 -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART] 8249 8250 -- If parent type has discriminants, then the discriminants that are 8251 -- declared in the derived type are [3.4 (11)]: 8252 8253 -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if 8254 -- there is one; 8255 8256 -- o Otherwise, each discriminant of the parent type (implicitly declared 8257 -- in the same order with the same specifications). In this case, the 8258 -- discriminants are said to be "inherited", or if unknown in the parent 8259 -- are also unknown in the derived type. 8260 8261 -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]: 8262 8263 -- o The parent subtype must be constrained; 8264 8265 -- o If the parent type is not a tagged type, then each discriminant of 8266 -- the derived type must be used in the constraint defining a parent 8267 -- subtype. [Implementation note: This ensures that the new discriminant 8268 -- can share storage with an existing discriminant.] 8269 8270 -- For the derived type each discriminant of the parent type is either 8271 -- inherited, constrained to equal some new discriminant of the derived 8272 -- type, or constrained to the value of an expression. 8273 8274 -- When inherited or constrained to equal some new discriminant, the 8275 -- parent discriminant and the discriminant of the derived type are said 8276 -- to "correspond". 8277 8278 -- If a discriminant of the parent type is constrained to a specific value 8279 -- in the derived type definition, then the discriminant is said to be 8280 -- "specified" by that derived type definition. 8281 8282 -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES 8283 8284 -- We have spoken about stored discriminants in point 1 (introduction) 8285 -- above. There are two sorts of stored discriminants: implicit and 8286 -- explicit. As long as the derived type inherits the same discriminants as 8287 -- the root record type, stored discriminants are the same as regular 8288 -- discriminants, and are said to be implicit. However, if any discriminant 8289 -- in the root type was renamed in the derived type, then the derived 8290 -- type will contain explicit stored discriminants. Explicit stored 8291 -- discriminants are discriminants in addition to the semantically visible 8292 -- discriminants defined for the derived type. Stored discriminants are 8293 -- used by Gigi to figure out what are the physical discriminants in 8294 -- objects of the derived type (see precise definition in einfo.ads). 8295 -- As an example, consider the following: 8296 8297 -- type R (D1, D2, D3 : Int) is record ... end record; 8298 -- type T1 is new R; 8299 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1); 8300 -- type T3 is new T2; 8301 -- type T4 (Y : Int) is new T3 (Y, 99); 8302 8303 -- The following table summarizes the discriminants and stored 8304 -- discriminants in R and T1 through T4: 8305 8306 -- Type Discrim Stored Discrim Comment 8307 -- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R 8308 -- T1 (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in T1 8309 -- T2 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T2 8310 -- T3 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T3 8311 -- T4 (Y) (D1, D2, D3) Girder discrims EXPLICIT in T4 8312 8313 -- Field Corresponding_Discriminant (abbreviated CD below) allows us to 8314 -- find the corresponding discriminant in the parent type, while 8315 -- Original_Record_Component (abbreviated ORC below) the actual physical 8316 -- component that is renamed. Finally the field Is_Completely_Hidden 8317 -- (abbreviated ICH below) is set for all explicit stored discriminants 8318 -- (see einfo.ads for more info). For the above example this gives: 8319 8320 -- Discrim CD ORC ICH 8321 -- ^^^^^^^ ^^ ^^^ ^^^ 8322 -- D1 in R empty itself no 8323 -- D2 in R empty itself no 8324 -- D3 in R empty itself no 8325 8326 -- D1 in T1 D1 in R itself no 8327 -- D2 in T1 D2 in R itself no 8328 -- D3 in T1 D3 in R itself no 8329 8330 -- X1 in T2 D3 in T1 D3 in T2 no 8331 -- X2 in T2 D1 in T1 D1 in T2 no 8332 -- D1 in T2 empty itself yes 8333 -- D2 in T2 empty itself yes 8334 -- D3 in T2 empty itself yes 8335 8336 -- X1 in T3 X1 in T2 D3 in T3 no 8337 -- X2 in T3 X2 in T2 D1 in T3 no 8338 -- D1 in T3 empty itself yes 8339 -- D2 in T3 empty itself yes 8340 -- D3 in T3 empty itself yes 8341 8342 -- Y in T4 X1 in T3 D3 in T4 no 8343 -- D1 in T4 empty itself yes 8344 -- D2 in T4 empty itself yes 8345 -- D3 in T4 empty itself yes 8346 8347 -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES 8348 8349 -- Type derivation for tagged types is fairly straightforward. If no 8350 -- discriminants are specified by the derived type, these are inherited 8351 -- from the parent. No explicit stored discriminants are ever necessary. 8352 -- The only manipulation that is done to the tree is that of adding a 8353 -- _parent field with parent type and constrained to the same constraint 8354 -- specified for the parent in the derived type definition. For instance: 8355 8356 -- type R (D1, D2, D3 : Int) is tagged record ... end record; 8357 -- type T1 is new R with null record; 8358 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record; 8359 8360 -- are changed into: 8361 8362 -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record 8363 -- _parent : R (D1, D2, D3); 8364 -- end record; 8365 8366 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record 8367 -- _parent : T1 (X2, 88, X1); 8368 -- end record; 8369 8370 -- The discriminants actually present in R, T1 and T2 as well as their CD, 8371 -- ORC and ICH fields are: 8372 8373 -- Discrim CD ORC ICH 8374 -- ^^^^^^^ ^^ ^^^ ^^^ 8375 -- D1 in R empty itself no 8376 -- D2 in R empty itself no 8377 -- D3 in R empty itself no 8378 8379 -- D1 in T1 D1 in R D1 in R no 8380 -- D2 in T1 D2 in R D2 in R no 8381 -- D3 in T1 D3 in R D3 in R no 8382 8383 -- X1 in T2 D3 in T1 D3 in R no 8384 -- X2 in T2 D1 in T1 D1 in R no 8385 8386 -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS 8387 -- 8388 -- Regardless of whether we dealing with a tagged or untagged type 8389 -- we will transform all derived type declarations of the form 8390 -- 8391 -- type T is new R (...) [with ...]; 8392 -- or 8393 -- subtype S is R (...); 8394 -- type T is new S [with ...]; 8395 -- into 8396 -- type BT is new R [with ...]; 8397 -- subtype T is BT (...); 8398 -- 8399 -- That is, the base derived type is constrained only if it has no 8400 -- discriminants. The reason for doing this is that GNAT's semantic model 8401 -- assumes that a base type with discriminants is unconstrained. 8402 -- 8403 -- Note that, strictly speaking, the above transformation is not always 8404 -- correct. Consider for instance the following excerpt from ACVC b34011a: 8405 -- 8406 -- procedure B34011A is 8407 -- type REC (D : integer := 0) is record 8408 -- I : Integer; 8409 -- end record; 8410 8411 -- package P is 8412 -- type T6 is new Rec; 8413 -- function F return T6; 8414 -- end P; 8415 8416 -- use P; 8417 -- package Q6 is 8418 -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F. 8419 -- end Q6; 8420 -- 8421 -- The definition of Q6.U is illegal. However transforming Q6.U into 8422 8423 -- type BaseU is new T6; 8424 -- subtype U is BaseU (Q6.F.I) 8425 8426 -- turns U into a legal subtype, which is incorrect. To avoid this problem 8427 -- we always analyze the constraint (in this case (Q6.F.I)) before applying 8428 -- the transformation described above. 8429 8430 -- There is another instance where the above transformation is incorrect. 8431 -- Consider: 8432 8433 -- package Pack is 8434 -- type Base (D : Integer) is tagged null record; 8435 -- procedure P (X : Base); 8436 8437 -- type Der is new Base (2) with null record; 8438 -- procedure P (X : Der); 8439 -- end Pack; 8440 8441 -- Then the above transformation turns this into 8442 8443 -- type Der_Base is new Base with null record; 8444 -- -- procedure P (X : Base) is implicitly inherited here 8445 -- -- as procedure P (X : Der_Base). 8446 8447 -- subtype Der is Der_Base (2); 8448 -- procedure P (X : Der); 8449 -- -- The overriding of P (X : Der_Base) is illegal since we 8450 -- -- have a parameter conformance problem. 8451 8452 -- To get around this problem, after having semantically processed Der_Base 8453 -- and the rewritten subtype declaration for Der, we copy Der_Base field 8454 -- Discriminant_Constraint from Der so that when parameter conformance is 8455 -- checked when P is overridden, no semantic errors are flagged. 8456 8457 -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS 8458 8459 -- Regardless of whether we are dealing with a tagged or untagged type 8460 -- we will transform all derived type declarations of the form 8461 8462 -- type R (D1, .., Dn : ...) is [tagged] record ...; 8463 -- type T is new R [with ...]; 8464 -- into 8465 -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...]; 8466 8467 -- The reason for such transformation is that it allows us to implement a 8468 -- very clean form of component inheritance as explained below. 8469 8470 -- Note that this transformation is not achieved by direct tree rewriting 8471 -- and manipulation, but rather by redoing the semantic actions that the 8472 -- above transformation will entail. This is done directly in routine 8473 -- Inherit_Components. 8474 8475 -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE 8476 8477 -- In both tagged and untagged derived types, regular non discriminant 8478 -- components are inherited in the derived type from the parent type. In 8479 -- the absence of discriminants component, inheritance is straightforward 8480 -- as components can simply be copied from the parent. 8481 8482 -- If the parent has discriminants, inheriting components constrained with 8483 -- these discriminants requires caution. Consider the following example: 8484 8485 -- type R (D1, D2 : Positive) is [tagged] record 8486 -- S : String (D1 .. D2); 8487 -- end record; 8488 8489 -- type T1 is new R [with null record]; 8490 -- type T2 (X : positive) is new R (1, X) [with null record]; 8491 8492 -- As explained in 6. above, T1 is rewritten as 8493 -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record]; 8494 -- which makes the treatment for T1 and T2 identical. 8495 8496 -- What we want when inheriting S, is that references to D1 and D2 in R are 8497 -- replaced with references to their correct constraints, i.e. D1 and D2 in 8498 -- T1 and 1 and X in T2. So all R's discriminant references are replaced 8499 -- with either discriminant references in the derived type or expressions. 8500 -- This replacement is achieved as follows: before inheriting R's 8501 -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is 8502 -- created in the scope of T1 (resp. scope of T2) so that discriminants D1 8503 -- and D2 of T1 are visible (resp. discriminant X of T2 is visible). 8504 -- For T2, for instance, this has the effect of replacing String (D1 .. D2) 8505 -- by String (1 .. X). 8506 8507 -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS 8508 8509 -- We explain here the rules governing private type extensions relevant to 8510 -- type derivation. These rules are explained on the following example: 8511 8512 -- type D [(...)] is new A [(...)] with private; <-- partial view 8513 -- type D [(...)] is new P [(...)] with null record; <-- full view 8514 8515 -- Type A is called the ancestor subtype of the private extension. 8516 -- Type P is the parent type of the full view of the private extension. It 8517 -- must be A or a type derived from A. 8518 8519 -- The rules concerning the discriminants of private type extensions are 8520 -- [7.3(10-13)]: 8521 8522 -- o If a private extension inherits known discriminants from the ancestor 8523 -- subtype, then the full view must also inherit its discriminants from 8524 -- the ancestor subtype and the parent subtype of the full view must be 8525 -- constrained if and only if the ancestor subtype is constrained. 8526 8527 -- o If a partial view has unknown discriminants, then the full view may 8528 -- define a definite or an indefinite subtype, with or without 8529 -- discriminants. 8530 8531 -- o If a partial view has neither known nor unknown discriminants, then 8532 -- the full view must define a definite subtype. 8533 8534 -- o If the ancestor subtype of a private extension has constrained 8535 -- discriminants, then the parent subtype of the full view must impose a 8536 -- statically matching constraint on those discriminants. 8537 8538 -- This means that only the following forms of private extensions are 8539 -- allowed: 8540 8541 -- type D is new A with private; <-- partial view 8542 -- type D is new P with null record; <-- full view 8543 8544 -- If A has no discriminants than P has no discriminants, otherwise P must 8545 -- inherit A's discriminants. 8546 8547 -- type D is new A (...) with private; <-- partial view 8548 -- type D is new P (:::) with null record; <-- full view 8549 8550 -- P must inherit A's discriminants and (...) and (:::) must statically 8551 -- match. 8552 8553 -- subtype A is R (...); 8554 -- type D is new A with private; <-- partial view 8555 -- type D is new P with null record; <-- full view 8556 8557 -- P must have inherited R's discriminants and must be derived from A or 8558 -- any of its subtypes. 8559 8560 -- type D (..) is new A with private; <-- partial view 8561 -- type D (..) is new P [(:::)] with null record; <-- full view 8562 8563 -- No specific constraints on P's discriminants or constraint (:::). 8564 -- Note that A can be unconstrained, but the parent subtype P must either 8565 -- be constrained or (:::) must be present. 8566 8567 -- type D (..) is new A [(...)] with private; <-- partial view 8568 -- type D (..) is new P [(:::)] with null record; <-- full view 8569 8570 -- P's constraints on A's discriminants must statically match those 8571 -- imposed by (...). 8572 8573 -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS 8574 8575 -- The full view of a private extension is handled exactly as described 8576 -- above. The model chose for the private view of a private extension is 8577 -- the same for what concerns discriminants (i.e. they receive the same 8578 -- treatment as in the tagged case). However, the private view of the 8579 -- private extension always inherits the components of the parent base, 8580 -- without replacing any discriminant reference. Strictly speaking this is 8581 -- incorrect. However, Gigi never uses this view to generate code so this 8582 -- is a purely semantic issue. In theory, a set of transformations similar 8583 -- to those given in 5. and 6. above could be applied to private views of 8584 -- private extensions to have the same model of component inheritance as 8585 -- for non private extensions. However, this is not done because it would 8586 -- further complicate private type processing. Semantically speaking, this 8587 -- leaves us in an uncomfortable situation. As an example consider: 8588 8589 -- package Pack is 8590 -- type R (D : integer) is tagged record 8591 -- S : String (1 .. D); 8592 -- end record; 8593 -- procedure P (X : R); 8594 -- type T is new R (1) with private; 8595 -- private 8596 -- type T is new R (1) with null record; 8597 -- end; 8598 8599 -- This is transformed into: 8600 8601 -- package Pack is 8602 -- type R (D : integer) is tagged record 8603 -- S : String (1 .. D); 8604 -- end record; 8605 -- procedure P (X : R); 8606 -- type T is new R (1) with private; 8607 -- private 8608 -- type BaseT is new R with null record; 8609 -- subtype T is BaseT (1); 8610 -- end; 8611 8612 -- (strictly speaking the above is incorrect Ada) 8613 8614 -- From the semantic standpoint the private view of private extension T 8615 -- should be flagged as constrained since one can clearly have 8616 -- 8617 -- Obj : T; 8618 -- 8619 -- in a unit withing Pack. However, when deriving subprograms for the 8620 -- private view of private extension T, T must be seen as unconstrained 8621 -- since T has discriminants (this is a constraint of the current 8622 -- subprogram derivation model). Thus, when processing the private view of 8623 -- a private extension such as T, we first mark T as unconstrained, we 8624 -- process it, we perform program derivation and just before returning from 8625 -- Build_Derived_Record_Type we mark T as constrained. 8626 8627 -- ??? Are there are other uncomfortable cases that we will have to 8628 -- deal with. 8629 8630 -- 10. RECORD_TYPE_WITH_PRIVATE complications 8631 8632 -- Types that are derived from a visible record type and have a private 8633 -- extension present other peculiarities. They behave mostly like private 8634 -- types, but if they have primitive operations defined, these will not 8635 -- have the proper signatures for further inheritance, because other 8636 -- primitive operations will use the implicit base that we define for 8637 -- private derivations below. This affect subprogram inheritance (see 8638 -- Derive_Subprograms for details). We also derive the implicit base from 8639 -- the base type of the full view, so that the implicit base is a record 8640 -- type and not another private type, This avoids infinite loops. 8641 8642 procedure Build_Derived_Record_Type 8643 (N : Node_Id; 8644 Parent_Type : Entity_Id; 8645 Derived_Type : Entity_Id; 8646 Derive_Subps : Boolean := True) 8647 is 8648 Discriminant_Specs : constant Boolean := 8649 Present (Discriminant_Specifications (N)); 8650 Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type); 8651 Loc : constant Source_Ptr := Sloc (N); 8652 Private_Extension : constant Boolean := 8653 Nkind (N) = N_Private_Extension_Declaration; 8654 Assoc_List : Elist_Id; 8655 Constraint_Present : Boolean; 8656 Constrs : Elist_Id; 8657 Discrim : Entity_Id; 8658 Indic : Node_Id; 8659 Inherit_Discrims : Boolean := False; 8660 Last_Discrim : Entity_Id; 8661 New_Base : Entity_Id; 8662 New_Decl : Node_Id; 8663 New_Discrs : Elist_Id; 8664 New_Indic : Node_Id; 8665 Parent_Base : Entity_Id; 8666 Save_Etype : Entity_Id; 8667 Save_Discr_Constr : Elist_Id; 8668 Save_Next_Entity : Entity_Id; 8669 Type_Def : Node_Id; 8670 8671 Discs : Elist_Id := New_Elmt_List; 8672 -- An empty Discs list means that there were no constraints in the 8673 -- subtype indication or that there was an error processing it. 8674 8675 procedure Check_Generic_Ancestors; 8676 -- In Ada 2005 (AI-344), the restriction that a derived tagged type 8677 -- cannot be declared at a deeper level than its parent type is 8678 -- removed. The check on derivation within a generic body is also 8679 -- relaxed, but there's a restriction that a derived tagged type 8680 -- cannot be declared in a generic body if it's derived directly 8681 -- or indirectly from a formal type of that generic. This applies 8682 -- to progenitors as well. 8683 8684 ----------------------------- 8685 -- Check_Generic_Ancestors -- 8686 ----------------------------- 8687 8688 procedure Check_Generic_Ancestors is 8689 Ancestor_Type : Entity_Id; 8690 Intf_List : List_Id; 8691 Intf_Name : Node_Id; 8692 8693 procedure Check_Ancestor; 8694 -- For parent and progenitors. 8695 8696 -------------------- 8697 -- Check_Ancestor -- 8698 -------------------- 8699 8700 procedure Check_Ancestor is 8701 begin 8702 -- If the derived type does have a formal type as an ancestor 8703 -- then it's an error if the derived type is declared within 8704 -- the body of the generic unit that declares the formal type 8705 -- in its generic formal part. It's sufficient to check whether 8706 -- the ancestor type is declared inside the same generic body 8707 -- as the derived type (such as within a nested generic spec), 8708 -- in which case the derivation is legal. If the formal type is 8709 -- declared outside of that generic body, then it's certain 8710 -- that the derived type is declared within the generic body 8711 -- of the generic unit declaring the formal type. 8712 8713 if Is_Generic_Type (Ancestor_Type) 8714 and then Enclosing_Generic_Body (Ancestor_Type) /= 8715 Enclosing_Generic_Body (Derived_Type) 8716 then 8717 Error_Msg_NE 8718 ("ancestor type& is formal type of enclosing" 8719 & " generic unit (RM 3.9.1 (4/2))", 8720 Indic, Ancestor_Type); 8721 end if; 8722 end Check_Ancestor; 8723 8724 begin 8725 if Nkind (N) = N_Private_Extension_Declaration then 8726 Intf_List := Interface_List (N); 8727 else 8728 Intf_List := Interface_List (Type_Definition (N)); 8729 end if; 8730 8731 if Present (Enclosing_Generic_Body (Derived_Type)) then 8732 Ancestor_Type := Parent_Type; 8733 8734 while not Is_Generic_Type (Ancestor_Type) 8735 and then Etype (Ancestor_Type) /= Ancestor_Type 8736 loop 8737 Ancestor_Type := Etype (Ancestor_Type); 8738 end loop; 8739 8740 Check_Ancestor; 8741 8742 if Present (Intf_List) then 8743 Intf_Name := First (Intf_List); 8744 while Present (Intf_Name) loop 8745 Ancestor_Type := Entity (Intf_Name); 8746 Check_Ancestor; 8747 Next (Intf_Name); 8748 end loop; 8749 end if; 8750 end if; 8751 end Check_Generic_Ancestors; 8752 8753 -- Start of processing for Build_Derived_Record_Type 8754 8755 begin 8756 if Ekind (Parent_Type) = E_Record_Type_With_Private 8757 and then Present (Full_View (Parent_Type)) 8758 and then Has_Discriminants (Parent_Type) 8759 then 8760 Parent_Base := Base_Type (Full_View (Parent_Type)); 8761 else 8762 Parent_Base := Base_Type (Parent_Type); 8763 end if; 8764 8765 -- If the parent type is declared as a subtype of another private 8766 -- type with inherited discriminants, its generated base type is 8767 -- itself a record subtype. To further inherit the constraint we 8768 -- need to use its own base to have an unconstrained type on which 8769 -- to apply the inherited constraint. 8770 8771 if Ekind (Parent_Base) = E_Record_Subtype then 8772 Parent_Base := Base_Type (Parent_Base); 8773 end if; 8774 8775 -- AI05-0115: if this is a derivation from a private type in some 8776 -- other scope that may lead to invisible components for the derived 8777 -- type, mark it accordingly. 8778 8779 if Is_Private_Type (Parent_Type) then 8780 if Scope (Parent_Base) = Scope (Derived_Type) then 8781 null; 8782 8783 elsif In_Open_Scopes (Scope (Parent_Base)) 8784 and then In_Private_Part (Scope (Parent_Base)) 8785 then 8786 null; 8787 8788 else 8789 Set_Has_Private_Ancestor (Derived_Type); 8790 end if; 8791 8792 else 8793 Set_Has_Private_Ancestor 8794 (Derived_Type, Has_Private_Ancestor (Parent_Type)); 8795 end if; 8796 8797 -- Before we start the previously documented transformations, here is 8798 -- little fix for size and alignment of tagged types. Normally when we 8799 -- derive type D from type P, we copy the size and alignment of P as the 8800 -- default for D, and in the absence of explicit representation clauses 8801 -- for D, the size and alignment are indeed the same as the parent. 8802 8803 -- But this is wrong for tagged types, since fields may be added, and 8804 -- the default size may need to be larger, and the default alignment may 8805 -- need to be larger. 8806 8807 -- We therefore reset the size and alignment fields in the tagged case. 8808 -- Note that the size and alignment will in any case be at least as 8809 -- large as the parent type (since the derived type has a copy of the 8810 -- parent type in the _parent field) 8811 8812 -- The type is also marked as being tagged here, which is needed when 8813 -- processing components with a self-referential anonymous access type 8814 -- in the call to Check_Anonymous_Access_Components below. Note that 8815 -- this flag is also set later on for completeness. 8816 8817 if Is_Tagged then 8818 Set_Is_Tagged_Type (Derived_Type); 8819 Init_Size_Align (Derived_Type); 8820 end if; 8821 8822 -- STEP 0a: figure out what kind of derived type declaration we have 8823 8824 if Private_Extension then 8825 Type_Def := N; 8826 Set_Ekind (Derived_Type, E_Record_Type_With_Private); 8827 Set_Default_SSO (Derived_Type); 8828 Set_No_Reordering (Derived_Type, No_Component_Reordering); 8829 8830 else 8831 Type_Def := Type_Definition (N); 8832 8833 -- Ekind (Parent_Base) is not necessarily E_Record_Type since 8834 -- Parent_Base can be a private type or private extension. However, 8835 -- for tagged types with an extension the newly added fields are 8836 -- visible and hence the Derived_Type is always an E_Record_Type. 8837 -- (except that the parent may have its own private fields). 8838 -- For untagged types we preserve the Ekind of the Parent_Base. 8839 8840 if Present (Record_Extension_Part (Type_Def)) then 8841 Set_Ekind (Derived_Type, E_Record_Type); 8842 Set_Default_SSO (Derived_Type); 8843 Set_No_Reordering (Derived_Type, No_Component_Reordering); 8844 8845 -- Create internal access types for components with anonymous 8846 -- access types. 8847 8848 if Ada_Version >= Ada_2005 then 8849 Check_Anonymous_Access_Components 8850 (N, Derived_Type, Derived_Type, 8851 Component_List (Record_Extension_Part (Type_Def))); 8852 end if; 8853 8854 else 8855 Set_Ekind (Derived_Type, Ekind (Parent_Base)); 8856 end if; 8857 end if; 8858 8859 -- Indic can either be an N_Identifier if the subtype indication 8860 -- contains no constraint or an N_Subtype_Indication if the subtype 8861 -- indication has a constraint. In either case it can include an 8862 -- interface list. 8863 8864 Indic := Subtype_Indication (Type_Def); 8865 Constraint_Present := (Nkind (Indic) = N_Subtype_Indication); 8866 8867 -- Check that the type has visible discriminants. The type may be 8868 -- a private type with unknown discriminants whose full view has 8869 -- discriminants which are invisible. 8870 8871 if Constraint_Present then 8872 if not Has_Discriminants (Parent_Base) 8873 or else 8874 (Has_Unknown_Discriminants (Parent_Base) 8875 and then Is_Private_Type (Parent_Base)) 8876 then 8877 Error_Msg_N 8878 ("invalid constraint: type has no discriminant", 8879 Constraint (Indic)); 8880 8881 Constraint_Present := False; 8882 Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic))); 8883 8884 elsif Is_Constrained (Parent_Type) then 8885 Error_Msg_N 8886 ("invalid constraint: parent type is already constrained", 8887 Constraint (Indic)); 8888 8889 Constraint_Present := False; 8890 Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic))); 8891 end if; 8892 end if; 8893 8894 -- STEP 0b: If needed, apply transformation given in point 5. above 8895 8896 if not Private_Extension 8897 and then Has_Discriminants (Parent_Type) 8898 and then not Discriminant_Specs 8899 and then (Is_Constrained (Parent_Type) or else Constraint_Present) 8900 then 8901 -- First, we must analyze the constraint (see comment in point 5.) 8902 -- The constraint may come from the subtype indication of the full 8903 -- declaration. 8904 8905 if Constraint_Present then 8906 New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic); 8907 8908 -- If there is no explicit constraint, there might be one that is 8909 -- inherited from a constrained parent type. In that case verify that 8910 -- it conforms to the constraint in the partial view. In perverse 8911 -- cases the parent subtypes of the partial and full view can have 8912 -- different constraints. 8913 8914 elsif Present (Stored_Constraint (Parent_Type)) then 8915 New_Discrs := Stored_Constraint (Parent_Type); 8916 8917 else 8918 New_Discrs := No_Elist; 8919 end if; 8920 8921 if Has_Discriminants (Derived_Type) 8922 and then Has_Private_Declaration (Derived_Type) 8923 and then Present (Discriminant_Constraint (Derived_Type)) 8924 and then Present (New_Discrs) 8925 then 8926 -- Verify that constraints of the full view statically match 8927 -- those given in the partial view. 8928 8929 declare 8930 C1, C2 : Elmt_Id; 8931 8932 begin 8933 C1 := First_Elmt (New_Discrs); 8934 C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); 8935 while Present (C1) and then Present (C2) loop 8936 if Fully_Conformant_Expressions (Node (C1), Node (C2)) 8937 or else 8938 (Is_OK_Static_Expression (Node (C1)) 8939 and then Is_OK_Static_Expression (Node (C2)) 8940 and then 8941 Expr_Value (Node (C1)) = Expr_Value (Node (C2))) 8942 then 8943 null; 8944 8945 else 8946 if Constraint_Present then 8947 Error_Msg_N 8948 ("constraint not conformant to previous declaration", 8949 Node (C1)); 8950 else 8951 Error_Msg_N 8952 ("constraint of full view is incompatible " 8953 & "with partial view", N); 8954 end if; 8955 end if; 8956 8957 Next_Elmt (C1); 8958 Next_Elmt (C2); 8959 end loop; 8960 end; 8961 end if; 8962 8963 -- Insert and analyze the declaration for the unconstrained base type 8964 8965 New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B'); 8966 8967 New_Decl := 8968 Make_Full_Type_Declaration (Loc, 8969 Defining_Identifier => New_Base, 8970 Type_Definition => 8971 Make_Derived_Type_Definition (Loc, 8972 Abstract_Present => Abstract_Present (Type_Def), 8973 Limited_Present => Limited_Present (Type_Def), 8974 Subtype_Indication => 8975 New_Occurrence_Of (Parent_Base, Loc), 8976 Record_Extension_Part => 8977 Relocate_Node (Record_Extension_Part (Type_Def)), 8978 Interface_List => Interface_List (Type_Def))); 8979 8980 Set_Parent (New_Decl, Parent (N)); 8981 Mark_Rewrite_Insertion (New_Decl); 8982 Insert_Before (N, New_Decl); 8983 8984 -- In the extension case, make sure ancestor is frozen appropriately 8985 -- (see also non-discriminated case below). 8986 8987 if Present (Record_Extension_Part (Type_Def)) 8988 or else Is_Interface (Parent_Base) 8989 then 8990 Freeze_Before (New_Decl, Parent_Type); 8991 end if; 8992 8993 -- Note that this call passes False for the Derive_Subps parameter 8994 -- because subprogram derivation is deferred until after creating 8995 -- the subtype (see below). 8996 8997 Build_Derived_Type 8998 (New_Decl, Parent_Base, New_Base, 8999 Is_Completion => False, Derive_Subps => False); 9000 9001 -- ??? This needs re-examination to determine whether the 9002 -- above call can simply be replaced by a call to Analyze. 9003 9004 Set_Analyzed (New_Decl); 9005 9006 -- Insert and analyze the declaration for the constrained subtype 9007 9008 if Constraint_Present then 9009 New_Indic := 9010 Make_Subtype_Indication (Loc, 9011 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 9012 Constraint => Relocate_Node (Constraint (Indic))); 9013 9014 else 9015 declare 9016 Constr_List : constant List_Id := New_List; 9017 C : Elmt_Id; 9018 Expr : Node_Id; 9019 9020 begin 9021 C := First_Elmt (Discriminant_Constraint (Parent_Type)); 9022 while Present (C) loop 9023 Expr := Node (C); 9024 9025 -- It is safe here to call New_Copy_Tree since we called 9026 -- Force_Evaluation on each constraint previously 9027 -- in Build_Discriminant_Constraints. 9028 9029 Append (New_Copy_Tree (Expr), To => Constr_List); 9030 9031 Next_Elmt (C); 9032 end loop; 9033 9034 New_Indic := 9035 Make_Subtype_Indication (Loc, 9036 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 9037 Constraint => 9038 Make_Index_Or_Discriminant_Constraint (Loc, Constr_List)); 9039 end; 9040 end if; 9041 9042 Rewrite (N, 9043 Make_Subtype_Declaration (Loc, 9044 Defining_Identifier => Derived_Type, 9045 Subtype_Indication => New_Indic)); 9046 9047 Analyze (N); 9048 9049 -- Derivation of subprograms must be delayed until the full subtype 9050 -- has been established, to ensure proper overriding of subprograms 9051 -- inherited by full types. If the derivations occurred as part of 9052 -- the call to Build_Derived_Type above, then the check for type 9053 -- conformance would fail because earlier primitive subprograms 9054 -- could still refer to the full type prior the change to the new 9055 -- subtype and hence would not match the new base type created here. 9056 -- Subprograms are not derived, however, when Derive_Subps is False 9057 -- (since otherwise there could be redundant derivations). 9058 9059 if Derive_Subps then 9060 Derive_Subprograms (Parent_Type, Derived_Type); 9061 end if; 9062 9063 -- For tagged types the Discriminant_Constraint of the new base itype 9064 -- is inherited from the first subtype so that no subtype conformance 9065 -- problem arise when the first subtype overrides primitive 9066 -- operations inherited by the implicit base type. 9067 9068 if Is_Tagged then 9069 Set_Discriminant_Constraint 9070 (New_Base, Discriminant_Constraint (Derived_Type)); 9071 end if; 9072 9073 return; 9074 end if; 9075 9076 -- If we get here Derived_Type will have no discriminants or it will be 9077 -- a discriminated unconstrained base type. 9078 9079 -- STEP 1a: perform preliminary actions/checks for derived tagged types 9080 9081 if Is_Tagged then 9082 9083 -- The parent type is frozen for non-private extensions (RM 13.14(7)) 9084 -- The declaration of a specific descendant of an interface type 9085 -- freezes the interface type (RM 13.14). 9086 9087 if not Private_Extension or else Is_Interface (Parent_Base) then 9088 Freeze_Before (N, Parent_Type); 9089 end if; 9090 9091 if Ada_Version >= Ada_2005 then 9092 Check_Generic_Ancestors; 9093 9094 elsif Type_Access_Level (Derived_Type) /= 9095 Type_Access_Level (Parent_Type) 9096 and then not Is_Generic_Type (Derived_Type) 9097 then 9098 if Is_Controlled (Parent_Type) then 9099 Error_Msg_N 9100 ("controlled type must be declared at the library level", 9101 Indic); 9102 else 9103 Error_Msg_N 9104 ("type extension at deeper accessibility level than parent", 9105 Indic); 9106 end if; 9107 9108 else 9109 declare 9110 GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type); 9111 begin 9112 if Present (GB) 9113 and then GB /= Enclosing_Generic_Body (Parent_Base) 9114 then 9115 Error_Msg_NE 9116 ("parent type of& must not be outside generic body" 9117 & " (RM 3.9.1(4))", 9118 Indic, Derived_Type); 9119 end if; 9120 end; 9121 end if; 9122 end if; 9123 9124 -- Ada 2005 (AI-251) 9125 9126 if Ada_Version >= Ada_2005 and then Is_Tagged then 9127 9128 -- "The declaration of a specific descendant of an interface type 9129 -- freezes the interface type" (RM 13.14). 9130 9131 declare 9132 Iface : Node_Id; 9133 begin 9134 if Is_Non_Empty_List (Interface_List (Type_Def)) then 9135 Iface := First (Interface_List (Type_Def)); 9136 while Present (Iface) loop 9137 Freeze_Before (N, Etype (Iface)); 9138 Next (Iface); 9139 end loop; 9140 end if; 9141 end; 9142 end if; 9143 9144 -- STEP 1b : preliminary cleanup of the full view of private types 9145 9146 -- If the type is already marked as having discriminants, then it's the 9147 -- completion of a private type or private extension and we need to 9148 -- retain the discriminants from the partial view if the current 9149 -- declaration has Discriminant_Specifications so that we can verify 9150 -- conformance. However, we must remove any existing components that 9151 -- were inherited from the parent (and attached in Copy_And_Swap) 9152 -- because the full type inherits all appropriate components anyway, and 9153 -- we do not want the partial view's components interfering. 9154 9155 if Has_Discriminants (Derived_Type) and then Discriminant_Specs then 9156 Discrim := First_Discriminant (Derived_Type); 9157 loop 9158 Last_Discrim := Discrim; 9159 Next_Discriminant (Discrim); 9160 exit when No (Discrim); 9161 end loop; 9162 9163 Set_Last_Entity (Derived_Type, Last_Discrim); 9164 9165 -- In all other cases wipe out the list of inherited components (even 9166 -- inherited discriminants), it will be properly rebuilt here. 9167 9168 else 9169 Set_First_Entity (Derived_Type, Empty); 9170 Set_Last_Entity (Derived_Type, Empty); 9171 end if; 9172 9173 -- STEP 1c: Initialize some flags for the Derived_Type 9174 9175 -- The following flags must be initialized here so that 9176 -- Process_Discriminants can check that discriminants of tagged types do 9177 -- not have a default initial value and that access discriminants are 9178 -- only specified for limited records. For completeness, these flags are 9179 -- also initialized along with all the other flags below. 9180 9181 -- AI-419: Limitedness is not inherited from an interface parent, so to 9182 -- be limited in that case the type must be explicitly declared as 9183 -- limited. However, task and protected interfaces are always limited. 9184 9185 if Limited_Present (Type_Def) then 9186 Set_Is_Limited_Record (Derived_Type); 9187 9188 elsif Is_Limited_Record (Parent_Type) 9189 or else (Present (Full_View (Parent_Type)) 9190 and then Is_Limited_Record (Full_View (Parent_Type))) 9191 then 9192 if not Is_Interface (Parent_Type) 9193 or else Is_Synchronized_Interface (Parent_Type) 9194 or else Is_Protected_Interface (Parent_Type) 9195 or else Is_Task_Interface (Parent_Type) 9196 then 9197 Set_Is_Limited_Record (Derived_Type); 9198 end if; 9199 end if; 9200 9201 -- STEP 2a: process discriminants of derived type if any 9202 9203 Push_Scope (Derived_Type); 9204 9205 if Discriminant_Specs then 9206 Set_Has_Unknown_Discriminants (Derived_Type, False); 9207 9208 -- The following call initializes fields Has_Discriminants and 9209 -- Discriminant_Constraint, unless we are processing the completion 9210 -- of a private type declaration. 9211 9212 Check_Or_Process_Discriminants (N, Derived_Type); 9213 9214 -- For untagged types, the constraint on the Parent_Type must be 9215 -- present and is used to rename the discriminants. 9216 9217 if not Is_Tagged and then not Has_Discriminants (Parent_Type) then 9218 Error_Msg_N ("untagged parent must have discriminants", Indic); 9219 9220 elsif not Is_Tagged and then not Constraint_Present then 9221 Error_Msg_N 9222 ("discriminant constraint needed for derived untagged records", 9223 Indic); 9224 9225 -- Otherwise the parent subtype must be constrained unless we have a 9226 -- private extension. 9227 9228 elsif not Constraint_Present 9229 and then not Private_Extension 9230 and then not Is_Constrained (Parent_Type) 9231 then 9232 Error_Msg_N 9233 ("unconstrained type not allowed in this context", Indic); 9234 9235 elsif Constraint_Present then 9236 -- The following call sets the field Corresponding_Discriminant 9237 -- for the discriminants in the Derived_Type. 9238 9239 Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True); 9240 9241 -- For untagged types all new discriminants must rename 9242 -- discriminants in the parent. For private extensions new 9243 -- discriminants cannot rename old ones (implied by [7.3(13)]). 9244 9245 Discrim := First_Discriminant (Derived_Type); 9246 while Present (Discrim) loop 9247 if not Is_Tagged 9248 and then No (Corresponding_Discriminant (Discrim)) 9249 then 9250 Error_Msg_N 9251 ("new discriminants must constrain old ones", Discrim); 9252 9253 elsif Private_Extension 9254 and then Present (Corresponding_Discriminant (Discrim)) 9255 then 9256 Error_Msg_N 9257 ("only static constraints allowed for parent" 9258 & " discriminants in the partial view", Indic); 9259 exit; 9260 end if; 9261 9262 -- If a new discriminant is used in the constraint, then its 9263 -- subtype must be statically compatible with the parent 9264 -- discriminant's subtype (3.7(15)). 9265 9266 -- However, if the record contains an array constrained by 9267 -- the discriminant but with some different bound, the compiler 9268 -- tries to create a smaller range for the discriminant type. 9269 -- (See exp_ch3.Adjust_Discriminants). In this case, where 9270 -- the discriminant type is a scalar type, the check must use 9271 -- the original discriminant type in the parent declaration. 9272 9273 declare 9274 Corr_Disc : constant Entity_Id := 9275 Corresponding_Discriminant (Discrim); 9276 Disc_Type : constant Entity_Id := Etype (Discrim); 9277 Corr_Type : Entity_Id; 9278 9279 begin 9280 if Present (Corr_Disc) then 9281 if Is_Scalar_Type (Disc_Type) then 9282 Corr_Type := 9283 Entity (Discriminant_Type (Parent (Corr_Disc))); 9284 else 9285 Corr_Type := Etype (Corr_Disc); 9286 end if; 9287 9288 if not 9289 Subtypes_Statically_Compatible (Disc_Type, Corr_Type) 9290 then 9291 Error_Msg_N 9292 ("subtype must be compatible " 9293 & "with parent discriminant", 9294 Discrim); 9295 end if; 9296 end if; 9297 end; 9298 9299 Next_Discriminant (Discrim); 9300 end loop; 9301 9302 -- Check whether the constraints of the full view statically 9303 -- match those imposed by the parent subtype [7.3(13)]. 9304 9305 if Present (Stored_Constraint (Derived_Type)) then 9306 declare 9307 C1, C2 : Elmt_Id; 9308 9309 begin 9310 C1 := First_Elmt (Discs); 9311 C2 := First_Elmt (Stored_Constraint (Derived_Type)); 9312 while Present (C1) and then Present (C2) loop 9313 if not 9314 Fully_Conformant_Expressions (Node (C1), Node (C2)) 9315 then 9316 Error_Msg_N 9317 ("not conformant with previous declaration", 9318 Node (C1)); 9319 end if; 9320 9321 Next_Elmt (C1); 9322 Next_Elmt (C2); 9323 end loop; 9324 end; 9325 end if; 9326 end if; 9327 9328 -- STEP 2b: No new discriminants, inherit discriminants if any 9329 9330 else 9331 if Private_Extension then 9332 Set_Has_Unknown_Discriminants 9333 (Derived_Type, 9334 Has_Unknown_Discriminants (Parent_Type) 9335 or else Unknown_Discriminants_Present (N)); 9336 9337 -- The partial view of the parent may have unknown discriminants, 9338 -- but if the full view has discriminants and the parent type is 9339 -- in scope they must be inherited. 9340 9341 elsif Has_Unknown_Discriminants (Parent_Type) 9342 and then 9343 (not Has_Discriminants (Parent_Type) 9344 or else not In_Open_Scopes (Scope (Parent_Base))) 9345 then 9346 Set_Has_Unknown_Discriminants (Derived_Type); 9347 end if; 9348 9349 if not Has_Unknown_Discriminants (Derived_Type) 9350 and then not Has_Unknown_Discriminants (Parent_Base) 9351 and then Has_Discriminants (Parent_Type) 9352 then 9353 Inherit_Discrims := True; 9354 Set_Has_Discriminants 9355 (Derived_Type, True); 9356 Set_Discriminant_Constraint 9357 (Derived_Type, Discriminant_Constraint (Parent_Base)); 9358 end if; 9359 9360 -- The following test is true for private types (remember 9361 -- transformation 5. is not applied to those) and in an error 9362 -- situation. 9363 9364 if Constraint_Present then 9365 Discs := Build_Discriminant_Constraints (Parent_Type, Indic); 9366 end if; 9367 9368 -- For now mark a new derived type as constrained only if it has no 9369 -- discriminants. At the end of Build_Derived_Record_Type we properly 9370 -- set this flag in the case of private extensions. See comments in 9371 -- point 9. just before body of Build_Derived_Record_Type. 9372 9373 Set_Is_Constrained 9374 (Derived_Type, 9375 not (Inherit_Discrims 9376 or else Has_Unknown_Discriminants (Derived_Type))); 9377 end if; 9378 9379 -- STEP 3: initialize fields of derived type 9380 9381 Set_Is_Tagged_Type (Derived_Type, Is_Tagged); 9382 Set_Stored_Constraint (Derived_Type, No_Elist); 9383 9384 -- Ada 2005 (AI-251): Private type-declarations can implement interfaces 9385 -- but cannot be interfaces 9386 9387 if not Private_Extension 9388 and then Ekind (Derived_Type) /= E_Private_Type 9389 and then Ekind (Derived_Type) /= E_Limited_Private_Type 9390 then 9391 if Interface_Present (Type_Def) then 9392 Analyze_Interface_Declaration (Derived_Type, Type_Def); 9393 end if; 9394 9395 Set_Interfaces (Derived_Type, No_Elist); 9396 end if; 9397 9398 -- Fields inherited from the Parent_Type 9399 9400 Set_Has_Specified_Layout 9401 (Derived_Type, Has_Specified_Layout (Parent_Type)); 9402 Set_Is_Limited_Composite 9403 (Derived_Type, Is_Limited_Composite (Parent_Type)); 9404 Set_Is_Private_Composite 9405 (Derived_Type, Is_Private_Composite (Parent_Type)); 9406 9407 if Is_Tagged_Type (Parent_Type) then 9408 Set_No_Tagged_Streams_Pragma 9409 (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type)); 9410 end if; 9411 9412 -- Fields inherited from the Parent_Base 9413 9414 Set_Has_Controlled_Component 9415 (Derived_Type, Has_Controlled_Component (Parent_Base)); 9416 Set_Has_Non_Standard_Rep 9417 (Derived_Type, Has_Non_Standard_Rep (Parent_Base)); 9418 Set_Has_Primitive_Operations 9419 (Derived_Type, Has_Primitive_Operations (Parent_Base)); 9420 9421 -- Set fields for private derived types 9422 9423 if Is_Private_Type (Derived_Type) then 9424 Set_Depends_On_Private (Derived_Type, True); 9425 Set_Private_Dependents (Derived_Type, New_Elmt_List); 9426 end if; 9427 9428 -- Inherit fields for non-private types. If this is the completion of a 9429 -- derivation from a private type, the parent itself is private and the 9430 -- attributes come from its full view, which must be present. 9431 9432 if Is_Record_Type (Derived_Type) then 9433 declare 9434 Parent_Full : Entity_Id; 9435 9436 begin 9437 if Is_Private_Type (Parent_Base) 9438 and then not Is_Record_Type (Parent_Base) 9439 then 9440 Parent_Full := Full_View (Parent_Base); 9441 else 9442 Parent_Full := Parent_Base; 9443 end if; 9444 9445 Set_Component_Alignment 9446 (Derived_Type, Component_Alignment (Parent_Full)); 9447 Set_C_Pass_By_Copy 9448 (Derived_Type, C_Pass_By_Copy (Parent_Full)); 9449 Set_Has_Complex_Representation 9450 (Derived_Type, Has_Complex_Representation (Parent_Full)); 9451 9452 -- For untagged types, inherit the layout by default to avoid 9453 -- costly changes of representation for type conversions. 9454 9455 if not Is_Tagged then 9456 Set_Is_Packed (Derived_Type, Is_Packed (Parent_Full)); 9457 Set_No_Reordering (Derived_Type, No_Reordering (Parent_Full)); 9458 end if; 9459 end; 9460 end if; 9461 9462 -- Set fields for tagged types 9463 9464 if Is_Tagged then 9465 Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); 9466 9467 -- All tagged types defined in Ada.Finalization are controlled 9468 9469 if Chars (Scope (Derived_Type)) = Name_Finalization 9470 and then Chars (Scope (Scope (Derived_Type))) = Name_Ada 9471 and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard 9472 then 9473 Set_Is_Controlled_Active (Derived_Type); 9474 else 9475 Set_Is_Controlled_Active 9476 (Derived_Type, Is_Controlled_Active (Parent_Base)); 9477 end if; 9478 9479 -- Minor optimization: there is no need to generate the class-wide 9480 -- entity associated with an underlying record view. 9481 9482 if not Is_Underlying_Record_View (Derived_Type) then 9483 Make_Class_Wide_Type (Derived_Type); 9484 end if; 9485 9486 Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def)); 9487 9488 if Has_Discriminants (Derived_Type) 9489 and then Constraint_Present 9490 then 9491 Set_Stored_Constraint 9492 (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs)); 9493 end if; 9494 9495 if Ada_Version >= Ada_2005 then 9496 declare 9497 Ifaces_List : Elist_Id; 9498 9499 begin 9500 -- Checks rules 3.9.4 (13/2 and 14/2) 9501 9502 if Comes_From_Source (Derived_Type) 9503 and then not Is_Private_Type (Derived_Type) 9504 and then Is_Interface (Parent_Type) 9505 and then not Is_Interface (Derived_Type) 9506 then 9507 if Is_Task_Interface (Parent_Type) then 9508 Error_Msg_N 9509 ("(Ada 2005) task type required (RM 3.9.4 (13.2))", 9510 Derived_Type); 9511 9512 elsif Is_Protected_Interface (Parent_Type) then 9513 Error_Msg_N 9514 ("(Ada 2005) protected type required (RM 3.9.4 (14.2))", 9515 Derived_Type); 9516 end if; 9517 end if; 9518 9519 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) 9520 9521 Check_Interfaces (N, Type_Def); 9522 9523 -- Ada 2005 (AI-251): Collect the list of progenitors that are 9524 -- not already in the parents. 9525 9526 Collect_Interfaces 9527 (T => Derived_Type, 9528 Ifaces_List => Ifaces_List, 9529 Exclude_Parents => True); 9530 9531 Set_Interfaces (Derived_Type, Ifaces_List); 9532 9533 -- If the derived type is the anonymous type created for 9534 -- a declaration whose parent has a constraint, propagate 9535 -- the interface list to the source type. This must be done 9536 -- prior to the completion of the analysis of the source type 9537 -- because the components in the extension may contain current 9538 -- instances whose legality depends on some ancestor. 9539 9540 if Is_Itype (Derived_Type) then 9541 declare 9542 Def : constant Node_Id := 9543 Associated_Node_For_Itype (Derived_Type); 9544 begin 9545 if Present (Def) 9546 and then Nkind (Def) = N_Full_Type_Declaration 9547 then 9548 Set_Interfaces 9549 (Defining_Identifier (Def), Ifaces_List); 9550 end if; 9551 end; 9552 end if; 9553 9554 -- A type extension is automatically Ghost when one of its 9555 -- progenitors is Ghost (SPARK RM 6.9(9)). This property is 9556 -- also inherited when the parent type is Ghost, but this is 9557 -- done in Build_Derived_Type as the mechanism also handles 9558 -- untagged derivations. 9559 9560 if Implements_Ghost_Interface (Derived_Type) then 9561 Set_Is_Ghost_Entity (Derived_Type); 9562 end if; 9563 end; 9564 end if; 9565 end if; 9566 9567 -- STEP 4: Inherit components from the parent base and constrain them. 9568 -- Apply the second transformation described in point 6. above. 9569 9570 if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims) 9571 or else not Has_Discriminants (Parent_Type) 9572 or else not Is_Constrained (Parent_Type) 9573 then 9574 Constrs := Discs; 9575 else 9576 Constrs := Discriminant_Constraint (Parent_Type); 9577 end if; 9578 9579 Assoc_List := 9580 Inherit_Components 9581 (N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs); 9582 9583 -- STEP 5a: Copy the parent record declaration for untagged types 9584 9585 Set_Has_Implicit_Dereference 9586 (Derived_Type, Has_Implicit_Dereference (Parent_Type)); 9587 9588 if not Is_Tagged then 9589 9590 -- Discriminant_Constraint (Derived_Type) has been properly 9591 -- constructed. Save it and temporarily set it to Empty because we 9592 -- do not want the call to New_Copy_Tree below to mess this list. 9593 9594 if Has_Discriminants (Derived_Type) then 9595 Save_Discr_Constr := Discriminant_Constraint (Derived_Type); 9596 Set_Discriminant_Constraint (Derived_Type, No_Elist); 9597 else 9598 Save_Discr_Constr := No_Elist; 9599 end if; 9600 9601 -- Save the Etype field of Derived_Type. It is correctly set now, 9602 -- but the call to New_Copy tree may remap it to point to itself, 9603 -- which is not what we want. Ditto for the Next_Entity field. 9604 9605 Save_Etype := Etype (Derived_Type); 9606 Save_Next_Entity := Next_Entity (Derived_Type); 9607 9608 -- Assoc_List maps all stored discriminants in the Parent_Base to 9609 -- stored discriminants in the Derived_Type. It is fundamental that 9610 -- no types or itypes with discriminants other than the stored 9611 -- discriminants appear in the entities declared inside 9612 -- Derived_Type, since the back end cannot deal with it. 9613 9614 New_Decl := 9615 New_Copy_Tree 9616 (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc); 9617 Copy_Dimensions_Of_Components (Derived_Type); 9618 9619 -- Restore the fields saved prior to the New_Copy_Tree call 9620 -- and compute the stored constraint. 9621 9622 Set_Etype (Derived_Type, Save_Etype); 9623 Link_Entities (Derived_Type, Save_Next_Entity); 9624 9625 if Has_Discriminants (Derived_Type) then 9626 Set_Discriminant_Constraint 9627 (Derived_Type, Save_Discr_Constr); 9628 Set_Stored_Constraint 9629 (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs)); 9630 9631 Replace_Components (Derived_Type, New_Decl); 9632 end if; 9633 9634 -- Insert the new derived type declaration 9635 9636 Rewrite (N, New_Decl); 9637 9638 -- STEP 5b: Complete the processing for record extensions in generics 9639 9640 -- There is no completion for record extensions declared in the 9641 -- parameter part of a generic, so we need to complete processing for 9642 -- these generic record extensions here. The Record_Type_Definition call 9643 -- will change the Ekind of the components from E_Void to E_Component. 9644 9645 elsif Private_Extension and then Is_Generic_Type (Derived_Type) then 9646 Record_Type_Definition (Empty, Derived_Type); 9647 9648 -- STEP 5c: Process the record extension for non private tagged types 9649 9650 elsif not Private_Extension then 9651 Expand_Record_Extension (Derived_Type, Type_Def); 9652 9653 -- Note : previously in ASIS mode we set the Parent_Subtype of the 9654 -- derived type to propagate some semantic information. This led 9655 -- to other ASIS failures and has been removed. 9656 9657 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the 9658 -- implemented interfaces if we are in expansion mode 9659 9660 if Expander_Active 9661 and then Has_Interfaces (Derived_Type) 9662 then 9663 Add_Interface_Tag_Components (N, Derived_Type); 9664 end if; 9665 9666 -- Analyze the record extension 9667 9668 Record_Type_Definition 9669 (Record_Extension_Part (Type_Def), Derived_Type); 9670 end if; 9671 9672 End_Scope; 9673 9674 -- Nothing else to do if there is an error in the derivation. 9675 -- An unusual case: the full view may be derived from a type in an 9676 -- instance, when the partial view was used illegally as an actual 9677 -- in that instance, leading to a circular definition. 9678 9679 if Etype (Derived_Type) = Any_Type 9680 or else Etype (Parent_Type) = Derived_Type 9681 then 9682 return; 9683 end if; 9684 9685 -- Set delayed freeze and then derive subprograms, we need to do 9686 -- this in this order so that derived subprograms inherit the 9687 -- derived freeze if necessary. 9688 9689 Set_Has_Delayed_Freeze (Derived_Type); 9690 9691 if Derive_Subps then 9692 Derive_Subprograms (Parent_Type, Derived_Type); 9693 end if; 9694 9695 -- If we have a private extension which defines a constrained derived 9696 -- type mark as constrained here after we have derived subprograms. See 9697 -- comment on point 9. just above the body of Build_Derived_Record_Type. 9698 9699 if Private_Extension and then Inherit_Discrims then 9700 if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then 9701 Set_Is_Constrained (Derived_Type, True); 9702 Set_Discriminant_Constraint (Derived_Type, Discs); 9703 9704 elsif Is_Constrained (Parent_Type) then 9705 Set_Is_Constrained 9706 (Derived_Type, True); 9707 Set_Discriminant_Constraint 9708 (Derived_Type, Discriminant_Constraint (Parent_Type)); 9709 end if; 9710 end if; 9711 9712 -- Update the class-wide type, which shares the now-completed entity 9713 -- list with its specific type. In case of underlying record views, 9714 -- we do not generate the corresponding class wide entity. 9715 9716 if Is_Tagged 9717 and then not Is_Underlying_Record_View (Derived_Type) 9718 then 9719 Set_First_Entity 9720 (Class_Wide_Type (Derived_Type), First_Entity (Derived_Type)); 9721 Set_Last_Entity 9722 (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type)); 9723 end if; 9724 9725 Check_Function_Writable_Actuals (N); 9726 end Build_Derived_Record_Type; 9727 9728 ------------------------ 9729 -- Build_Derived_Type -- 9730 ------------------------ 9731 9732 procedure Build_Derived_Type 9733 (N : Node_Id; 9734 Parent_Type : Entity_Id; 9735 Derived_Type : Entity_Id; 9736 Is_Completion : Boolean; 9737 Derive_Subps : Boolean := True) 9738 is 9739 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 9740 9741 begin 9742 -- Set common attributes 9743 9744 Set_Scope (Derived_Type, Current_Scope); 9745 Set_Etype (Derived_Type, Parent_Base); 9746 Set_Ekind (Derived_Type, Ekind (Parent_Base)); 9747 Propagate_Concurrent_Flags (Derived_Type, Parent_Base); 9748 9749 Set_Size_Info (Derived_Type, Parent_Type); 9750 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 9751 9752 Set_Is_Controlled_Active 9753 (Derived_Type, Is_Controlled_Active (Parent_Type)); 9754 9755 Set_Disable_Controlled (Derived_Type, Disable_Controlled (Parent_Type)); 9756 Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); 9757 Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type)); 9758 9759 if Is_Tagged_Type (Derived_Type) then 9760 Set_No_Tagged_Streams_Pragma 9761 (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type)); 9762 end if; 9763 9764 -- If the parent has primitive routines and may have not-seen-yet aspect 9765 -- specifications (e.g., a Pack pragma), then set the derived type link 9766 -- in order to later diagnose "early derivation" issues. If in different 9767 -- compilation units, then "early derivation" cannot be an issue (and we 9768 -- don't like interunit references that go in the opposite direction of 9769 -- semantic dependencies). 9770 9771 if Has_Primitive_Operations (Parent_Type) 9772 and then Enclosing_Comp_Unit_Node (Parent_Type) = 9773 Enclosing_Comp_Unit_Node (Derived_Type) 9774 then 9775 Set_Derived_Type_Link (Parent_Base, Derived_Type); 9776 end if; 9777 9778 -- If the parent type is a private subtype, the convention on the base 9779 -- type may be set in the private part, and not propagated to the 9780 -- subtype until later, so we obtain the convention from the base type. 9781 9782 Set_Convention (Derived_Type, Convention (Parent_Base)); 9783 9784 -- Set SSO default for record or array type 9785 9786 if (Is_Array_Type (Derived_Type) or else Is_Record_Type (Derived_Type)) 9787 and then Is_Base_Type (Derived_Type) 9788 then 9789 Set_Default_SSO (Derived_Type); 9790 end if; 9791 9792 -- A derived type inherits the Default_Initial_Condition pragma coming 9793 -- from any parent type within the derivation chain. 9794 9795 if Has_DIC (Parent_Type) then 9796 Set_Has_Inherited_DIC (Derived_Type); 9797 end if; 9798 9799 -- A derived type inherits any class-wide invariants coming from a 9800 -- parent type or an interface. Note that the invariant procedure of 9801 -- the parent type should not be inherited because the derived type may 9802 -- define invariants of its own. 9803 9804 if not Is_Interface (Derived_Type) then 9805 if Has_Inherited_Invariants (Parent_Type) 9806 or else Has_Inheritable_Invariants (Parent_Type) 9807 then 9808 Set_Has_Inherited_Invariants (Derived_Type); 9809 9810 elsif Is_Concurrent_Type (Derived_Type) 9811 or else Is_Tagged_Type (Derived_Type) 9812 then 9813 declare 9814 Iface : Entity_Id; 9815 Ifaces : Elist_Id; 9816 Iface_Elmt : Elmt_Id; 9817 9818 begin 9819 Collect_Interfaces 9820 (T => Derived_Type, 9821 Ifaces_List => Ifaces, 9822 Exclude_Parents => True); 9823 9824 if Present (Ifaces) then 9825 Iface_Elmt := First_Elmt (Ifaces); 9826 while Present (Iface_Elmt) loop 9827 Iface := Node (Iface_Elmt); 9828 9829 if Has_Inheritable_Invariants (Iface) then 9830 Set_Has_Inherited_Invariants (Derived_Type); 9831 exit; 9832 end if; 9833 9834 Next_Elmt (Iface_Elmt); 9835 end loop; 9836 end if; 9837 end; 9838 end if; 9839 end if; 9840 9841 -- We similarly inherit predicates. Note that for scalar derived types 9842 -- the predicate is inherited from the first subtype, and not from its 9843 -- (anonymous) base type. 9844 9845 if Has_Predicates (Parent_Type) 9846 or else Has_Predicates (First_Subtype (Parent_Type)) 9847 then 9848 Set_Has_Predicates (Derived_Type); 9849 end if; 9850 9851 -- The derived type inherits representation clauses from the parent 9852 -- type, and from any interfaces. 9853 9854 Inherit_Rep_Item_Chain (Derived_Type, Parent_Type); 9855 9856 declare 9857 Iface : Node_Id := First (Abstract_Interface_List (Derived_Type)); 9858 begin 9859 while Present (Iface) loop 9860 Inherit_Rep_Item_Chain (Derived_Type, Entity (Iface)); 9861 Next (Iface); 9862 end loop; 9863 end; 9864 9865 -- If the parent type has delayed rep aspects, then mark the derived 9866 -- type as possibly inheriting a delayed rep aspect. 9867 9868 if Has_Delayed_Rep_Aspects (Parent_Type) then 9869 Set_May_Inherit_Delayed_Rep_Aspects (Derived_Type); 9870 end if; 9871 9872 -- A derived type becomes Ghost when its parent type is also Ghost 9873 -- (SPARK RM 6.9(9)). Note that the Ghost-related attributes are not 9874 -- directly inherited because the Ghost policy in effect may differ. 9875 9876 if Is_Ghost_Entity (Parent_Type) then 9877 Set_Is_Ghost_Entity (Derived_Type); 9878 end if; 9879 9880 -- Type dependent processing 9881 9882 case Ekind (Parent_Type) is 9883 when Numeric_Kind => 9884 Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type); 9885 9886 when Array_Kind => 9887 Build_Derived_Array_Type (N, Parent_Type, Derived_Type); 9888 9889 when Class_Wide_Kind 9890 | E_Record_Subtype 9891 | E_Record_Type 9892 => 9893 Build_Derived_Record_Type 9894 (N, Parent_Type, Derived_Type, Derive_Subps); 9895 return; 9896 9897 when Enumeration_Kind => 9898 Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type); 9899 9900 when Access_Kind => 9901 Build_Derived_Access_Type (N, Parent_Type, Derived_Type); 9902 9903 when Incomplete_Or_Private_Kind => 9904 Build_Derived_Private_Type 9905 (N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps); 9906 9907 -- For discriminated types, the derivation includes deriving 9908 -- primitive operations. For others it is done below. 9909 9910 if Is_Tagged_Type (Parent_Type) 9911 or else Has_Discriminants (Parent_Type) 9912 or else (Present (Full_View (Parent_Type)) 9913 and then Has_Discriminants (Full_View (Parent_Type))) 9914 then 9915 return; 9916 end if; 9917 9918 when Concurrent_Kind => 9919 Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type); 9920 9921 when others => 9922 raise Program_Error; 9923 end case; 9924 9925 -- Nothing more to do if some error occurred 9926 9927 if Etype (Derived_Type) = Any_Type then 9928 return; 9929 end if; 9930 9931 -- Set delayed freeze and then derive subprograms, we need to do this 9932 -- in this order so that derived subprograms inherit the derived freeze 9933 -- if necessary. 9934 9935 Set_Has_Delayed_Freeze (Derived_Type); 9936 9937 if Derive_Subps then 9938 Derive_Subprograms (Parent_Type, Derived_Type); 9939 end if; 9940 9941 Set_Has_Primitive_Operations 9942 (Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type)); 9943 end Build_Derived_Type; 9944 9945 ----------------------- 9946 -- Build_Discriminal -- 9947 ----------------------- 9948 9949 procedure Build_Discriminal (Discrim : Entity_Id) is 9950 D_Minal : Entity_Id; 9951 CR_Disc : Entity_Id; 9952 9953 begin 9954 -- A discriminal has the same name as the discriminant 9955 9956 D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); 9957 9958 Set_Ekind (D_Minal, E_In_Parameter); 9959 Set_Mechanism (D_Minal, Default_Mechanism); 9960 Set_Etype (D_Minal, Etype (Discrim)); 9961 Set_Scope (D_Minal, Current_Scope); 9962 Set_Parent (D_Minal, Parent (Discrim)); 9963 9964 Set_Discriminal (Discrim, D_Minal); 9965 Set_Discriminal_Link (D_Minal, Discrim); 9966 9967 -- For task types, build at once the discriminants of the corresponding 9968 -- record, which are needed if discriminants are used in entry defaults 9969 -- and in family bounds. 9970 9971 if Is_Concurrent_Type (Current_Scope) 9972 or else 9973 Is_Limited_Type (Current_Scope) 9974 then 9975 CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); 9976 9977 Set_Ekind (CR_Disc, E_In_Parameter); 9978 Set_Mechanism (CR_Disc, Default_Mechanism); 9979 Set_Etype (CR_Disc, Etype (Discrim)); 9980 Set_Scope (CR_Disc, Current_Scope); 9981 Set_Discriminal_Link (CR_Disc, Discrim); 9982 Set_CR_Discriminant (Discrim, CR_Disc); 9983 end if; 9984 end Build_Discriminal; 9985 9986 ------------------------------------ 9987 -- Build_Discriminant_Constraints -- 9988 ------------------------------------ 9989 9990 function Build_Discriminant_Constraints 9991 (T : Entity_Id; 9992 Def : Node_Id; 9993 Derived_Def : Boolean := False) return Elist_Id 9994 is 9995 C : constant Node_Id := Constraint (Def); 9996 Nb_Discr : constant Nat := Number_Discriminants (T); 9997 9998 Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty); 9999 -- Saves the expression corresponding to a given discriminant in T 10000 10001 function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat; 10002 -- Return the Position number within array Discr_Expr of a discriminant 10003 -- D within the discriminant list of the discriminated type T. 10004 10005 procedure Process_Discriminant_Expression 10006 (Expr : Node_Id; 10007 D : Entity_Id); 10008 -- If this is a discriminant constraint on a partial view, do not 10009 -- generate an overflow check on the discriminant expression. The check 10010 -- will be generated when constraining the full view. Otherwise the 10011 -- backend creates duplicate symbols for the temporaries corresponding 10012 -- to the expressions to be checked, causing spurious assembler errors. 10013 10014 ------------------ 10015 -- Pos_Of_Discr -- 10016 ------------------ 10017 10018 function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is 10019 Disc : Entity_Id; 10020 10021 begin 10022 Disc := First_Discriminant (T); 10023 for J in Discr_Expr'Range loop 10024 if Disc = D then 10025 return J; 10026 end if; 10027 10028 Next_Discriminant (Disc); 10029 end loop; 10030 10031 -- Note: Since this function is called on discriminants that are 10032 -- known to belong to the discriminated type, falling through the 10033 -- loop with no match signals an internal compiler error. 10034 10035 raise Program_Error; 10036 end Pos_Of_Discr; 10037 10038 ------------------------------------- 10039 -- Process_Discriminant_Expression -- 10040 ------------------------------------- 10041 10042 procedure Process_Discriminant_Expression 10043 (Expr : Node_Id; 10044 D : Entity_Id) 10045 is 10046 BDT : constant Entity_Id := Base_Type (Etype (D)); 10047 10048 begin 10049 -- If this is a discriminant constraint on a partial view, do 10050 -- not generate an overflow on the discriminant expression. The 10051 -- check will be generated when constraining the full view. 10052 10053 if Is_Private_Type (T) 10054 and then Present (Full_View (T)) 10055 then 10056 Analyze_And_Resolve (Expr, BDT, Suppress => Overflow_Check); 10057 else 10058 Analyze_And_Resolve (Expr, BDT); 10059 end if; 10060 end Process_Discriminant_Expression; 10061 10062 -- Declarations local to Build_Discriminant_Constraints 10063 10064 Discr : Entity_Id; 10065 E : Entity_Id; 10066 Elist : constant Elist_Id := New_Elmt_List; 10067 10068 Constr : Node_Id; 10069 Expr : Node_Id; 10070 Id : Node_Id; 10071 Position : Nat; 10072 Found : Boolean; 10073 10074 Discrim_Present : Boolean := False; 10075 10076 -- Start of processing for Build_Discriminant_Constraints 10077 10078 begin 10079 -- The following loop will process positional associations only. 10080 -- For a positional association, the (single) discriminant is 10081 -- implicitly specified by position, in textual order (RM 3.7.2). 10082 10083 Discr := First_Discriminant (T); 10084 Constr := First (Constraints (C)); 10085 for D in Discr_Expr'Range loop 10086 exit when Nkind (Constr) = N_Discriminant_Association; 10087 10088 if No (Constr) then 10089 Error_Msg_N ("too few discriminants given in constraint", C); 10090 return New_Elmt_List; 10091 10092 elsif Nkind (Constr) = N_Range 10093 or else (Nkind (Constr) = N_Attribute_Reference 10094 and then Attribute_Name (Constr) = Name_Range) 10095 then 10096 Error_Msg_N 10097 ("a range is not a valid discriminant constraint", Constr); 10098 Discr_Expr (D) := Error; 10099 10100 elsif Nkind (Constr) = N_Subtype_Indication then 10101 Error_Msg_N 10102 ("a subtype indication is not a valid discriminant constraint", 10103 Constr); 10104 Discr_Expr (D) := Error; 10105 10106 else 10107 Process_Discriminant_Expression (Constr, Discr); 10108 Discr_Expr (D) := Constr; 10109 end if; 10110 10111 Next_Discriminant (Discr); 10112 Next (Constr); 10113 end loop; 10114 10115 if No (Discr) and then Present (Constr) then 10116 Error_Msg_N ("too many discriminants given in constraint", Constr); 10117 return New_Elmt_List; 10118 end if; 10119 10120 -- Named associations can be given in any order, but if both positional 10121 -- and named associations are used in the same discriminant constraint, 10122 -- then positional associations must occur first, at their normal 10123 -- position. Hence once a named association is used, the rest of the 10124 -- discriminant constraint must use only named associations. 10125 10126 while Present (Constr) loop 10127 10128 -- Positional association forbidden after a named association 10129 10130 if Nkind (Constr) /= N_Discriminant_Association then 10131 Error_Msg_N ("positional association follows named one", Constr); 10132 return New_Elmt_List; 10133 10134 -- Otherwise it is a named association 10135 10136 else 10137 -- E records the type of the discriminants in the named 10138 -- association. All the discriminants specified in the same name 10139 -- association must have the same type. 10140 10141 E := Empty; 10142 10143 -- Search the list of discriminants in T to see if the simple name 10144 -- given in the constraint matches any of them. 10145 10146 Id := First (Selector_Names (Constr)); 10147 while Present (Id) loop 10148 Found := False; 10149 10150 -- If Original_Discriminant is present, we are processing a 10151 -- generic instantiation and this is an instance node. We need 10152 -- to find the name of the corresponding discriminant in the 10153 -- actual record type T and not the name of the discriminant in 10154 -- the generic formal. Example: 10155 10156 -- generic 10157 -- type G (D : int) is private; 10158 -- package P is 10159 -- subtype W is G (D => 1); 10160 -- end package; 10161 -- type Rec (X : int) is record ... end record; 10162 -- package Q is new P (G => Rec); 10163 10164 -- At the point of the instantiation, formal type G is Rec 10165 -- and therefore when reanalyzing "subtype W is G (D => 1);" 10166 -- which really looks like "subtype W is Rec (D => 1);" at 10167 -- the point of instantiation, we want to find the discriminant 10168 -- that corresponds to D in Rec, i.e. X. 10169 10170 if Present (Original_Discriminant (Id)) 10171 and then In_Instance 10172 then 10173 Discr := Find_Corresponding_Discriminant (Id, T); 10174 Found := True; 10175 10176 else 10177 Discr := First_Discriminant (T); 10178 while Present (Discr) loop 10179 if Chars (Discr) = Chars (Id) then 10180 Found := True; 10181 exit; 10182 end if; 10183 10184 Next_Discriminant (Discr); 10185 end loop; 10186 10187 if not Found then 10188 Error_Msg_N ("& does not match any discriminant", Id); 10189 return New_Elmt_List; 10190 10191 -- If the parent type is a generic formal, preserve the 10192 -- name of the discriminant for subsequent instances. 10193 -- see comment at the beginning of this if statement. 10194 10195 elsif Is_Generic_Type (Root_Type (T)) then 10196 Set_Original_Discriminant (Id, Discr); 10197 end if; 10198 end if; 10199 10200 Position := Pos_Of_Discr (T, Discr); 10201 10202 if Present (Discr_Expr (Position)) then 10203 Error_Msg_N ("duplicate constraint for discriminant&", Id); 10204 10205 else 10206 -- Each discriminant specified in the same named association 10207 -- must be associated with a separate copy of the 10208 -- corresponding expression. 10209 10210 if Present (Next (Id)) then 10211 Expr := New_Copy_Tree (Expression (Constr)); 10212 Set_Parent (Expr, Parent (Expression (Constr))); 10213 else 10214 Expr := Expression (Constr); 10215 end if; 10216 10217 Discr_Expr (Position) := Expr; 10218 Process_Discriminant_Expression (Expr, Discr); 10219 end if; 10220 10221 -- A discriminant association with more than one discriminant 10222 -- name is only allowed if the named discriminants are all of 10223 -- the same type (RM 3.7.1(8)). 10224 10225 if E = Empty then 10226 E := Base_Type (Etype (Discr)); 10227 10228 elsif Base_Type (Etype (Discr)) /= E then 10229 Error_Msg_N 10230 ("all discriminants in an association " & 10231 "must have the same type", Id); 10232 end if; 10233 10234 Next (Id); 10235 end loop; 10236 end if; 10237 10238 Next (Constr); 10239 end loop; 10240 10241 -- A discriminant constraint must provide exactly one value for each 10242 -- discriminant of the type (RM 3.7.1(8)). 10243 10244 for J in Discr_Expr'Range loop 10245 if No (Discr_Expr (J)) then 10246 Error_Msg_N ("too few discriminants given in constraint", C); 10247 return New_Elmt_List; 10248 end if; 10249 end loop; 10250 10251 -- Determine if there are discriminant expressions in the constraint 10252 10253 for J in Discr_Expr'Range loop 10254 if Denotes_Discriminant 10255 (Discr_Expr (J), Check_Concurrent => True) 10256 then 10257 Discrim_Present := True; 10258 end if; 10259 end loop; 10260 10261 -- Build an element list consisting of the expressions given in the 10262 -- discriminant constraint and apply the appropriate checks. The list 10263 -- is constructed after resolving any named discriminant associations 10264 -- and therefore the expressions appear in the textual order of the 10265 -- discriminants. 10266 10267 Discr := First_Discriminant (T); 10268 for J in Discr_Expr'Range loop 10269 if Discr_Expr (J) /= Error then 10270 Append_Elmt (Discr_Expr (J), Elist); 10271 10272 -- If any of the discriminant constraints is given by a 10273 -- discriminant and we are in a derived type declaration we 10274 -- have a discriminant renaming. Establish link between new 10275 -- and old discriminant. The new discriminant has an implicit 10276 -- dereference if the old one does. 10277 10278 if Denotes_Discriminant (Discr_Expr (J)) then 10279 if Derived_Def then 10280 declare 10281 New_Discr : constant Entity_Id := Entity (Discr_Expr (J)); 10282 10283 begin 10284 Set_Corresponding_Discriminant (New_Discr, Discr); 10285 Set_Has_Implicit_Dereference (New_Discr, 10286 Has_Implicit_Dereference (Discr)); 10287 end; 10288 end if; 10289 10290 -- Force the evaluation of non-discriminant expressions. 10291 -- If we have found a discriminant in the constraint 3.4(26) 10292 -- and 3.8(18) demand that no range checks are performed are 10293 -- after evaluation. If the constraint is for a component 10294 -- definition that has a per-object constraint, expressions are 10295 -- evaluated but not checked either. In all other cases perform 10296 -- a range check. 10297 10298 else 10299 if Discrim_Present then 10300 null; 10301 10302 elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration 10303 and then Has_Per_Object_Constraint 10304 (Defining_Identifier (Parent (Parent (Def)))) 10305 then 10306 null; 10307 10308 elsif Is_Access_Type (Etype (Discr)) then 10309 Apply_Constraint_Check (Discr_Expr (J), Etype (Discr)); 10310 10311 else 10312 Apply_Range_Check (Discr_Expr (J), Etype (Discr)); 10313 end if; 10314 10315 Force_Evaluation (Discr_Expr (J)); 10316 end if; 10317 10318 -- Check that the designated type of an access discriminant's 10319 -- expression is not a class-wide type unless the discriminant's 10320 -- designated type is also class-wide. 10321 10322 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type 10323 and then not Is_Class_Wide_Type 10324 (Designated_Type (Etype (Discr))) 10325 and then Etype (Discr_Expr (J)) /= Any_Type 10326 and then Is_Class_Wide_Type 10327 (Designated_Type (Etype (Discr_Expr (J)))) 10328 then 10329 Wrong_Type (Discr_Expr (J), Etype (Discr)); 10330 10331 elsif Is_Access_Type (Etype (Discr)) 10332 and then not Is_Access_Constant (Etype (Discr)) 10333 and then Is_Access_Type (Etype (Discr_Expr (J))) 10334 and then Is_Access_Constant (Etype (Discr_Expr (J))) 10335 then 10336 Error_Msg_NE 10337 ("constraint for discriminant& must be access to variable", 10338 Def, Discr); 10339 end if; 10340 end if; 10341 10342 Next_Discriminant (Discr); 10343 end loop; 10344 10345 return Elist; 10346 end Build_Discriminant_Constraints; 10347 10348 --------------------------------- 10349 -- Build_Discriminated_Subtype -- 10350 --------------------------------- 10351 10352 procedure Build_Discriminated_Subtype 10353 (T : Entity_Id; 10354 Def_Id : Entity_Id; 10355 Elist : Elist_Id; 10356 Related_Nod : Node_Id; 10357 For_Access : Boolean := False) 10358 is 10359 Has_Discrs : constant Boolean := Has_Discriminants (T); 10360 Constrained : constant Boolean := 10361 (Has_Discrs 10362 and then not Is_Empty_Elmt_List (Elist) 10363 and then not Is_Class_Wide_Type (T)) 10364 or else Is_Constrained (T); 10365 10366 begin 10367 if Ekind (T) = E_Record_Type then 10368 Set_Ekind (Def_Id, E_Record_Subtype); 10369 10370 -- Inherit preelaboration flag from base, for types for which it 10371 -- may have been set: records, private types, protected types. 10372 10373 Set_Known_To_Have_Preelab_Init 10374 (Def_Id, Known_To_Have_Preelab_Init (T)); 10375 10376 elsif Ekind (T) = E_Task_Type then 10377 Set_Ekind (Def_Id, E_Task_Subtype); 10378 10379 elsif Ekind (T) = E_Protected_Type then 10380 Set_Ekind (Def_Id, E_Protected_Subtype); 10381 Set_Known_To_Have_Preelab_Init 10382 (Def_Id, Known_To_Have_Preelab_Init (T)); 10383 10384 elsif Is_Private_Type (T) then 10385 Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); 10386 Set_Known_To_Have_Preelab_Init 10387 (Def_Id, Known_To_Have_Preelab_Init (T)); 10388 10389 -- Private subtypes may have private dependents 10390 10391 Set_Private_Dependents (Def_Id, New_Elmt_List); 10392 10393 elsif Is_Class_Wide_Type (T) then 10394 Set_Ekind (Def_Id, E_Class_Wide_Subtype); 10395 10396 else 10397 -- Incomplete type. Attach subtype to list of dependents, to be 10398 -- completed with full view of parent type, unless is it the 10399 -- designated subtype of a record component within an init_proc. 10400 -- This last case arises for a component of an access type whose 10401 -- designated type is incomplete (e.g. a Taft Amendment type). 10402 -- The designated subtype is within an inner scope, and needs no 10403 -- elaboration, because only the access type is needed in the 10404 -- initialization procedure. 10405 10406 if Ekind (T) = E_Incomplete_Type then 10407 Set_Ekind (Def_Id, E_Incomplete_Subtype); 10408 else 10409 Set_Ekind (Def_Id, Ekind (T)); 10410 end if; 10411 10412 if For_Access and then Within_Init_Proc then 10413 null; 10414 else 10415 Append_Elmt (Def_Id, Private_Dependents (T)); 10416 end if; 10417 end if; 10418 10419 Set_Etype (Def_Id, T); 10420 Init_Size_Align (Def_Id); 10421 Set_Has_Discriminants (Def_Id, Has_Discrs); 10422 Set_Is_Constrained (Def_Id, Constrained); 10423 10424 Set_First_Entity (Def_Id, First_Entity (T)); 10425 Set_Last_Entity (Def_Id, Last_Entity (T)); 10426 Set_Has_Implicit_Dereference 10427 (Def_Id, Has_Implicit_Dereference (T)); 10428 Set_Has_Pragma_Unreferenced_Objects 10429 (Def_Id, Has_Pragma_Unreferenced_Objects (T)); 10430 10431 -- If the subtype is the completion of a private declaration, there may 10432 -- have been representation clauses for the partial view, and they must 10433 -- be preserved. Build_Derived_Type chains the inherited clauses with 10434 -- the ones appearing on the extension. If this comes from a subtype 10435 -- declaration, all clauses are inherited. 10436 10437 if No (First_Rep_Item (Def_Id)) then 10438 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 10439 end if; 10440 10441 if Is_Tagged_Type (T) then 10442 Set_Is_Tagged_Type (Def_Id); 10443 Set_No_Tagged_Streams_Pragma (Def_Id, No_Tagged_Streams_Pragma (T)); 10444 Make_Class_Wide_Type (Def_Id); 10445 end if; 10446 10447 Set_Stored_Constraint (Def_Id, No_Elist); 10448 10449 if Has_Discrs then 10450 Set_Discriminant_Constraint (Def_Id, Elist); 10451 Set_Stored_Constraint_From_Discriminant_Constraint (Def_Id); 10452 end if; 10453 10454 if Is_Tagged_Type (T) then 10455 10456 -- Ada 2005 (AI-251): In case of concurrent types we inherit the 10457 -- concurrent record type (which has the list of primitive 10458 -- operations). 10459 10460 if Ada_Version >= Ada_2005 10461 and then Is_Concurrent_Type (T) 10462 then 10463 Set_Corresponding_Record_Type (Def_Id, 10464 Corresponding_Record_Type (T)); 10465 else 10466 Set_Direct_Primitive_Operations (Def_Id, 10467 Direct_Primitive_Operations (T)); 10468 end if; 10469 10470 Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T)); 10471 end if; 10472 10473 -- Subtypes introduced by component declarations do not need to be 10474 -- marked as delayed, and do not get freeze nodes, because the semantics 10475 -- verifies that the parents of the subtypes are frozen before the 10476 -- enclosing record is frozen. 10477 10478 if not Is_Type (Scope (Def_Id)) then 10479 Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); 10480 10481 if Is_Private_Type (T) 10482 and then Present (Full_View (T)) 10483 then 10484 Conditional_Delay (Def_Id, Full_View (T)); 10485 else 10486 Conditional_Delay (Def_Id, T); 10487 end if; 10488 end if; 10489 10490 if Is_Record_Type (T) then 10491 Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T)); 10492 10493 if Has_Discrs 10494 and then not Is_Empty_Elmt_List (Elist) 10495 and then not For_Access 10496 then 10497 Create_Constrained_Components (Def_Id, Related_Nod, T, Elist); 10498 10499 else 10500 Set_Cloned_Subtype (Def_Id, T); 10501 end if; 10502 end if; 10503 end Build_Discriminated_Subtype; 10504 10505 --------------------------- 10506 -- Build_Itype_Reference -- 10507 --------------------------- 10508 10509 procedure Build_Itype_Reference 10510 (Ityp : Entity_Id; 10511 Nod : Node_Id) 10512 is 10513 IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod)); 10514 begin 10515 10516 -- Itype references are only created for use by the back-end 10517 10518 if Inside_A_Generic then 10519 return; 10520 else 10521 Set_Itype (IR, Ityp); 10522 10523 -- If Nod is a library unit entity, then Insert_After won't work, 10524 -- because Nod is not a member of any list. Therefore, we use 10525 -- Add_Global_Declaration in this case. This can happen if we have a 10526 -- build-in-place library function, child unit or not. 10527 10528 if (Nkind (Nod) in N_Entity and then Is_Compilation_Unit (Nod)) 10529 or else (Nkind_In (Nod, N_Defining_Program_Unit_Name, 10530 N_Subprogram_Declaration) 10531 and then Is_Compilation_Unit (Defining_Entity (Nod))) 10532 then 10533 Add_Global_Declaration (IR); 10534 else 10535 Insert_After (Nod, IR); 10536 end if; 10537 end if; 10538 end Build_Itype_Reference; 10539 10540 ------------------------ 10541 -- Build_Scalar_Bound -- 10542 ------------------------ 10543 10544 function Build_Scalar_Bound 10545 (Bound : Node_Id; 10546 Par_T : Entity_Id; 10547 Der_T : Entity_Id) return Node_Id 10548 is 10549 New_Bound : Entity_Id; 10550 10551 begin 10552 -- Note: not clear why this is needed, how can the original bound 10553 -- be unanalyzed at this point? and if it is, what business do we 10554 -- have messing around with it? and why is the base type of the 10555 -- parent type the right type for the resolution. It probably is 10556 -- not. It is OK for the new bound we are creating, but not for 10557 -- the old one??? Still if it never happens, no problem. 10558 10559 Analyze_And_Resolve (Bound, Base_Type (Par_T)); 10560 10561 if Nkind_In (Bound, N_Integer_Literal, N_Real_Literal) then 10562 New_Bound := New_Copy (Bound); 10563 Set_Etype (New_Bound, Der_T); 10564 Set_Analyzed (New_Bound); 10565 10566 elsif Is_Entity_Name (Bound) then 10567 New_Bound := OK_Convert_To (Der_T, New_Copy (Bound)); 10568 10569 -- The following is almost certainly wrong. What business do we have 10570 -- relocating a node (Bound) that is presumably still attached to 10571 -- the tree elsewhere??? 10572 10573 else 10574 New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound)); 10575 end if; 10576 10577 Set_Etype (New_Bound, Der_T); 10578 return New_Bound; 10579 end Build_Scalar_Bound; 10580 10581 ------------------------------- 10582 -- Check_Abstract_Overriding -- 10583 ------------------------------- 10584 10585 procedure Check_Abstract_Overriding (T : Entity_Id) is 10586 Alias_Subp : Entity_Id; 10587 Elmt : Elmt_Id; 10588 Op_List : Elist_Id; 10589 Subp : Entity_Id; 10590 Type_Def : Node_Id; 10591 10592 procedure Check_Pragma_Implemented (Subp : Entity_Id); 10593 -- Ada 2012 (AI05-0030): Subprogram Subp overrides an interface routine 10594 -- which has pragma Implemented already set. Check whether Subp's entity 10595 -- kind conforms to the implementation kind of the overridden routine. 10596 10597 procedure Check_Pragma_Implemented 10598 (Subp : Entity_Id; 10599 Iface_Subp : Entity_Id); 10600 -- Ada 2012 (AI05-0030): Subprogram Subp overrides interface routine 10601 -- Iface_Subp and both entities have pragma Implemented already set on 10602 -- them. Check whether the two implementation kinds are conforming. 10603 10604 procedure Inherit_Pragma_Implemented 10605 (Subp : Entity_Id; 10606 Iface_Subp : Entity_Id); 10607 -- Ada 2012 (AI05-0030): Interface primitive Subp overrides interface 10608 -- subprogram Iface_Subp which has been marked by pragma Implemented. 10609 -- Propagate the implementation kind of Iface_Subp to Subp. 10610 10611 ------------------------------ 10612 -- Check_Pragma_Implemented -- 10613 ------------------------------ 10614 10615 procedure Check_Pragma_Implemented (Subp : Entity_Id) is 10616 Iface_Alias : constant Entity_Id := Interface_Alias (Subp); 10617 Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias); 10618 Subp_Alias : constant Entity_Id := Alias (Subp); 10619 Contr_Typ : Entity_Id; 10620 Impl_Subp : Entity_Id; 10621 10622 begin 10623 -- Subp must have an alias since it is a hidden entity used to link 10624 -- an interface subprogram to its overriding counterpart. 10625 10626 pragma Assert (Present (Subp_Alias)); 10627 10628 -- Handle aliases to synchronized wrappers 10629 10630 Impl_Subp := Subp_Alias; 10631 10632 if Is_Primitive_Wrapper (Impl_Subp) then 10633 Impl_Subp := Wrapped_Entity (Impl_Subp); 10634 end if; 10635 10636 -- Extract the type of the controlling formal 10637 10638 Contr_Typ := Etype (First_Formal (Subp_Alias)); 10639 10640 if Is_Concurrent_Record_Type (Contr_Typ) then 10641 Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ); 10642 end if; 10643 10644 -- An interface subprogram whose implementation kind is By_Entry must 10645 -- be implemented by an entry. 10646 10647 if Impl_Kind = Name_By_Entry 10648 and then Ekind (Impl_Subp) /= E_Entry 10649 then 10650 Error_Msg_Node_2 := Iface_Alias; 10651 Error_Msg_NE 10652 ("type & must implement abstract subprogram & with an entry", 10653 Subp_Alias, Contr_Typ); 10654 10655 elsif Impl_Kind = Name_By_Protected_Procedure then 10656 10657 -- An interface subprogram whose implementation kind is By_ 10658 -- Protected_Procedure cannot be implemented by a primitive 10659 -- procedure of a task type. 10660 10661 if Ekind (Contr_Typ) /= E_Protected_Type then 10662 Error_Msg_Node_2 := Contr_Typ; 10663 Error_Msg_NE 10664 ("interface subprogram & cannot be implemented by a " 10665 & "primitive procedure of task type &", 10666 Subp_Alias, Iface_Alias); 10667 10668 -- An interface subprogram whose implementation kind is By_ 10669 -- Protected_Procedure must be implemented by a procedure. 10670 10671 elsif Ekind (Impl_Subp) /= E_Procedure then 10672 Error_Msg_Node_2 := Iface_Alias; 10673 Error_Msg_NE 10674 ("type & must implement abstract subprogram & with a " 10675 & "procedure", Subp_Alias, Contr_Typ); 10676 10677 elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented)) 10678 and then Implementation_Kind (Impl_Subp) /= Impl_Kind 10679 then 10680 Error_Msg_Name_1 := Impl_Kind; 10681 Error_Msg_N 10682 ("overriding operation& must have synchronization%", 10683 Subp_Alias); 10684 end if; 10685 10686 -- If primitive has Optional synchronization, overriding operation 10687 -- must match if it has an explicit synchronization. 10688 10689 elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented)) 10690 and then Implementation_Kind (Impl_Subp) /= Impl_Kind 10691 then 10692 Error_Msg_Name_1 := Impl_Kind; 10693 Error_Msg_N 10694 ("overriding operation& must have synchronization%", Subp_Alias); 10695 end if; 10696 end Check_Pragma_Implemented; 10697 10698 ------------------------------ 10699 -- Check_Pragma_Implemented -- 10700 ------------------------------ 10701 10702 procedure Check_Pragma_Implemented 10703 (Subp : Entity_Id; 10704 Iface_Subp : Entity_Id) 10705 is 10706 Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); 10707 Subp_Kind : constant Name_Id := Implementation_Kind (Subp); 10708 10709 begin 10710 -- Ada 2012 (AI05-0030): The implementation kinds of an overridden 10711 -- and overriding subprogram are different. In general this is an 10712 -- error except when the implementation kind of the overridden 10713 -- subprograms is By_Any or Optional. 10714 10715 if Iface_Kind /= Subp_Kind 10716 and then Iface_Kind /= Name_By_Any 10717 and then Iface_Kind /= Name_Optional 10718 then 10719 if Iface_Kind = Name_By_Entry then 10720 Error_Msg_N 10721 ("incompatible implementation kind, overridden subprogram " & 10722 "is marked By_Entry", Subp); 10723 else 10724 Error_Msg_N 10725 ("incompatible implementation kind, overridden subprogram " & 10726 "is marked By_Protected_Procedure", Subp); 10727 end if; 10728 end if; 10729 end Check_Pragma_Implemented; 10730 10731 -------------------------------- 10732 -- Inherit_Pragma_Implemented -- 10733 -------------------------------- 10734 10735 procedure Inherit_Pragma_Implemented 10736 (Subp : Entity_Id; 10737 Iface_Subp : Entity_Id) 10738 is 10739 Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); 10740 Loc : constant Source_Ptr := Sloc (Subp); 10741 Impl_Prag : Node_Id; 10742 10743 begin 10744 -- Since the implementation kind is stored as a representation item 10745 -- rather than a flag, create a pragma node. 10746 10747 Impl_Prag := 10748 Make_Pragma (Loc, 10749 Chars => Name_Implemented, 10750 Pragma_Argument_Associations => New_List ( 10751 Make_Pragma_Argument_Association (Loc, 10752 Expression => New_Occurrence_Of (Subp, Loc)), 10753 10754 Make_Pragma_Argument_Association (Loc, 10755 Expression => Make_Identifier (Loc, Iface_Kind)))); 10756 10757 -- The pragma doesn't need to be analyzed because it is internally 10758 -- built. It is safe to directly register it as a rep item since we 10759 -- are only interested in the characters of the implementation kind. 10760 10761 Record_Rep_Item (Subp, Impl_Prag); 10762 end Inherit_Pragma_Implemented; 10763 10764 -- Start of processing for Check_Abstract_Overriding 10765 10766 begin 10767 Op_List := Primitive_Operations (T); 10768 10769 -- Loop to check primitive operations 10770 10771 Elmt := First_Elmt (Op_List); 10772 while Present (Elmt) loop 10773 Subp := Node (Elmt); 10774 Alias_Subp := Alias (Subp); 10775 10776 -- Inherited subprograms are identified by the fact that they do not 10777 -- come from source, and the associated source location is the 10778 -- location of the first subtype of the derived type. 10779 10780 -- Ada 2005 (AI-228): Apply the rules of RM-3.9.3(6/2) for 10781 -- subprograms that "require overriding". 10782 10783 -- Special exception, do not complain about failure to override the 10784 -- stream routines _Input and _Output, as well as the primitive 10785 -- operations used in dispatching selects since we always provide 10786 -- automatic overridings for these subprograms. 10787 10788 -- The partial view of T may have been a private extension, for 10789 -- which inherited functions dispatching on result are abstract. 10790 -- If the full view is a null extension, there is no need for 10791 -- overriding in Ada 2005, but wrappers need to be built for them 10792 -- (see exp_ch3, Build_Controlling_Function_Wrappers). 10793 10794 if Is_Null_Extension (T) 10795 and then Has_Controlling_Result (Subp) 10796 and then Ada_Version >= Ada_2005 10797 and then Present (Alias_Subp) 10798 and then not Comes_From_Source (Subp) 10799 and then not Is_Abstract_Subprogram (Alias_Subp) 10800 and then not Is_Access_Type (Etype (Subp)) 10801 then 10802 null; 10803 10804 -- Ada 2005 (AI-251): Internal entities of interfaces need no 10805 -- processing because this check is done with the aliased 10806 -- entity 10807 10808 elsif Present (Interface_Alias (Subp)) then 10809 null; 10810 10811 elsif (Is_Abstract_Subprogram (Subp) 10812 or else Requires_Overriding (Subp) 10813 or else 10814 (Has_Controlling_Result (Subp) 10815 and then Present (Alias_Subp) 10816 and then not Comes_From_Source (Subp) 10817 and then Sloc (Subp) = Sloc (First_Subtype (T)))) 10818 and then not Is_TSS (Subp, TSS_Stream_Input) 10819 and then not Is_TSS (Subp, TSS_Stream_Output) 10820 and then not Is_Abstract_Type (T) 10821 and then not Is_Predefined_Interface_Primitive (Subp) 10822 10823 -- Ada 2005 (AI-251): Do not consider hidden entities associated 10824 -- with abstract interface types because the check will be done 10825 -- with the aliased entity (otherwise we generate a duplicated 10826 -- error message). 10827 10828 and then not Present (Interface_Alias (Subp)) 10829 then 10830 if Present (Alias_Subp) then 10831 10832 -- Only perform the check for a derived subprogram when the 10833 -- type has an explicit record extension. This avoids incorrect 10834 -- flagging of abstract subprograms for the case of a type 10835 -- without an extension that is derived from a formal type 10836 -- with a tagged actual (can occur within a private part). 10837 10838 -- Ada 2005 (AI-391): In the case of an inherited function with 10839 -- a controlling result of the type, the rule does not apply if 10840 -- the type is a null extension (unless the parent function 10841 -- itself is abstract, in which case the function must still be 10842 -- be overridden). The expander will generate an overriding 10843 -- wrapper function calling the parent subprogram (see 10844 -- Exp_Ch3.Make_Controlling_Wrapper_Functions). 10845 10846 Type_Def := Type_Definition (Parent (T)); 10847 10848 if Nkind (Type_Def) = N_Derived_Type_Definition 10849 and then Present (Record_Extension_Part (Type_Def)) 10850 and then 10851 (Ada_Version < Ada_2005 10852 or else not Is_Null_Extension (T) 10853 or else Ekind (Subp) = E_Procedure 10854 or else not Has_Controlling_Result (Subp) 10855 or else Is_Abstract_Subprogram (Alias_Subp) 10856 or else Requires_Overriding (Subp) 10857 or else Is_Access_Type (Etype (Subp))) 10858 then 10859 -- Avoid reporting error in case of abstract predefined 10860 -- primitive inherited from interface type because the 10861 -- body of internally generated predefined primitives 10862 -- of tagged types are generated later by Freeze_Type 10863 10864 if Is_Interface (Root_Type (T)) 10865 and then Is_Abstract_Subprogram (Subp) 10866 and then Is_Predefined_Dispatching_Operation (Subp) 10867 and then not Comes_From_Source (Ultimate_Alias (Subp)) 10868 then 10869 null; 10870 10871 -- A null extension is not obliged to override an inherited 10872 -- procedure subject to pragma Extensions_Visible with value 10873 -- False and at least one controlling OUT parameter 10874 -- (SPARK RM 6.1.7(6)). 10875 10876 elsif Is_Null_Extension (T) 10877 and then Is_EVF_Procedure (Subp) 10878 then 10879 null; 10880 10881 else 10882 Error_Msg_NE 10883 ("type must be declared abstract or & overridden", 10884 T, Subp); 10885 10886 -- Traverse the whole chain of aliased subprograms to 10887 -- complete the error notification. This is especially 10888 -- useful for traceability of the chain of entities when 10889 -- the subprogram corresponds with an interface 10890 -- subprogram (which may be defined in another package). 10891 10892 if Present (Alias_Subp) then 10893 declare 10894 E : Entity_Id; 10895 10896 begin 10897 E := Subp; 10898 while Present (Alias (E)) loop 10899 10900 -- Avoid reporting redundant errors on entities 10901 -- inherited from interfaces 10902 10903 if Sloc (E) /= Sloc (T) then 10904 Error_Msg_Sloc := Sloc (E); 10905 Error_Msg_NE 10906 ("\& has been inherited #", T, Subp); 10907 end if; 10908 10909 E := Alias (E); 10910 end loop; 10911 10912 Error_Msg_Sloc := Sloc (E); 10913 10914 -- AI05-0068: report if there is an overriding 10915 -- non-abstract subprogram that is invisible. 10916 10917 if Is_Hidden (E) 10918 and then not Is_Abstract_Subprogram (E) 10919 then 10920 Error_Msg_NE 10921 ("\& subprogram# is not visible", 10922 T, Subp); 10923 10924 -- Clarify the case where a non-null extension must 10925 -- override inherited procedure subject to pragma 10926 -- Extensions_Visible with value False and at least 10927 -- one controlling OUT param. 10928 10929 elsif Is_EVF_Procedure (E) then 10930 Error_Msg_NE 10931 ("\& # is subject to Extensions_Visible False", 10932 T, Subp); 10933 10934 else 10935 Error_Msg_NE 10936 ("\& has been inherited from subprogram #", 10937 T, Subp); 10938 end if; 10939 end; 10940 end if; 10941 end if; 10942 10943 -- Ada 2005 (AI-345): Protected or task type implementing 10944 -- abstract interfaces. 10945 10946 elsif Is_Concurrent_Record_Type (T) 10947 and then Present (Interfaces (T)) 10948 then 10949 -- There is no need to check here RM 9.4(11.9/3) since we 10950 -- are processing the corresponding record type and the 10951 -- mode of the overriding subprograms was verified by 10952 -- Check_Conformance when the corresponding concurrent 10953 -- type declaration was analyzed. 10954 10955 Error_Msg_NE 10956 ("interface subprogram & must be overridden", T, Subp); 10957 10958 -- Examine primitive operations of synchronized type to find 10959 -- homonyms that have the wrong profile. 10960 10961 declare 10962 Prim : Entity_Id; 10963 10964 begin 10965 Prim := First_Entity (Corresponding_Concurrent_Type (T)); 10966 while Present (Prim) loop 10967 if Chars (Prim) = Chars (Subp) then 10968 Error_Msg_NE 10969 ("profile is not type conformant with prefixed " 10970 & "view profile of inherited operation&", 10971 Prim, Subp); 10972 end if; 10973 10974 Next_Entity (Prim); 10975 end loop; 10976 end; 10977 end if; 10978 10979 else 10980 Error_Msg_Node_2 := T; 10981 Error_Msg_N 10982 ("abstract subprogram& not allowed for type&", Subp); 10983 10984 -- Also post unconditional warning on the type (unconditional 10985 -- so that if there are more than one of these cases, we get 10986 -- them all, and not just the first one). 10987 10988 Error_Msg_Node_2 := Subp; 10989 Error_Msg_N ("nonabstract type& has abstract subprogram&!", T); 10990 end if; 10991 10992 -- A subprogram subject to pragma Extensions_Visible with value 10993 -- "True" cannot override a subprogram subject to the same pragma 10994 -- with value "False" (SPARK RM 6.1.7(5)). 10995 10996 elsif Extensions_Visible_Status (Subp) = Extensions_Visible_True 10997 and then Present (Overridden_Operation (Subp)) 10998 and then Extensions_Visible_Status (Overridden_Operation (Subp)) = 10999 Extensions_Visible_False 11000 then 11001 Error_Msg_Sloc := Sloc (Overridden_Operation (Subp)); 11002 Error_Msg_N 11003 ("subprogram & with Extensions_Visible True cannot override " 11004 & "subprogram # with Extensions_Visible False", Subp); 11005 end if; 11006 11007 -- Ada 2012 (AI05-0030): Perform checks related to pragma Implemented 11008 11009 -- Subp is an expander-generated procedure which maps an interface 11010 -- alias to a protected wrapper. The interface alias is flagged by 11011 -- pragma Implemented. Ensure that Subp is a procedure when the 11012 -- implementation kind is By_Protected_Procedure or an entry when 11013 -- By_Entry. 11014 11015 if Ada_Version >= Ada_2012 11016 and then Is_Hidden (Subp) 11017 and then Present (Interface_Alias (Subp)) 11018 and then Has_Rep_Pragma (Interface_Alias (Subp), Name_Implemented) 11019 then 11020 Check_Pragma_Implemented (Subp); 11021 end if; 11022 11023 -- Subp is an interface primitive which overrides another interface 11024 -- primitive marked with pragma Implemented. 11025 11026 if Ada_Version >= Ada_2012 11027 and then Present (Overridden_Operation (Subp)) 11028 and then Has_Rep_Pragma 11029 (Overridden_Operation (Subp), Name_Implemented) 11030 then 11031 -- If the overriding routine is also marked by Implemented, check 11032 -- that the two implementation kinds are conforming. 11033 11034 if Has_Rep_Pragma (Subp, Name_Implemented) then 11035 Check_Pragma_Implemented 11036 (Subp => Subp, 11037 Iface_Subp => Overridden_Operation (Subp)); 11038 11039 -- Otherwise the overriding routine inherits the implementation 11040 -- kind from the overridden subprogram. 11041 11042 else 11043 Inherit_Pragma_Implemented 11044 (Subp => Subp, 11045 Iface_Subp => Overridden_Operation (Subp)); 11046 end if; 11047 end if; 11048 11049 -- If the operation is a wrapper for a synchronized primitive, it 11050 -- may be called indirectly through a dispatching select. We assume 11051 -- that it will be referenced elsewhere indirectly, and suppress 11052 -- warnings about an unused entity. 11053 11054 if Is_Primitive_Wrapper (Subp) 11055 and then Present (Wrapped_Entity (Subp)) 11056 then 11057 Set_Referenced (Wrapped_Entity (Subp)); 11058 end if; 11059 11060 Next_Elmt (Elmt); 11061 end loop; 11062 end Check_Abstract_Overriding; 11063 11064 ------------------------------------------------ 11065 -- Check_Access_Discriminant_Requires_Limited -- 11066 ------------------------------------------------ 11067 11068 procedure Check_Access_Discriminant_Requires_Limited 11069 (D : Node_Id; 11070 Loc : Node_Id) 11071 is 11072 begin 11073 -- A discriminant_specification for an access discriminant shall appear 11074 -- only in the declaration for a task or protected type, or for a type 11075 -- with the reserved word 'limited' in its definition or in one of its 11076 -- ancestors (RM 3.7(10)). 11077 11078 -- AI-0063: The proper condition is that type must be immutably limited, 11079 -- or else be a partial view. 11080 11081 if Nkind (Discriminant_Type (D)) = N_Access_Definition then 11082 if Is_Limited_View (Current_Scope) 11083 or else 11084 (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration 11085 and then Limited_Present (Parent (Current_Scope))) 11086 then 11087 null; 11088 11089 else 11090 Error_Msg_N 11091 ("access discriminants allowed only for limited types", Loc); 11092 end if; 11093 end if; 11094 end Check_Access_Discriminant_Requires_Limited; 11095 11096 ----------------------------------- 11097 -- Check_Aliased_Component_Types -- 11098 ----------------------------------- 11099 11100 procedure Check_Aliased_Component_Types (T : Entity_Id) is 11101 C : Entity_Id; 11102 11103 begin 11104 -- ??? Also need to check components of record extensions, but not 11105 -- components of protected types (which are always limited). 11106 11107 -- Ada 2005: AI-363 relaxes this rule, to allow heap objects of such 11108 -- types to be unconstrained. This is safe because it is illegal to 11109 -- create access subtypes to such types with explicit discriminant 11110 -- constraints. 11111 11112 if not Is_Limited_Type (T) then 11113 if Ekind (T) = E_Record_Type then 11114 C := First_Component (T); 11115 while Present (C) loop 11116 if Is_Aliased (C) 11117 and then Has_Discriminants (Etype (C)) 11118 and then not Is_Constrained (Etype (C)) 11119 and then not In_Instance_Body 11120 and then Ada_Version < Ada_2005 11121 then 11122 Error_Msg_N 11123 ("aliased component must be constrained (RM 3.6(11))", 11124 C); 11125 end if; 11126 11127 Next_Component (C); 11128 end loop; 11129 11130 elsif Ekind (T) = E_Array_Type then 11131 if Has_Aliased_Components (T) 11132 and then Has_Discriminants (Component_Type (T)) 11133 and then not Is_Constrained (Component_Type (T)) 11134 and then not In_Instance_Body 11135 and then Ada_Version < Ada_2005 11136 then 11137 Error_Msg_N 11138 ("aliased component type must be constrained (RM 3.6(11))", 11139 T); 11140 end if; 11141 end if; 11142 end if; 11143 end Check_Aliased_Component_Types; 11144 11145 --------------------------------------- 11146 -- Check_Anonymous_Access_Components -- 11147 --------------------------------------- 11148 11149 procedure Check_Anonymous_Access_Components 11150 (Typ_Decl : Node_Id; 11151 Typ : Entity_Id; 11152 Prev : Entity_Id; 11153 Comp_List : Node_Id) 11154 is 11155 Loc : constant Source_Ptr := Sloc (Typ_Decl); 11156 Anon_Access : Entity_Id; 11157 Acc_Def : Node_Id; 11158 Comp : Node_Id; 11159 Comp_Def : Node_Id; 11160 Decl : Node_Id; 11161 Type_Def : Node_Id; 11162 11163 procedure Build_Incomplete_Type_Declaration; 11164 -- If the record type contains components that include an access to the 11165 -- current record, then create an incomplete type declaration for the 11166 -- record, to be used as the designated type of the anonymous access. 11167 -- This is done only once, and only if there is no previous partial 11168 -- view of the type. 11169 11170 function Designates_T (Subt : Node_Id) return Boolean; 11171 -- Check whether a node designates the enclosing record type, or 'Class 11172 -- of that type 11173 11174 function Mentions_T (Acc_Def : Node_Id) return Boolean; 11175 -- Check whether an access definition includes a reference to 11176 -- the enclosing record type. The reference can be a subtype mark 11177 -- in the access definition itself, a 'Class attribute reference, or 11178 -- recursively a reference appearing in a parameter specification 11179 -- or result definition of an access_to_subprogram definition. 11180 11181 -------------------------------------- 11182 -- Build_Incomplete_Type_Declaration -- 11183 -------------------------------------- 11184 11185 procedure Build_Incomplete_Type_Declaration is 11186 Decl : Node_Id; 11187 Inc_T : Entity_Id; 11188 H : Entity_Id; 11189 11190 -- Is_Tagged indicates whether the type is tagged. It is tagged if 11191 -- it's "is new ... with record" or else "is tagged record ...". 11192 11193 Is_Tagged : constant Boolean := 11194 (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition 11195 and then 11196 Present (Record_Extension_Part (Type_Definition (Typ_Decl)))) 11197 or else 11198 (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition 11199 and then Tagged_Present (Type_Definition (Typ_Decl))); 11200 11201 begin 11202 -- If there is a previous partial view, no need to create a new one 11203 -- If the partial view, given by Prev, is incomplete, If Prev is 11204 -- a private declaration, full declaration is flagged accordingly. 11205 11206 if Prev /= Typ then 11207 if Is_Tagged then 11208 Make_Class_Wide_Type (Prev); 11209 Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); 11210 Set_Etype (Class_Wide_Type (Typ), Typ); 11211 end if; 11212 11213 return; 11214 11215 elsif Has_Private_Declaration (Typ) then 11216 11217 -- If we refer to T'Class inside T, and T is the completion of a 11218 -- private type, then make sure the class-wide type exists. 11219 11220 if Is_Tagged then 11221 Make_Class_Wide_Type (Typ); 11222 end if; 11223 11224 return; 11225 11226 -- If there was a previous anonymous access type, the incomplete 11227 -- type declaration will have been created already. 11228 11229 elsif Present (Current_Entity (Typ)) 11230 and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type 11231 and then Full_View (Current_Entity (Typ)) = Typ 11232 then 11233 if Is_Tagged 11234 and then Comes_From_Source (Current_Entity (Typ)) 11235 and then not Is_Tagged_Type (Current_Entity (Typ)) 11236 then 11237 Make_Class_Wide_Type (Typ); 11238 Error_Msg_N 11239 ("incomplete view of tagged type should be declared tagged??", 11240 Parent (Current_Entity (Typ))); 11241 end if; 11242 return; 11243 11244 else 11245 Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); 11246 Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); 11247 11248 -- Type has already been inserted into the current scope. Remove 11249 -- it, and add incomplete declaration for type, so that subsequent 11250 -- anonymous access types can use it. The entity is unchained from 11251 -- the homonym list and from immediate visibility. After analysis, 11252 -- the entity in the incomplete declaration becomes immediately 11253 -- visible in the record declaration that follows. 11254 11255 H := Current_Entity (Typ); 11256 11257 if H = Typ then 11258 Set_Name_Entity_Id (Chars (Typ), Homonym (Typ)); 11259 else 11260 while Present (H) 11261 and then Homonym (H) /= Typ 11262 loop 11263 H := Homonym (Typ); 11264 end loop; 11265 11266 Set_Homonym (H, Homonym (Typ)); 11267 end if; 11268 11269 Insert_Before (Typ_Decl, Decl); 11270 Analyze (Decl); 11271 Set_Full_View (Inc_T, Typ); 11272 11273 if Is_Tagged then 11274 11275 -- Create a common class-wide type for both views, and set the 11276 -- Etype of the class-wide type to the full view. 11277 11278 Make_Class_Wide_Type (Inc_T); 11279 Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); 11280 Set_Etype (Class_Wide_Type (Typ), Typ); 11281 end if; 11282 end if; 11283 end Build_Incomplete_Type_Declaration; 11284 11285 ------------------ 11286 -- Designates_T -- 11287 ------------------ 11288 11289 function Designates_T (Subt : Node_Id) return Boolean is 11290 Type_Id : constant Name_Id := Chars (Typ); 11291 11292 function Names_T (Nam : Node_Id) return Boolean; 11293 -- The record type has not been introduced in the current scope 11294 -- yet, so we must examine the name of the type itself, either 11295 -- an identifier T, or an expanded name of the form P.T, where 11296 -- P denotes the current scope. 11297 11298 ------------- 11299 -- Names_T -- 11300 ------------- 11301 11302 function Names_T (Nam : Node_Id) return Boolean is 11303 begin 11304 if Nkind (Nam) = N_Identifier then 11305 return Chars (Nam) = Type_Id; 11306 11307 elsif Nkind (Nam) = N_Selected_Component then 11308 if Chars (Selector_Name (Nam)) = Type_Id then 11309 if Nkind (Prefix (Nam)) = N_Identifier then 11310 return Chars (Prefix (Nam)) = Chars (Current_Scope); 11311 11312 elsif Nkind (Prefix (Nam)) = N_Selected_Component then 11313 return Chars (Selector_Name (Prefix (Nam))) = 11314 Chars (Current_Scope); 11315 else 11316 return False; 11317 end if; 11318 11319 else 11320 return False; 11321 end if; 11322 11323 else 11324 return False; 11325 end if; 11326 end Names_T; 11327 11328 -- Start of processing for Designates_T 11329 11330 begin 11331 if Nkind (Subt) = N_Identifier then 11332 return Chars (Subt) = Type_Id; 11333 11334 -- Reference can be through an expanded name which has not been 11335 -- analyzed yet, and which designates enclosing scopes. 11336 11337 elsif Nkind (Subt) = N_Selected_Component then 11338 if Names_T (Subt) then 11339 return True; 11340 11341 -- Otherwise it must denote an entity that is already visible. 11342 -- The access definition may name a subtype of the enclosing 11343 -- type, if there is a previous incomplete declaration for it. 11344 11345 else 11346 Find_Selected_Component (Subt); 11347 return 11348 Is_Entity_Name (Subt) 11349 and then Scope (Entity (Subt)) = Current_Scope 11350 and then 11351 (Chars (Base_Type (Entity (Subt))) = Type_Id 11352 or else 11353 (Is_Class_Wide_Type (Entity (Subt)) 11354 and then 11355 Chars (Etype (Base_Type (Entity (Subt)))) = 11356 Type_Id)); 11357 end if; 11358 11359 -- A reference to the current type may appear as the prefix of 11360 -- a 'Class attribute. 11361 11362 elsif Nkind (Subt) = N_Attribute_Reference 11363 and then Attribute_Name (Subt) = Name_Class 11364 then 11365 return Names_T (Prefix (Subt)); 11366 11367 else 11368 return False; 11369 end if; 11370 end Designates_T; 11371 11372 ---------------- 11373 -- Mentions_T -- 11374 ---------------- 11375 11376 function Mentions_T (Acc_Def : Node_Id) return Boolean is 11377 Param_Spec : Node_Id; 11378 11379 Acc_Subprg : constant Node_Id := 11380 Access_To_Subprogram_Definition (Acc_Def); 11381 11382 begin 11383 if No (Acc_Subprg) then 11384 return Designates_T (Subtype_Mark (Acc_Def)); 11385 end if; 11386 11387 -- Component is an access_to_subprogram: examine its formals, 11388 -- and result definition in the case of an access_to_function. 11389 11390 Param_Spec := First (Parameter_Specifications (Acc_Subprg)); 11391 while Present (Param_Spec) loop 11392 if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition 11393 and then Mentions_T (Parameter_Type (Param_Spec)) 11394 then 11395 return True; 11396 11397 elsif Designates_T (Parameter_Type (Param_Spec)) then 11398 return True; 11399 end if; 11400 11401 Next (Param_Spec); 11402 end loop; 11403 11404 if Nkind (Acc_Subprg) = N_Access_Function_Definition then 11405 if Nkind (Result_Definition (Acc_Subprg)) = 11406 N_Access_Definition 11407 then 11408 return Mentions_T (Result_Definition (Acc_Subprg)); 11409 else 11410 return Designates_T (Result_Definition (Acc_Subprg)); 11411 end if; 11412 end if; 11413 11414 return False; 11415 end Mentions_T; 11416 11417 -- Start of processing for Check_Anonymous_Access_Components 11418 11419 begin 11420 if No (Comp_List) then 11421 return; 11422 end if; 11423 11424 Comp := First (Component_Items (Comp_List)); 11425 while Present (Comp) loop 11426 if Nkind (Comp) = N_Component_Declaration 11427 and then Present 11428 (Access_Definition (Component_Definition (Comp))) 11429 and then 11430 Mentions_T (Access_Definition (Component_Definition (Comp))) 11431 then 11432 Comp_Def := Component_Definition (Comp); 11433 Acc_Def := 11434 Access_To_Subprogram_Definition (Access_Definition (Comp_Def)); 11435 11436 Build_Incomplete_Type_Declaration; 11437 Anon_Access := Make_Temporary (Loc, 'S'); 11438 11439 -- Create a declaration for the anonymous access type: either 11440 -- an access_to_object or an access_to_subprogram. 11441 11442 if Present (Acc_Def) then 11443 if Nkind (Acc_Def) = N_Access_Function_Definition then 11444 Type_Def := 11445 Make_Access_Function_Definition (Loc, 11446 Parameter_Specifications => 11447 Parameter_Specifications (Acc_Def), 11448 Result_Definition => Result_Definition (Acc_Def)); 11449 else 11450 Type_Def := 11451 Make_Access_Procedure_Definition (Loc, 11452 Parameter_Specifications => 11453 Parameter_Specifications (Acc_Def)); 11454 end if; 11455 11456 else 11457 Type_Def := 11458 Make_Access_To_Object_Definition (Loc, 11459 Subtype_Indication => 11460 Relocate_Node 11461 (Subtype_Mark (Access_Definition (Comp_Def)))); 11462 11463 Set_Constant_Present 11464 (Type_Def, Constant_Present (Access_Definition (Comp_Def))); 11465 Set_All_Present 11466 (Type_Def, All_Present (Access_Definition (Comp_Def))); 11467 end if; 11468 11469 Set_Null_Exclusion_Present 11470 (Type_Def, 11471 Null_Exclusion_Present (Access_Definition (Comp_Def))); 11472 11473 Decl := 11474 Make_Full_Type_Declaration (Loc, 11475 Defining_Identifier => Anon_Access, 11476 Type_Definition => Type_Def); 11477 11478 Insert_Before (Typ_Decl, Decl); 11479 Analyze (Decl); 11480 11481 -- If an access to subprogram, create the extra formals 11482 11483 if Present (Acc_Def) then 11484 Create_Extra_Formals (Designated_Type (Anon_Access)); 11485 11486 -- If an access to object, preserve entity of designated type, 11487 -- for ASIS use, before rewriting the component definition. 11488 11489 else 11490 declare 11491 Desig : Entity_Id; 11492 11493 begin 11494 Desig := Entity (Subtype_Indication (Type_Def)); 11495 11496 -- If the access definition is to the current record, 11497 -- the visible entity at this point is an incomplete 11498 -- type. Retrieve the full view to simplify ASIS queries 11499 11500 if Ekind (Desig) = E_Incomplete_Type then 11501 Desig := Full_View (Desig); 11502 end if; 11503 11504 Set_Entity 11505 (Subtype_Mark (Access_Definition (Comp_Def)), Desig); 11506 end; 11507 end if; 11508 11509 Rewrite (Comp_Def, 11510 Make_Component_Definition (Loc, 11511 Subtype_Indication => 11512 New_Occurrence_Of (Anon_Access, Loc))); 11513 11514 if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then 11515 Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); 11516 else 11517 Set_Ekind (Anon_Access, E_Anonymous_Access_Type); 11518 end if; 11519 11520 Set_Is_Local_Anonymous_Access (Anon_Access); 11521 end if; 11522 11523 Next (Comp); 11524 end loop; 11525 11526 if Present (Variant_Part (Comp_List)) then 11527 declare 11528 V : Node_Id; 11529 begin 11530 V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 11531 while Present (V) loop 11532 Check_Anonymous_Access_Components 11533 (Typ_Decl, Typ, Prev, Component_List (V)); 11534 Next_Non_Pragma (V); 11535 end loop; 11536 end; 11537 end if; 11538 end Check_Anonymous_Access_Components; 11539 11540 ---------------------- 11541 -- Check_Completion -- 11542 ---------------------- 11543 11544 procedure Check_Completion (Body_Id : Node_Id := Empty) is 11545 E : Entity_Id; 11546 11547 procedure Post_Error; 11548 -- Post error message for lack of completion for entity E 11549 11550 ---------------- 11551 -- Post_Error -- 11552 ---------------- 11553 11554 procedure Post_Error is 11555 procedure Missing_Body; 11556 -- Output missing body message 11557 11558 ------------------ 11559 -- Missing_Body -- 11560 ------------------ 11561 11562 procedure Missing_Body is 11563 begin 11564 -- Spec is in same unit, so we can post on spec 11565 11566 if In_Same_Source_Unit (Body_Id, E) then 11567 Error_Msg_N ("missing body for &", E); 11568 11569 -- Spec is in a separate unit, so we have to post on the body 11570 11571 else 11572 Error_Msg_NE ("missing body for & declared#!", Body_Id, E); 11573 end if; 11574 end Missing_Body; 11575 11576 -- Start of processing for Post_Error 11577 11578 begin 11579 if not Comes_From_Source (E) then 11580 if Ekind_In (E, E_Task_Type, E_Protected_Type) then 11581 11582 -- It may be an anonymous protected type created for a 11583 -- single variable. Post error on variable, if present. 11584 11585 declare 11586 Var : Entity_Id; 11587 11588 begin 11589 Var := First_Entity (Current_Scope); 11590 while Present (Var) loop 11591 exit when Etype (Var) = E 11592 and then Comes_From_Source (Var); 11593 11594 Next_Entity (Var); 11595 end loop; 11596 11597 if Present (Var) then 11598 E := Var; 11599 end if; 11600 end; 11601 end if; 11602 end if; 11603 11604 -- If a generated entity has no completion, then either previous 11605 -- semantic errors have disabled the expansion phase, or else we had 11606 -- missing subunits, or else we are compiling without expansion, 11607 -- or else something is very wrong. 11608 11609 if not Comes_From_Source (E) then 11610 pragma Assert 11611 (Serious_Errors_Detected > 0 11612 or else Configurable_Run_Time_Violations > 0 11613 or else Subunits_Missing 11614 or else not Expander_Active); 11615 return; 11616 11617 -- Here for source entity 11618 11619 else 11620 -- Here if no body to post the error message, so we post the error 11621 -- on the declaration that has no completion. This is not really 11622 -- the right place to post it, think about this later ??? 11623 11624 if No (Body_Id) then 11625 if Is_Type (E) then 11626 Error_Msg_NE 11627 ("missing full declaration for }", Parent (E), E); 11628 else 11629 Error_Msg_NE ("missing body for &", Parent (E), E); 11630 end if; 11631 11632 -- Package body has no completion for a declaration that appears 11633 -- in the corresponding spec. Post error on the body, with a 11634 -- reference to the non-completed declaration. 11635 11636 else 11637 Error_Msg_Sloc := Sloc (E); 11638 11639 if Is_Type (E) then 11640 Error_Msg_NE ("missing full declaration for }!", Body_Id, E); 11641 11642 elsif Is_Overloadable (E) 11643 and then Current_Entity_In_Scope (E) /= E 11644 then 11645 -- It may be that the completion is mistyped and appears as 11646 -- a distinct overloading of the entity. 11647 11648 declare 11649 Candidate : constant Entity_Id := 11650 Current_Entity_In_Scope (E); 11651 Decl : constant Node_Id := 11652 Unit_Declaration_Node (Candidate); 11653 11654 begin 11655 if Is_Overloadable (Candidate) 11656 and then Ekind (Candidate) = Ekind (E) 11657 and then Nkind (Decl) = N_Subprogram_Body 11658 and then Acts_As_Spec (Decl) 11659 then 11660 Check_Type_Conformant (Candidate, E); 11661 11662 else 11663 Missing_Body; 11664 end if; 11665 end; 11666 11667 else 11668 Missing_Body; 11669 end if; 11670 end if; 11671 end if; 11672 end Post_Error; 11673 11674 -- Local variables 11675 11676 Pack_Id : constant Entity_Id := Current_Scope; 11677 11678 -- Start of processing for Check_Completion 11679 11680 begin 11681 E := First_Entity (Pack_Id); 11682 while Present (E) loop 11683 if Is_Intrinsic_Subprogram (E) then 11684 null; 11685 11686 -- The following situation requires special handling: a child unit 11687 -- that appears in the context clause of the body of its parent: 11688 11689 -- procedure Parent.Child (...); 11690 11691 -- with Parent.Child; 11692 -- package body Parent is 11693 11694 -- Here Parent.Child appears as a local entity, but should not be 11695 -- flagged as requiring completion, because it is a compilation 11696 -- unit. 11697 11698 -- Ignore missing completion for a subprogram that does not come from 11699 -- source (including the _Call primitive operation of RAS types, 11700 -- which has to have the flag Comes_From_Source for other purposes): 11701 -- we assume that the expander will provide the missing completion. 11702 -- In case of previous errors, other expansion actions that provide 11703 -- bodies for null procedures with not be invoked, so inhibit message 11704 -- in those cases. 11705 11706 -- Note that E_Operator is not in the list that follows, because 11707 -- this kind is reserved for predefined operators, that are 11708 -- intrinsic and do not need completion. 11709 11710 elsif Ekind_In (E, E_Function, 11711 E_Procedure, 11712 E_Generic_Function, 11713 E_Generic_Procedure) 11714 then 11715 if Has_Completion (E) then 11716 null; 11717 11718 elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then 11719 null; 11720 11721 elsif Is_Subprogram (E) 11722 and then (not Comes_From_Source (E) 11723 or else Chars (E) = Name_uCall) 11724 then 11725 null; 11726 11727 elsif 11728 Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit 11729 then 11730 null; 11731 11732 elsif Nkind (Parent (E)) = N_Procedure_Specification 11733 and then Null_Present (Parent (E)) 11734 and then Serious_Errors_Detected > 0 11735 then 11736 null; 11737 11738 else 11739 Post_Error; 11740 end if; 11741 11742 elsif Is_Entry (E) then 11743 if not Has_Completion (E) and then 11744 (Ekind (Scope (E)) = E_Protected_Object 11745 or else Ekind (Scope (E)) = E_Protected_Type) 11746 then 11747 Post_Error; 11748 end if; 11749 11750 elsif Is_Package_Or_Generic_Package (E) then 11751 if Unit_Requires_Body (E) then 11752 if not Has_Completion (E) 11753 and then Nkind (Parent (Unit_Declaration_Node (E))) /= 11754 N_Compilation_Unit 11755 then 11756 Post_Error; 11757 end if; 11758 11759 elsif not Is_Child_Unit (E) then 11760 May_Need_Implicit_Body (E); 11761 end if; 11762 11763 -- A formal incomplete type (Ada 2012) does not require a completion; 11764 -- other incomplete type declarations do. 11765 11766 elsif Ekind (E) = E_Incomplete_Type 11767 and then No (Underlying_Type (E)) 11768 and then not Is_Generic_Type (E) 11769 then 11770 Post_Error; 11771 11772 elsif Ekind_In (E, E_Task_Type, E_Protected_Type) 11773 and then not Has_Completion (E) 11774 then 11775 Post_Error; 11776 11777 -- A single task declared in the current scope is a constant, verify 11778 -- that the body of its anonymous type is in the same scope. If the 11779 -- task is defined elsewhere, this may be a renaming declaration for 11780 -- which no completion is needed. 11781 11782 elsif Ekind (E) = E_Constant 11783 and then Ekind (Etype (E)) = E_Task_Type 11784 and then not Has_Completion (Etype (E)) 11785 and then Scope (Etype (E)) = Current_Scope 11786 then 11787 Post_Error; 11788 11789 elsif Ekind (E) = E_Protected_Object 11790 and then not Has_Completion (Etype (E)) 11791 then 11792 Post_Error; 11793 11794 elsif Ekind (E) = E_Record_Type then 11795 if Is_Tagged_Type (E) then 11796 Check_Abstract_Overriding (E); 11797 Check_Conventions (E); 11798 end if; 11799 11800 Check_Aliased_Component_Types (E); 11801 11802 elsif Ekind (E) = E_Array_Type then 11803 Check_Aliased_Component_Types (E); 11804 11805 end if; 11806 11807 Next_Entity (E); 11808 end loop; 11809 end Check_Completion; 11810 11811 ------------------------------------ 11812 -- Check_CPP_Type_Has_No_Defaults -- 11813 ------------------------------------ 11814 11815 procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is 11816 Tdef : constant Node_Id := Type_Definition (Declaration_Node (T)); 11817 Clist : Node_Id; 11818 Comp : Node_Id; 11819 11820 begin 11821 -- Obtain the component list 11822 11823 if Nkind (Tdef) = N_Record_Definition then 11824 Clist := Component_List (Tdef); 11825 else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); 11826 Clist := Component_List (Record_Extension_Part (Tdef)); 11827 end if; 11828 11829 -- Check all components to ensure no default expressions 11830 11831 if Present (Clist) then 11832 Comp := First (Component_Items (Clist)); 11833 while Present (Comp) loop 11834 if Present (Expression (Comp)) then 11835 Error_Msg_N 11836 ("component of imported 'C'P'P type cannot have " 11837 & "default expression", Expression (Comp)); 11838 end if; 11839 11840 Next (Comp); 11841 end loop; 11842 end if; 11843 end Check_CPP_Type_Has_No_Defaults; 11844 11845 ---------------------------- 11846 -- Check_Delta_Expression -- 11847 ---------------------------- 11848 11849 procedure Check_Delta_Expression (E : Node_Id) is 11850 begin 11851 if not (Is_Real_Type (Etype (E))) then 11852 Wrong_Type (E, Any_Real); 11853 11854 elsif not Is_OK_Static_Expression (E) then 11855 Flag_Non_Static_Expr 11856 ("non-static expression used for delta value!", E); 11857 11858 elsif not UR_Is_Positive (Expr_Value_R (E)) then 11859 Error_Msg_N ("delta expression must be positive", E); 11860 11861 else 11862 return; 11863 end if; 11864 11865 -- If any of above errors occurred, then replace the incorrect 11866 -- expression by the real 0.1, which should prevent further errors. 11867 11868 Rewrite (E, 11869 Make_Real_Literal (Sloc (E), Ureal_Tenth)); 11870 Analyze_And_Resolve (E, Standard_Float); 11871 end Check_Delta_Expression; 11872 11873 ----------------------------- 11874 -- Check_Digits_Expression -- 11875 ----------------------------- 11876 11877 procedure Check_Digits_Expression (E : Node_Id) is 11878 begin 11879 if not (Is_Integer_Type (Etype (E))) then 11880 Wrong_Type (E, Any_Integer); 11881 11882 elsif not Is_OK_Static_Expression (E) then 11883 Flag_Non_Static_Expr 11884 ("non-static expression used for digits value!", E); 11885 11886 elsif Expr_Value (E) <= 0 then 11887 Error_Msg_N ("digits value must be greater than zero", E); 11888 11889 else 11890 return; 11891 end if; 11892 11893 -- If any of above errors occurred, then replace the incorrect 11894 -- expression by the integer 1, which should prevent further errors. 11895 11896 Rewrite (E, Make_Integer_Literal (Sloc (E), 1)); 11897 Analyze_And_Resolve (E, Standard_Integer); 11898 11899 end Check_Digits_Expression; 11900 11901 -------------------------- 11902 -- Check_Initialization -- 11903 -------------------------- 11904 11905 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is 11906 begin 11907 -- Special processing for limited types 11908 11909 if Is_Limited_Type (T) 11910 and then not In_Instance 11911 and then not In_Inlined_Body 11912 then 11913 if not OK_For_Limited_Init (T, Exp) then 11914 11915 -- In GNAT mode, this is just a warning, to allow it to be evilly 11916 -- turned off. Otherwise it is a real error. 11917 11918 if GNAT_Mode then 11919 Error_Msg_N 11920 ("??cannot initialize entities of limited type!", Exp); 11921 11922 elsif Ada_Version < Ada_2005 then 11923 11924 -- The side effect removal machinery may generate illegal Ada 11925 -- code to avoid the usage of access types and 'reference in 11926 -- SPARK mode. Since this is legal code with respect to theorem 11927 -- proving, do not emit the error. 11928 11929 if GNATprove_Mode 11930 and then Nkind (Exp) = N_Function_Call 11931 and then Nkind (Parent (Exp)) = N_Object_Declaration 11932 and then not Comes_From_Source 11933 (Defining_Identifier (Parent (Exp))) 11934 then 11935 null; 11936 11937 else 11938 Error_Msg_N 11939 ("cannot initialize entities of limited type", Exp); 11940 Explain_Limited_Type (T, Exp); 11941 end if; 11942 11943 else 11944 -- Specialize error message according to kind of illegal 11945 -- initial expression. We check the Original_Node to cover 11946 -- cases where the initialization expression of an object 11947 -- declaration generated by the compiler has been rewritten 11948 -- (such as for dispatching calls). 11949 11950 if Nkind (Original_Node (Exp)) = N_Type_Conversion 11951 and then 11952 Nkind (Expression (Original_Node (Exp))) = N_Function_Call 11953 then 11954 -- No error for internally-generated object declarations, 11955 -- which can come from build-in-place assignment statements. 11956 11957 if Nkind (Parent (Exp)) = N_Object_Declaration 11958 and then not Comes_From_Source 11959 (Defining_Identifier (Parent (Exp))) 11960 then 11961 null; 11962 11963 else 11964 Error_Msg_N 11965 ("illegal context for call to function with limited " 11966 & "result", Exp); 11967 end if; 11968 11969 else 11970 Error_Msg_N 11971 ("initialization of limited object requires aggregate or " 11972 & "function call", Exp); 11973 end if; 11974 end if; 11975 end if; 11976 end if; 11977 11978 -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets 11979 -- set unless we can be sure that no range check is required. 11980 11981 if (GNATprove_Mode or not Expander_Active) 11982 and then Is_Scalar_Type (T) 11983 and then not Is_In_Range (Exp, T, Assume_Valid => True) 11984 then 11985 Set_Do_Range_Check (Exp); 11986 end if; 11987 end Check_Initialization; 11988 11989 ---------------------- 11990 -- Check_Interfaces -- 11991 ---------------------- 11992 11993 procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is 11994 Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); 11995 11996 Iface : Node_Id; 11997 Iface_Def : Node_Id; 11998 Iface_Typ : Entity_Id; 11999 Parent_Node : Node_Id; 12000 12001 Is_Task : Boolean := False; 12002 -- Set True if parent type or any progenitor is a task interface 12003 12004 Is_Protected : Boolean := False; 12005 -- Set True if parent type or any progenitor is a protected interface 12006 12007 procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); 12008 -- Check that a progenitor is compatible with declaration. If an error 12009 -- message is output, it is posted on Error_Node. 12010 12011 ------------------ 12012 -- Check_Ifaces -- 12013 ------------------ 12014 12015 procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is 12016 Iface_Id : constant Entity_Id := 12017 Defining_Identifier (Parent (Iface_Def)); 12018 Type_Def : Node_Id; 12019 12020 begin 12021 if Nkind (N) = N_Private_Extension_Declaration then 12022 Type_Def := N; 12023 else 12024 Type_Def := Type_Definition (N); 12025 end if; 12026 12027 if Is_Task_Interface (Iface_Id) then 12028 Is_Task := True; 12029 12030 elsif Is_Protected_Interface (Iface_Id) then 12031 Is_Protected := True; 12032 end if; 12033 12034 if Is_Synchronized_Interface (Iface_Id) then 12035 12036 -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private 12037 -- extension derived from a synchronized interface must explicitly 12038 -- be declared synchronized, because the full view will be a 12039 -- synchronized type. 12040 12041 if Nkind (N) = N_Private_Extension_Declaration then 12042 if not Synchronized_Present (N) then 12043 Error_Msg_NE 12044 ("private extension of& must be explicitly synchronized", 12045 N, Iface_Id); 12046 end if; 12047 12048 -- However, by 3.9.4(16/2), a full type that is a record extension 12049 -- is never allowed to derive from a synchronized interface (note 12050 -- that interfaces must be excluded from this check, because those 12051 -- are represented by derived type definitions in some cases). 12052 12053 elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition 12054 and then not Interface_Present (Type_Definition (N)) 12055 then 12056 Error_Msg_N ("record extension cannot derive from synchronized " 12057 & "interface", Error_Node); 12058 end if; 12059 end if; 12060 12061 -- Check that the characteristics of the progenitor are compatible 12062 -- with the explicit qualifier in the declaration. 12063 -- The check only applies to qualifiers that come from source. 12064 -- Limited_Present also appears in the declaration of corresponding 12065 -- records, and the check does not apply to them. 12066 12067 if Limited_Present (Type_Def) 12068 and then not 12069 Is_Concurrent_Record_Type (Defining_Identifier (N)) 12070 then 12071 if Is_Limited_Interface (Parent_Type) 12072 and then not Is_Limited_Interface (Iface_Id) 12073 then 12074 Error_Msg_NE 12075 ("progenitor & must be limited interface", 12076 Error_Node, Iface_Id); 12077 12078 elsif 12079 (Task_Present (Iface_Def) 12080 or else Protected_Present (Iface_Def) 12081 or else Synchronized_Present (Iface_Def)) 12082 and then Nkind (N) /= N_Private_Extension_Declaration 12083 and then not Error_Posted (N) 12084 then 12085 Error_Msg_NE 12086 ("progenitor & must be limited interface", 12087 Error_Node, Iface_Id); 12088 end if; 12089 12090 -- Protected interfaces can only inherit from limited, synchronized 12091 -- or protected interfaces. 12092 12093 elsif Nkind (N) = N_Full_Type_Declaration 12094 and then Protected_Present (Type_Def) 12095 then 12096 if Limited_Present (Iface_Def) 12097 or else Synchronized_Present (Iface_Def) 12098 or else Protected_Present (Iface_Def) 12099 then 12100 null; 12101 12102 elsif Task_Present (Iface_Def) then 12103 Error_Msg_N ("(Ada 2005) protected interface cannot inherit " 12104 & "from task interface", Error_Node); 12105 12106 else 12107 Error_Msg_N ("(Ada 2005) protected interface cannot inherit " 12108 & "from non-limited interface", Error_Node); 12109 end if; 12110 12111 -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from 12112 -- limited and synchronized. 12113 12114 elsif Synchronized_Present (Type_Def) then 12115 if Limited_Present (Iface_Def) 12116 or else Synchronized_Present (Iface_Def) 12117 then 12118 null; 12119 12120 elsif Protected_Present (Iface_Def) 12121 and then Nkind (N) /= N_Private_Extension_Declaration 12122 then 12123 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " 12124 & "from protected interface", Error_Node); 12125 12126 elsif Task_Present (Iface_Def) 12127 and then Nkind (N) /= N_Private_Extension_Declaration 12128 then 12129 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " 12130 & "from task interface", Error_Node); 12131 12132 elsif not Is_Limited_Interface (Iface_Id) then 12133 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " 12134 & "from non-limited interface", Error_Node); 12135 end if; 12136 12137 -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, 12138 -- synchronized or task interfaces. 12139 12140 elsif Nkind (N) = N_Full_Type_Declaration 12141 and then Task_Present (Type_Def) 12142 then 12143 if Limited_Present (Iface_Def) 12144 or else Synchronized_Present (Iface_Def) 12145 or else Task_Present (Iface_Def) 12146 then 12147 null; 12148 12149 elsif Protected_Present (Iface_Def) then 12150 Error_Msg_N ("(Ada 2005) task interface cannot inherit from " 12151 & "protected interface", Error_Node); 12152 12153 else 12154 Error_Msg_N ("(Ada 2005) task interface cannot inherit from " 12155 & "non-limited interface", Error_Node); 12156 end if; 12157 end if; 12158 end Check_Ifaces; 12159 12160 -- Start of processing for Check_Interfaces 12161 12162 begin 12163 if Is_Interface (Parent_Type) then 12164 if Is_Task_Interface (Parent_Type) then 12165 Is_Task := True; 12166 12167 elsif Is_Protected_Interface (Parent_Type) then 12168 Is_Protected := True; 12169 end if; 12170 end if; 12171 12172 if Nkind (N) = N_Private_Extension_Declaration then 12173 12174 -- Check that progenitors are compatible with declaration 12175 12176 Iface := First (Interface_List (Def)); 12177 while Present (Iface) loop 12178 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 12179 12180 Parent_Node := Parent (Base_Type (Iface_Typ)); 12181 Iface_Def := Type_Definition (Parent_Node); 12182 12183 if not Is_Interface (Iface_Typ) then 12184 Diagnose_Interface (Iface, Iface_Typ); 12185 else 12186 Check_Ifaces (Iface_Def, Iface); 12187 end if; 12188 12189 Next (Iface); 12190 end loop; 12191 12192 if Is_Task and Is_Protected then 12193 Error_Msg_N 12194 ("type cannot derive from task and protected interface", N); 12195 end if; 12196 12197 return; 12198 end if; 12199 12200 -- Full type declaration of derived type. 12201 -- Check compatibility with parent if it is interface type 12202 12203 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition 12204 and then Is_Interface (Parent_Type) 12205 then 12206 Parent_Node := Parent (Parent_Type); 12207 12208 -- More detailed checks for interface varieties 12209 12210 Check_Ifaces 12211 (Iface_Def => Type_Definition (Parent_Node), 12212 Error_Node => Subtype_Indication (Type_Definition (N))); 12213 end if; 12214 12215 Iface := First (Interface_List (Def)); 12216 while Present (Iface) loop 12217 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 12218 12219 Parent_Node := Parent (Base_Type (Iface_Typ)); 12220 Iface_Def := Type_Definition (Parent_Node); 12221 12222 if not Is_Interface (Iface_Typ) then 12223 Diagnose_Interface (Iface, Iface_Typ); 12224 12225 else 12226 -- "The declaration of a specific descendant of an interface 12227 -- type freezes the interface type" RM 13.14 12228 12229 Freeze_Before (N, Iface_Typ); 12230 Check_Ifaces (Iface_Def, Error_Node => Iface); 12231 end if; 12232 12233 Next (Iface); 12234 end loop; 12235 12236 if Is_Task and Is_Protected then 12237 Error_Msg_N 12238 ("type cannot derive from task and protected interface", N); 12239 end if; 12240 end Check_Interfaces; 12241 12242 ------------------------------------ 12243 -- Check_Or_Process_Discriminants -- 12244 ------------------------------------ 12245 12246 -- If an incomplete or private type declaration was already given for the 12247 -- type, the discriminants may have already been processed if they were 12248 -- present on the incomplete declaration. In this case a full conformance 12249 -- check has been performed in Find_Type_Name, and we then recheck here 12250 -- some properties that can't be checked on the partial view alone. 12251 -- Otherwise we call Process_Discriminants. 12252 12253 procedure Check_Or_Process_Discriminants 12254 (N : Node_Id; 12255 T : Entity_Id; 12256 Prev : Entity_Id := Empty) 12257 is 12258 begin 12259 if Has_Discriminants (T) then 12260 12261 -- Discriminants are already set on T if they were already present 12262 -- on the partial view. Make them visible to component declarations. 12263 12264 declare 12265 D : Entity_Id; 12266 -- Discriminant on T (full view) referencing expr on partial view 12267 12268 Prev_D : Entity_Id; 12269 -- Entity of corresponding discriminant on partial view 12270 12271 New_D : Node_Id; 12272 -- Discriminant specification for full view, expression is 12273 -- the syntactic copy on full view (which has been checked for 12274 -- conformance with partial view), only used here to post error 12275 -- message. 12276 12277 begin 12278 D := First_Discriminant (T); 12279 New_D := First (Discriminant_Specifications (N)); 12280 while Present (D) loop 12281 Prev_D := Current_Entity (D); 12282 Set_Current_Entity (D); 12283 Set_Is_Immediately_Visible (D); 12284 Set_Homonym (D, Prev_D); 12285 12286 -- Handle the case where there is an untagged partial view and 12287 -- the full view is tagged: must disallow discriminants with 12288 -- defaults, unless compiling for Ada 2012, which allows a 12289 -- limited tagged type to have defaulted discriminants (see 12290 -- AI05-0214). However, suppress error here if it was already 12291 -- reported on the default expression of the partial view. 12292 12293 if Is_Tagged_Type (T) 12294 and then Present (Expression (Parent (D))) 12295 and then (not Is_Limited_Type (Current_Scope) 12296 or else Ada_Version < Ada_2012) 12297 and then not Error_Posted (Expression (Parent (D))) 12298 then 12299 if Ada_Version >= Ada_2012 then 12300 Error_Msg_N 12301 ("discriminants of nonlimited tagged type cannot have " 12302 & "defaults", 12303 Expression (New_D)); 12304 else 12305 Error_Msg_N 12306 ("discriminants of tagged type cannot have defaults", 12307 Expression (New_D)); 12308 end if; 12309 end if; 12310 12311 -- Ada 2005 (AI-230): Access discriminant allowed in 12312 -- non-limited record types. 12313 12314 if Ada_Version < Ada_2005 then 12315 12316 -- This restriction gets applied to the full type here. It 12317 -- has already been applied earlier to the partial view. 12318 12319 Check_Access_Discriminant_Requires_Limited (Parent (D), N); 12320 end if; 12321 12322 Next_Discriminant (D); 12323 Next (New_D); 12324 end loop; 12325 end; 12326 12327 elsif Present (Discriminant_Specifications (N)) then 12328 Process_Discriminants (N, Prev); 12329 end if; 12330 end Check_Or_Process_Discriminants; 12331 12332 ---------------------- 12333 -- Check_Real_Bound -- 12334 ---------------------- 12335 12336 procedure Check_Real_Bound (Bound : Node_Id) is 12337 begin 12338 if not Is_Real_Type (Etype (Bound)) then 12339 Error_Msg_N 12340 ("bound in real type definition must be of real type", Bound); 12341 12342 elsif not Is_OK_Static_Expression (Bound) then 12343 Flag_Non_Static_Expr 12344 ("non-static expression used for real type bound!", Bound); 12345 12346 else 12347 return; 12348 end if; 12349 12350 Rewrite 12351 (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0)); 12352 Analyze (Bound); 12353 Resolve (Bound, Standard_Float); 12354 end Check_Real_Bound; 12355 12356 ------------------------------ 12357 -- Complete_Private_Subtype -- 12358 ------------------------------ 12359 12360 procedure Complete_Private_Subtype 12361 (Priv : Entity_Id; 12362 Full : Entity_Id; 12363 Full_Base : Entity_Id; 12364 Related_Nod : Node_Id) 12365 is 12366 Save_Next_Entity : Entity_Id; 12367 Save_Homonym : Entity_Id; 12368 12369 begin 12370 -- Set semantic attributes for (implicit) private subtype completion. 12371 -- If the full type has no discriminants, then it is a copy of the 12372 -- full view of the base. Otherwise, it is a subtype of the base with 12373 -- a possible discriminant constraint. Save and restore the original 12374 -- Next_Entity field of full to ensure that the calls to Copy_Node do 12375 -- not corrupt the entity chain. 12376 12377 Save_Next_Entity := Next_Entity (Full); 12378 Save_Homonym := Homonym (Priv); 12379 12380 if Is_Private_Type (Full_Base) 12381 or else Is_Record_Type (Full_Base) 12382 or else Is_Concurrent_Type (Full_Base) 12383 then 12384 Copy_Node (Priv, Full); 12385 12386 -- Note that the Etype of the full view is the same as the Etype of 12387 -- the partial view. In this fashion, the subtype has access to the 12388 -- correct view of the parent. 12389 12390 Set_Has_Discriminants (Full, Has_Discriminants (Full_Base)); 12391 Set_Has_Unknown_Discriminants 12392 (Full, Has_Unknown_Discriminants (Full_Base)); 12393 Set_First_Entity (Full, First_Entity (Full_Base)); 12394 Set_Last_Entity (Full, Last_Entity (Full_Base)); 12395 12396 -- If the underlying base type is constrained, we know that the 12397 -- full view of the subtype is constrained as well (the converse 12398 -- is not necessarily true). 12399 12400 if Is_Constrained (Full_Base) then 12401 Set_Is_Constrained (Full); 12402 end if; 12403 12404 else 12405 Copy_Node (Full_Base, Full); 12406 12407 -- The following subtlety with the Etype of the full view needs to be 12408 -- taken into account here. One could think that it must naturally be 12409 -- set to the base type of the full base: 12410 12411 -- Set_Etype (Full, Base_Type (Full_Base)); 12412 12413 -- so that the full view becomes a subtype of the full base when the 12414 -- latter is a base type, which must for example happen when the full 12415 -- base is declared as derived type. That's also correct if the full 12416 -- base is declared as an array type, or a floating-point type, or a 12417 -- fixed-point type, or a signed integer type, as these declarations 12418 -- create an implicit base type and a first subtype so the Etype of 12419 -- the full views must be the implicit base type. But that's wrong 12420 -- if the full base is declared as an access type, or an enumeration 12421 -- type, or a modular integer type, as these declarations directly 12422 -- create a base type, i.e. with Etype pointing to itself. Moreover 12423 -- the full base being declared in the private part, i.e. when the 12424 -- views are swapped, the end result is that the Etype of the full 12425 -- base is set to its private view in this case and that we need to 12426 -- propagate this setting to the full view in order for the subtype 12427 -- to be compatible with the base type. 12428 12429 if Is_Base_Type (Full_Base) 12430 and then (Is_Derived_Type (Full_Base) 12431 or else Ekind (Full_Base) in Array_Kind 12432 or else Ekind (Full_Base) in Fixed_Point_Kind 12433 or else Ekind (Full_Base) in Float_Kind 12434 or else Ekind (Full_Base) in Signed_Integer_Kind) 12435 then 12436 Set_Etype (Full, Full_Base); 12437 end if; 12438 12439 Set_Chars (Full, Chars (Priv)); 12440 Set_Sloc (Full, Sloc (Priv)); 12441 Conditional_Delay (Full, Priv); 12442 end if; 12443 12444 Link_Entities (Full, Save_Next_Entity); 12445 Set_Homonym (Full, Save_Homonym); 12446 Set_Associated_Node_For_Itype (Full, Related_Nod); 12447 12448 -- Set common attributes for all subtypes: kind, convention, etc. 12449 12450 Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); 12451 Set_Convention (Full, Convention (Full_Base)); 12452 Set_Is_First_Subtype (Full, False); 12453 Set_Scope (Full, Scope (Priv)); 12454 Set_Size_Info (Full, Full_Base); 12455 Set_RM_Size (Full, RM_Size (Full_Base)); 12456 Set_Is_Itype (Full); 12457 12458 -- A subtype of a private-type-without-discriminants, whose full-view 12459 -- has discriminants with default expressions, is not constrained. 12460 12461 if not Has_Discriminants (Priv) then 12462 Set_Is_Constrained (Full, Is_Constrained (Full_Base)); 12463 12464 if Has_Discriminants (Full_Base) then 12465 Set_Discriminant_Constraint 12466 (Full, Discriminant_Constraint (Full_Base)); 12467 12468 -- The partial view may have been indefinite, the full view 12469 -- might not be. 12470 12471 Set_Has_Unknown_Discriminants 12472 (Full, Has_Unknown_Discriminants (Full_Base)); 12473 end if; 12474 end if; 12475 12476 Set_First_Rep_Item (Full, First_Rep_Item (Full_Base)); 12477 Set_Depends_On_Private (Full, Has_Private_Component (Full)); 12478 12479 -- Freeze the private subtype entity if its parent is delayed, and not 12480 -- already frozen. We skip this processing if the type is an anonymous 12481 -- subtype of a record component, or is the corresponding record of a 12482 -- protected type, since these are processed when the enclosing type 12483 -- is frozen. If the parent type is declared in a nested package then 12484 -- the freezing of the private and full views also happens later. 12485 12486 if not Is_Type (Scope (Full)) then 12487 if Is_Itype (Priv) 12488 and then In_Same_Source_Unit (Full, Full_Base) 12489 and then Scope (Full_Base) /= Scope (Full) 12490 then 12491 Set_Has_Delayed_Freeze (Full); 12492 Set_Has_Delayed_Freeze (Priv); 12493 12494 else 12495 Set_Has_Delayed_Freeze (Full, 12496 Has_Delayed_Freeze (Full_Base) 12497 and then not Is_Frozen (Full_Base)); 12498 end if; 12499 end if; 12500 12501 Set_Freeze_Node (Full, Empty); 12502 Set_Is_Frozen (Full, False); 12503 12504 if Has_Discriminants (Full) then 12505 Set_Stored_Constraint_From_Discriminant_Constraint (Full); 12506 Set_Stored_Constraint (Priv, Stored_Constraint (Full)); 12507 12508 if Has_Unknown_Discriminants (Full) then 12509 Set_Discriminant_Constraint (Full, No_Elist); 12510 end if; 12511 end if; 12512 12513 if Ekind (Full_Base) = E_Record_Type 12514 and then Has_Discriminants (Full_Base) 12515 and then Has_Discriminants (Priv) -- might not, if errors 12516 and then not Has_Unknown_Discriminants (Priv) 12517 and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv)) 12518 then 12519 Create_Constrained_Components 12520 (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv)); 12521 12522 -- If the full base is itself derived from private, build a congruent 12523 -- subtype of its underlying full view, for use by the back end. 12524 12525 elsif Is_Private_Type (Full_Base) 12526 and then Present (Underlying_Full_View (Full_Base)) 12527 then 12528 declare 12529 Underlying_Full_Base : constant Entity_Id 12530 := Underlying_Full_View (Full_Base); 12531 Underlying_Full : constant Entity_Id 12532 := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); 12533 begin 12534 Set_Is_Itype (Underlying_Full); 12535 Set_Associated_Node_For_Itype (Underlying_Full, Related_Nod); 12536 Complete_Private_Subtype 12537 (Priv, Underlying_Full, Underlying_Full_Base, Related_Nod); 12538 Set_Underlying_Full_View (Full, Underlying_Full); 12539 Set_Is_Underlying_Full_View (Underlying_Full); 12540 end; 12541 12542 elsif Is_Record_Type (Full_Base) then 12543 12544 -- Show Full is simply a renaming of Full_Base 12545 12546 Set_Cloned_Subtype (Full, Full_Base); 12547 12548 -- Propagate predicates 12549 12550 if Has_Predicates (Full_Base) then 12551 Set_Has_Predicates (Full); 12552 12553 if Present (Predicate_Function (Full_Base)) 12554 and then No (Predicate_Function (Full)) 12555 then 12556 Set_Predicate_Function (Full, Predicate_Function (Full_Base)); 12557 end if; 12558 end if; 12559 end if; 12560 12561 -- It is unsafe to share the bounds of a scalar type, because the Itype 12562 -- is elaborated on demand, and if a bound is nonstatic, then different 12563 -- orders of elaboration in different units will lead to different 12564 -- external symbols. 12565 12566 if Is_Scalar_Type (Full_Base) then 12567 Set_Scalar_Range (Full, 12568 Make_Range (Sloc (Related_Nod), 12569 Low_Bound => 12570 Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)), 12571 High_Bound => 12572 Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base)))); 12573 12574 -- This completion inherits the bounds of the full parent, but if 12575 -- the parent is an unconstrained floating point type, so is the 12576 -- completion. 12577 12578 if Is_Floating_Point_Type (Full_Base) then 12579 Set_Includes_Infinities 12580 (Scalar_Range (Full), Has_Infinities (Full_Base)); 12581 end if; 12582 end if; 12583 12584 -- ??? It seems that a lot of fields are missing that should be copied 12585 -- from Full_Base to Full. Here are some that are introduced in a 12586 -- non-disruptive way but a cleanup is necessary. 12587 12588 if Is_Tagged_Type (Full_Base) then 12589 Set_Is_Tagged_Type (Full); 12590 Set_Direct_Primitive_Operations 12591 (Full, Direct_Primitive_Operations (Full_Base)); 12592 Set_No_Tagged_Streams_Pragma 12593 (Full, No_Tagged_Streams_Pragma (Full_Base)); 12594 12595 -- Inherit class_wide type of full_base in case the partial view was 12596 -- not tagged. Otherwise it has already been created when the private 12597 -- subtype was analyzed. 12598 12599 if No (Class_Wide_Type (Full)) then 12600 Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); 12601 end if; 12602 12603 -- If this is a subtype of a protected or task type, constrain its 12604 -- corresponding record, unless this is a subtype without constraints, 12605 -- i.e. a simple renaming as with an actual subtype in an instance. 12606 12607 elsif Is_Concurrent_Type (Full_Base) then 12608 if Has_Discriminants (Full) 12609 and then Present (Corresponding_Record_Type (Full_Base)) 12610 and then 12611 not Is_Empty_Elmt_List (Discriminant_Constraint (Full)) 12612 then 12613 Set_Corresponding_Record_Type (Full, 12614 Constrain_Corresponding_Record 12615 (Full, Corresponding_Record_Type (Full_Base), Related_Nod)); 12616 12617 else 12618 Set_Corresponding_Record_Type (Full, 12619 Corresponding_Record_Type (Full_Base)); 12620 end if; 12621 end if; 12622 12623 -- Link rep item chain, and also setting of Has_Predicates from private 12624 -- subtype to full subtype, since we will need these on the full subtype 12625 -- to create the predicate function. Note that the full subtype may 12626 -- already have rep items, inherited from the full view of the base 12627 -- type, so we must be sure not to overwrite these entries. 12628 12629 declare 12630 Append : Boolean; 12631 Item : Node_Id; 12632 Next_Item : Node_Id; 12633 Priv_Item : Node_Id; 12634 12635 begin 12636 Item := First_Rep_Item (Full); 12637 Priv_Item := First_Rep_Item (Priv); 12638 12639 -- If no existing rep items on full type, we can just link directly 12640 -- to the list of items on the private type, if any exist.. Same if 12641 -- the rep items are only those inherited from the base 12642 12643 if (No (Item) 12644 or else Nkind (Item) /= N_Aspect_Specification 12645 or else Entity (Item) = Full_Base) 12646 and then Present (First_Rep_Item (Priv)) 12647 then 12648 Set_First_Rep_Item (Full, Priv_Item); 12649 12650 -- Otherwise, search to the end of items currently linked to the full 12651 -- subtype and append the private items to the end. However, if Priv 12652 -- and Full already have the same list of rep items, then the append 12653 -- is not done, as that would create a circularity. 12654 -- 12655 -- The partial view may have a predicate and the rep item lists of 12656 -- both views agree when inherited from the same ancestor. In that 12657 -- case, simply propagate the list from one view to the other. 12658 -- A more complex analysis needed here ??? 12659 12660 elsif Present (Priv_Item) 12661 and then Item = Next_Rep_Item (Priv_Item) 12662 then 12663 Set_First_Rep_Item (Full, Priv_Item); 12664 12665 elsif Item /= Priv_Item then 12666 Append := True; 12667 loop 12668 Next_Item := Next_Rep_Item (Item); 12669 exit when No (Next_Item); 12670 Item := Next_Item; 12671 12672 -- If the private view has aspect specifications, the full view 12673 -- inherits them. Since these aspects may already have been 12674 -- attached to the full view during derivation, do not append 12675 -- them if already present. 12676 12677 if Item = First_Rep_Item (Priv) then 12678 Append := False; 12679 exit; 12680 end if; 12681 end loop; 12682 12683 -- And link the private type items at the end of the chain 12684 12685 if Append then 12686 Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); 12687 end if; 12688 end if; 12689 end; 12690 12691 -- Make sure Has_Predicates is set on full type if it is set on the 12692 -- private type. Note that it may already be set on the full type and 12693 -- if so, we don't want to unset it. Similarly, propagate information 12694 -- about delayed aspects, because the corresponding pragmas must be 12695 -- analyzed when one of the views is frozen. This last step is needed 12696 -- in particular when the full type is a scalar type for which an 12697 -- anonymous base type is constructed. 12698 12699 -- The predicate functions are generated either at the freeze point 12700 -- of the type or at the end of the visible part, and we must avoid 12701 -- generating them twice. 12702 12703 if Has_Predicates (Priv) then 12704 Set_Has_Predicates (Full); 12705 12706 if Present (Predicate_Function (Priv)) 12707 and then No (Predicate_Function (Full)) 12708 then 12709 Set_Predicate_Function (Full, Predicate_Function (Priv)); 12710 end if; 12711 end if; 12712 12713 if Has_Delayed_Aspects (Priv) then 12714 Set_Has_Delayed_Aspects (Full); 12715 end if; 12716 end Complete_Private_Subtype; 12717 12718 ---------------------------- 12719 -- Constant_Redeclaration -- 12720 ---------------------------- 12721 12722 procedure Constant_Redeclaration 12723 (Id : Entity_Id; 12724 N : Node_Id; 12725 T : out Entity_Id) 12726 is 12727 Prev : constant Entity_Id := Current_Entity_In_Scope (Id); 12728 Obj_Def : constant Node_Id := Object_Definition (N); 12729 New_T : Entity_Id; 12730 12731 procedure Check_Possible_Deferred_Completion 12732 (Prev_Id : Entity_Id; 12733 Prev_Obj_Def : Node_Id; 12734 Curr_Obj_Def : Node_Id); 12735 -- Determine whether the two object definitions describe the partial 12736 -- and the full view of a constrained deferred constant. Generate 12737 -- a subtype for the full view and verify that it statically matches 12738 -- the subtype of the partial view. 12739 12740 procedure Check_Recursive_Declaration (Typ : Entity_Id); 12741 -- If deferred constant is an access type initialized with an allocator, 12742 -- check whether there is an illegal recursion in the definition, 12743 -- through a default value of some record subcomponent. This is normally 12744 -- detected when generating init procs, but requires this additional 12745 -- mechanism when expansion is disabled. 12746 12747 ---------------------------------------- 12748 -- Check_Possible_Deferred_Completion -- 12749 ---------------------------------------- 12750 12751 procedure Check_Possible_Deferred_Completion 12752 (Prev_Id : Entity_Id; 12753 Prev_Obj_Def : Node_Id; 12754 Curr_Obj_Def : Node_Id) 12755 is 12756 begin 12757 if Nkind (Prev_Obj_Def) = N_Subtype_Indication 12758 and then Present (Constraint (Prev_Obj_Def)) 12759 and then Nkind (Curr_Obj_Def) = N_Subtype_Indication 12760 and then Present (Constraint (Curr_Obj_Def)) 12761 then 12762 declare 12763 Loc : constant Source_Ptr := Sloc (N); 12764 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); 12765 Decl : constant Node_Id := 12766 Make_Subtype_Declaration (Loc, 12767 Defining_Identifier => Def_Id, 12768 Subtype_Indication => 12769 Relocate_Node (Curr_Obj_Def)); 12770 12771 begin 12772 Insert_Before_And_Analyze (N, Decl); 12773 Set_Etype (Id, Def_Id); 12774 12775 if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then 12776 Error_Msg_Sloc := Sloc (Prev_Id); 12777 Error_Msg_N ("subtype does not statically match deferred " 12778 & "declaration #", N); 12779 end if; 12780 end; 12781 end if; 12782 end Check_Possible_Deferred_Completion; 12783 12784 --------------------------------- 12785 -- Check_Recursive_Declaration -- 12786 --------------------------------- 12787 12788 procedure Check_Recursive_Declaration (Typ : Entity_Id) is 12789 Comp : Entity_Id; 12790 12791 begin 12792 if Is_Record_Type (Typ) then 12793 Comp := First_Component (Typ); 12794 while Present (Comp) loop 12795 if Comes_From_Source (Comp) then 12796 if Present (Expression (Parent (Comp))) 12797 and then Is_Entity_Name (Expression (Parent (Comp))) 12798 and then Entity (Expression (Parent (Comp))) = Prev 12799 then 12800 Error_Msg_Sloc := Sloc (Parent (Comp)); 12801 Error_Msg_NE 12802 ("illegal circularity with declaration for & #", 12803 N, Comp); 12804 return; 12805 12806 elsif Is_Record_Type (Etype (Comp)) then 12807 Check_Recursive_Declaration (Etype (Comp)); 12808 end if; 12809 end if; 12810 12811 Next_Component (Comp); 12812 end loop; 12813 end if; 12814 end Check_Recursive_Declaration; 12815 12816 -- Start of processing for Constant_Redeclaration 12817 12818 begin 12819 if Nkind (Parent (Prev)) = N_Object_Declaration then 12820 if Nkind (Object_Definition 12821 (Parent (Prev))) = N_Subtype_Indication 12822 then 12823 -- Find type of new declaration. The constraints of the two 12824 -- views must match statically, but there is no point in 12825 -- creating an itype for the full view. 12826 12827 if Nkind (Obj_Def) = N_Subtype_Indication then 12828 Find_Type (Subtype_Mark (Obj_Def)); 12829 New_T := Entity (Subtype_Mark (Obj_Def)); 12830 12831 else 12832 Find_Type (Obj_Def); 12833 New_T := Entity (Obj_Def); 12834 end if; 12835 12836 T := Etype (Prev); 12837 12838 else 12839 -- The full view may impose a constraint, even if the partial 12840 -- view does not, so construct the subtype. 12841 12842 New_T := Find_Type_Of_Object (Obj_Def, N); 12843 T := New_T; 12844 end if; 12845 12846 else 12847 -- Current declaration is illegal, diagnosed below in Enter_Name 12848 12849 T := Empty; 12850 New_T := Any_Type; 12851 end if; 12852 12853 -- If previous full declaration or a renaming declaration exists, or if 12854 -- a homograph is present, let Enter_Name handle it, either with an 12855 -- error or with the removal of an overridden implicit subprogram. 12856 -- The previous one is a full declaration if it has an expression 12857 -- (which in the case of an aggregate is indicated by the Init flag). 12858 12859 if Ekind (Prev) /= E_Constant 12860 or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration 12861 or else Present (Expression (Parent (Prev))) 12862 or else Has_Init_Expression (Parent (Prev)) 12863 or else Present (Full_View (Prev)) 12864 then 12865 Enter_Name (Id); 12866 12867 -- Verify that types of both declarations match, or else that both types 12868 -- are anonymous access types whose designated subtypes statically match 12869 -- (as allowed in Ada 2005 by AI-385). 12870 12871 elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) 12872 and then 12873 (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type 12874 or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type 12875 or else Is_Access_Constant (Etype (New_T)) /= 12876 Is_Access_Constant (Etype (Prev)) 12877 or else Can_Never_Be_Null (Etype (New_T)) /= 12878 Can_Never_Be_Null (Etype (Prev)) 12879 or else Null_Exclusion_Present (Parent (Prev)) /= 12880 Null_Exclusion_Present (Parent (Id)) 12881 or else not Subtypes_Statically_Match 12882 (Designated_Type (Etype (Prev)), 12883 Designated_Type (Etype (New_T)))) 12884 then 12885 Error_Msg_Sloc := Sloc (Prev); 12886 Error_Msg_N ("type does not match declaration#", N); 12887 Set_Full_View (Prev, Id); 12888 Set_Etype (Id, Any_Type); 12889 12890 -- A deferred constant whose type is an anonymous array is always 12891 -- illegal (unless imported). A detailed error message might be 12892 -- helpful for Ada beginners. 12893 12894 if Nkind (Object_Definition (Parent (Prev))) 12895 = N_Constrained_Array_Definition 12896 and then Nkind (Object_Definition (N)) 12897 = N_Constrained_Array_Definition 12898 then 12899 Error_Msg_N ("\each anonymous array is a distinct type", N); 12900 Error_Msg_N ("a deferred constant must have a named type", 12901 Object_Definition (Parent (Prev))); 12902 end if; 12903 12904 elsif 12905 Null_Exclusion_Present (Parent (Prev)) 12906 and then not Null_Exclusion_Present (N) 12907 then 12908 Error_Msg_Sloc := Sloc (Prev); 12909 Error_Msg_N ("null-exclusion does not match declaration#", N); 12910 Set_Full_View (Prev, Id); 12911 Set_Etype (Id, Any_Type); 12912 12913 -- If so, process the full constant declaration 12914 12915 else 12916 -- RM 7.4 (6): If the subtype defined by the subtype_indication in 12917 -- the deferred declaration is constrained, then the subtype defined 12918 -- by the subtype_indication in the full declaration shall match it 12919 -- statically. 12920 12921 Check_Possible_Deferred_Completion 12922 (Prev_Id => Prev, 12923 Prev_Obj_Def => Object_Definition (Parent (Prev)), 12924 Curr_Obj_Def => Obj_Def); 12925 12926 Set_Full_View (Prev, Id); 12927 Set_Is_Public (Id, Is_Public (Prev)); 12928 Set_Is_Internal (Id); 12929 Append_Entity (Id, Current_Scope); 12930 12931 -- Check ALIASED present if present before (RM 7.4(7)) 12932 12933 if Is_Aliased (Prev) 12934 and then not Aliased_Present (N) 12935 then 12936 Error_Msg_Sloc := Sloc (Prev); 12937 Error_Msg_N ("ALIASED required (see declaration #)", N); 12938 end if; 12939 12940 -- Check that placement is in private part and that the incomplete 12941 -- declaration appeared in the visible part. 12942 12943 if Ekind (Current_Scope) = E_Package 12944 and then not In_Private_Part (Current_Scope) 12945 then 12946 Error_Msg_Sloc := Sloc (Prev); 12947 Error_Msg_N 12948 ("full constant for declaration # must be in private part", N); 12949 12950 elsif Ekind (Current_Scope) = E_Package 12951 and then 12952 List_Containing (Parent (Prev)) /= 12953 Visible_Declarations (Package_Specification (Current_Scope)) 12954 then 12955 Error_Msg_N 12956 ("deferred constant must be declared in visible part", 12957 Parent (Prev)); 12958 end if; 12959 12960 if Is_Access_Type (T) 12961 and then Nkind (Expression (N)) = N_Allocator 12962 then 12963 Check_Recursive_Declaration (Designated_Type (T)); 12964 end if; 12965 12966 -- A deferred constant is a visible entity. If type has invariants, 12967 -- verify that the initial value satisfies them. This is not done in 12968 -- GNATprove mode, as GNATprove handles invariant checks itself. 12969 12970 if Has_Invariants (T) 12971 and then Present (Invariant_Procedure (T)) 12972 and then not GNATprove_Mode 12973 then 12974 Insert_After (N, 12975 Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N)))); 12976 end if; 12977 end if; 12978 end Constant_Redeclaration; 12979 12980 ---------------------- 12981 -- Constrain_Access -- 12982 ---------------------- 12983 12984 procedure Constrain_Access 12985 (Def_Id : in out Entity_Id; 12986 S : Node_Id; 12987 Related_Nod : Node_Id) 12988 is 12989 T : constant Entity_Id := Entity (Subtype_Mark (S)); 12990 Desig_Type : constant Entity_Id := Designated_Type (T); 12991 Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); 12992 Constraint_OK : Boolean := True; 12993 12994 begin 12995 if Is_Array_Type (Desig_Type) then 12996 Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); 12997 12998 elsif (Is_Record_Type (Desig_Type) 12999 or else Is_Incomplete_Or_Private_Type (Desig_Type)) 13000 and then not Is_Constrained (Desig_Type) 13001 then 13002 -- If this is a constrained access definition for a record 13003 -- component, we leave the type as an unconstrained access, 13004 -- and mark the component so that its actual type is built 13005 -- at a point of use (e.g., an assignment statement). This 13006 -- is handled in Sem_Util.Build_Actual_Subtype_Of_Component. 13007 13008 if Desig_Type = Current_Scope 13009 and then No (Def_Id) 13010 then 13011 Desig_Subtype := 13012 Create_Itype 13013 (E_Void, Related_Nod, Scope_Id => Scope (Desig_Type)); 13014 Set_Ekind (Desig_Subtype, E_Record_Subtype); 13015 Def_Id := Entity (Subtype_Mark (S)); 13016 13017 -- We indicate that the component has a per-object constraint 13018 -- for treatment at a point of use, even though the constraint 13019 -- may be independent of discriminants of the enclosing type. 13020 13021 if Nkind (Related_Nod) = N_Component_Declaration then 13022 Set_Has_Per_Object_Constraint 13023 (Defining_Identifier (Related_Nod)); 13024 end if; 13025 13026 -- This call added to ensure that the constraint is analyzed 13027 -- (needed for a B test). Note that we still return early from 13028 -- this procedure to avoid recursive processing. 13029 13030 Constrain_Discriminated_Type 13031 (Desig_Subtype, S, Related_Nod, For_Access => True); 13032 return; 13033 end if; 13034 13035 -- Enforce rule that the constraint is illegal if there is an 13036 -- unconstrained view of the designated type. This means that the 13037 -- partial view (either a private type declaration or a derivation 13038 -- from a private type) has no discriminants. (Defect Report 13039 -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001). 13040 13041 -- Rule updated for Ada 2005: The private type is said to have 13042 -- a constrained partial view, given that objects of the type 13043 -- can be declared. Furthermore, the rule applies to all access 13044 -- types, unlike the rule concerning default discriminants (see 13045 -- RM 3.7.1(7/3)) 13046 13047 if (Ekind (T) = E_General_Access_Type or else Ada_Version >= Ada_2005) 13048 and then Has_Private_Declaration (Desig_Type) 13049 and then In_Open_Scopes (Scope (Desig_Type)) 13050 and then Has_Discriminants (Desig_Type) 13051 then 13052 declare 13053 Pack : constant Node_Id := 13054 Unit_Declaration_Node (Scope (Desig_Type)); 13055 Decls : List_Id; 13056 Decl : Node_Id; 13057 13058 begin 13059 if Nkind (Pack) = N_Package_Declaration then 13060 Decls := Visible_Declarations (Specification (Pack)); 13061 Decl := First (Decls); 13062 while Present (Decl) loop 13063 if (Nkind (Decl) = N_Private_Type_Declaration 13064 and then Chars (Defining_Identifier (Decl)) = 13065 Chars (Desig_Type)) 13066 13067 or else 13068 (Nkind (Decl) = N_Full_Type_Declaration 13069 and then 13070 Chars (Defining_Identifier (Decl)) = 13071 Chars (Desig_Type) 13072 and then Is_Derived_Type (Desig_Type) 13073 and then 13074 Has_Private_Declaration (Etype (Desig_Type))) 13075 then 13076 if No (Discriminant_Specifications (Decl)) then 13077 Error_Msg_N 13078 ("cannot constrain access type if designated " 13079 & "type has constrained partial view", S); 13080 end if; 13081 13082 exit; 13083 end if; 13084 13085 Next (Decl); 13086 end loop; 13087 end if; 13088 end; 13089 end if; 13090 13091 Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, 13092 For_Access => True); 13093 13094 elsif Is_Concurrent_Type (Desig_Type) 13095 and then not Is_Constrained (Desig_Type) 13096 then 13097 Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' '); 13098 13099 else 13100 Error_Msg_N ("invalid constraint on access type", S); 13101 13102 -- We simply ignore an invalid constraint 13103 13104 Desig_Subtype := Desig_Type; 13105 Constraint_OK := False; 13106 end if; 13107 13108 if No (Def_Id) then 13109 Def_Id := Create_Itype (E_Access_Subtype, Related_Nod); 13110 else 13111 Set_Ekind (Def_Id, E_Access_Subtype); 13112 end if; 13113 13114 if Constraint_OK then 13115 Set_Etype (Def_Id, Base_Type (T)); 13116 13117 if Is_Private_Type (Desig_Type) then 13118 Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod); 13119 end if; 13120 else 13121 Set_Etype (Def_Id, Any_Type); 13122 end if; 13123 13124 Set_Size_Info (Def_Id, T); 13125 Set_Is_Constrained (Def_Id, Constraint_OK); 13126 Set_Directly_Designated_Type (Def_Id, Desig_Subtype); 13127 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 13128 Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T)); 13129 13130 Conditional_Delay (Def_Id, T); 13131 13132 -- AI-363 : Subtypes of general access types whose designated types have 13133 -- default discriminants are disallowed. In instances, the rule has to 13134 -- be checked against the actual, of which T is the subtype. In a 13135 -- generic body, the rule is checked assuming that the actual type has 13136 -- defaulted discriminants. 13137 13138 if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then 13139 if Ekind (Base_Type (T)) = E_General_Access_Type 13140 and then Has_Defaulted_Discriminants (Desig_Type) 13141 then 13142 if Ada_Version < Ada_2005 then 13143 Error_Msg_N 13144 ("access subtype of general access type would not " & 13145 "be allowed in Ada 2005?y?", S); 13146 else 13147 Error_Msg_N 13148 ("access subtype of general access type not allowed", S); 13149 end if; 13150 13151 Error_Msg_N ("\discriminants have defaults", S); 13152 13153 elsif Is_Access_Type (T) 13154 and then Is_Generic_Type (Desig_Type) 13155 and then Has_Discriminants (Desig_Type) 13156 and then In_Package_Body (Current_Scope) 13157 then 13158 if Ada_Version < Ada_2005 then 13159 Error_Msg_N 13160 ("access subtype would not be allowed in generic body " 13161 & "in Ada 2005?y?", S); 13162 else 13163 Error_Msg_N 13164 ("access subtype not allowed in generic body", S); 13165 end if; 13166 13167 Error_Msg_N 13168 ("\designated type is a discriminated formal", S); 13169 end if; 13170 end if; 13171 end Constrain_Access; 13172 13173 --------------------- 13174 -- Constrain_Array -- 13175 --------------------- 13176 13177 procedure Constrain_Array 13178 (Def_Id : in out Entity_Id; 13179 SI : Node_Id; 13180 Related_Nod : Node_Id; 13181 Related_Id : Entity_Id; 13182 Suffix : Character) 13183 is 13184 C : constant Node_Id := Constraint (SI); 13185 Number_Of_Constraints : Nat := 0; 13186 Index : Node_Id; 13187 S, T : Entity_Id; 13188 Constraint_OK : Boolean := True; 13189 13190 begin 13191 T := Entity (Subtype_Mark (SI)); 13192 13193 if Is_Access_Type (T) then 13194 T := Designated_Type (T); 13195 end if; 13196 13197 -- If an index constraint follows a subtype mark in a subtype indication 13198 -- then the type or subtype denoted by the subtype mark must not already 13199 -- impose an index constraint. The subtype mark must denote either an 13200 -- unconstrained array type or an access type whose designated type 13201 -- is such an array type... (RM 3.6.1) 13202 13203 if Is_Constrained (T) then 13204 Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); 13205 Constraint_OK := False; 13206 13207 else 13208 S := First (Constraints (C)); 13209 while Present (S) loop 13210 Number_Of_Constraints := Number_Of_Constraints + 1; 13211 Next (S); 13212 end loop; 13213 13214 -- In either case, the index constraint must provide a discrete 13215 -- range for each index of the array type and the type of each 13216 -- discrete range must be the same as that of the corresponding 13217 -- index. (RM 3.6.1) 13218 13219 if Number_Of_Constraints /= Number_Dimensions (T) then 13220 Error_Msg_NE ("incorrect number of index constraints for }", C, T); 13221 Constraint_OK := False; 13222 13223 else 13224 S := First (Constraints (C)); 13225 Index := First_Index (T); 13226 Analyze (Index); 13227 13228 -- Apply constraints to each index type 13229 13230 for J in 1 .. Number_Of_Constraints loop 13231 Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J); 13232 Next (Index); 13233 Next (S); 13234 end loop; 13235 13236 end if; 13237 end if; 13238 13239 if No (Def_Id) then 13240 Def_Id := 13241 Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix); 13242 Set_Parent (Def_Id, Related_Nod); 13243 13244 else 13245 Set_Ekind (Def_Id, E_Array_Subtype); 13246 end if; 13247 13248 Set_Size_Info (Def_Id, (T)); 13249 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 13250 Set_Etype (Def_Id, Base_Type (T)); 13251 13252 if Constraint_OK then 13253 Set_First_Index (Def_Id, First (Constraints (C))); 13254 else 13255 Set_First_Index (Def_Id, First_Index (T)); 13256 end if; 13257 13258 Set_Is_Constrained (Def_Id, True); 13259 Set_Is_Aliased (Def_Id, Is_Aliased (T)); 13260 Set_Is_Independent (Def_Id, Is_Independent (T)); 13261 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 13262 13263 Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T)); 13264 Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T)); 13265 13266 -- A subtype does not inherit the Packed_Array_Impl_Type of is parent. 13267 -- We need to initialize the attribute because if Def_Id is previously 13268 -- analyzed through a limited_with clause, it will have the attributes 13269 -- of an incomplete type, one of which is an Elist that overlaps the 13270 -- Packed_Array_Impl_Type field. 13271 13272 Set_Packed_Array_Impl_Type (Def_Id, Empty); 13273 13274 -- Build a freeze node if parent still needs one. Also make sure that 13275 -- the Depends_On_Private status is set because the subtype will need 13276 -- reprocessing at the time the base type does, and also we must set a 13277 -- conditional delay. 13278 13279 Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); 13280 Conditional_Delay (Def_Id, T); 13281 end Constrain_Array; 13282 13283 ------------------------------ 13284 -- Constrain_Component_Type -- 13285 ------------------------------ 13286 13287 function Constrain_Component_Type 13288 (Comp : Entity_Id; 13289 Constrained_Typ : Entity_Id; 13290 Related_Node : Node_Id; 13291 Typ : Entity_Id; 13292 Constraints : Elist_Id) return Entity_Id 13293 is 13294 Loc : constant Source_Ptr := Sloc (Constrained_Typ); 13295 Compon_Type : constant Entity_Id := Etype (Comp); 13296 13297 function Build_Constrained_Array_Type 13298 (Old_Type : Entity_Id) return Entity_Id; 13299 -- If Old_Type is an array type, one of whose indexes is constrained 13300 -- by a discriminant, build an Itype whose constraint replaces the 13301 -- discriminant with its value in the constraint. 13302 13303 function Build_Constrained_Discriminated_Type 13304 (Old_Type : Entity_Id) return Entity_Id; 13305 -- Ditto for record components. Handle the case where the constraint 13306 -- is a conversion of the discriminant value, introduced during 13307 -- expansion. 13308 13309 function Build_Constrained_Access_Type 13310 (Old_Type : Entity_Id) return Entity_Id; 13311 -- Ditto for access types. Makes use of previous two functions, to 13312 -- constrain designated type. 13313 13314 function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id; 13315 -- T is an array or discriminated type, C is a list of constraints 13316 -- that apply to T. This routine builds the constrained subtype. 13317 13318 function Is_Discriminant (Expr : Node_Id) return Boolean; 13319 -- Returns True if Expr is a discriminant 13320 13321 function Get_Discr_Value (Discrim : Entity_Id) return Node_Id; 13322 -- Find the value of discriminant Discrim in Constraint 13323 13324 ----------------------------------- 13325 -- Build_Constrained_Access_Type -- 13326 ----------------------------------- 13327 13328 function Build_Constrained_Access_Type 13329 (Old_Type : Entity_Id) return Entity_Id 13330 is 13331 Desig_Type : constant Entity_Id := Designated_Type (Old_Type); 13332 Itype : Entity_Id; 13333 Desig_Subtype : Entity_Id; 13334 Scop : Entity_Id; 13335 13336 begin 13337 -- if the original access type was not embedded in the enclosing 13338 -- type definition, there is no need to produce a new access 13339 -- subtype. In fact every access type with an explicit constraint 13340 -- generates an itype whose scope is the enclosing record. 13341 13342 if not Is_Type (Scope (Old_Type)) then 13343 return Old_Type; 13344 13345 elsif Is_Array_Type (Desig_Type) then 13346 Desig_Subtype := Build_Constrained_Array_Type (Desig_Type); 13347 13348 elsif Has_Discriminants (Desig_Type) then 13349 13350 -- This may be an access type to an enclosing record type for 13351 -- which we are constructing the constrained components. Return 13352 -- the enclosing record subtype. This is not always correct, 13353 -- but avoids infinite recursion. ??? 13354 13355 Desig_Subtype := Any_Type; 13356 13357 for J in reverse 0 .. Scope_Stack.Last loop 13358 Scop := Scope_Stack.Table (J).Entity; 13359 13360 if Is_Type (Scop) 13361 and then Base_Type (Scop) = Base_Type (Desig_Type) 13362 then 13363 Desig_Subtype := Scop; 13364 end if; 13365 13366 exit when not Is_Type (Scop); 13367 end loop; 13368 13369 if Desig_Subtype = Any_Type then 13370 Desig_Subtype := 13371 Build_Constrained_Discriminated_Type (Desig_Type); 13372 end if; 13373 13374 else 13375 return Old_Type; 13376 end if; 13377 13378 if Desig_Subtype /= Desig_Type then 13379 13380 -- The Related_Node better be here or else we won't be able 13381 -- to attach new itypes to a node in the tree. 13382 13383 pragma Assert (Present (Related_Node)); 13384 13385 Itype := Create_Itype (E_Access_Subtype, Related_Node); 13386 13387 Set_Etype (Itype, Base_Type (Old_Type)); 13388 Set_Size_Info (Itype, (Old_Type)); 13389 Set_Directly_Designated_Type (Itype, Desig_Subtype); 13390 Set_Depends_On_Private (Itype, Has_Private_Component 13391 (Old_Type)); 13392 Set_Is_Access_Constant (Itype, Is_Access_Constant 13393 (Old_Type)); 13394 13395 -- The new itype needs freezing when it depends on a not frozen 13396 -- type and the enclosing subtype needs freezing. 13397 13398 if Has_Delayed_Freeze (Constrained_Typ) 13399 and then not Is_Frozen (Constrained_Typ) 13400 then 13401 Conditional_Delay (Itype, Base_Type (Old_Type)); 13402 end if; 13403 13404 return Itype; 13405 13406 else 13407 return Old_Type; 13408 end if; 13409 end Build_Constrained_Access_Type; 13410 13411 ---------------------------------- 13412 -- Build_Constrained_Array_Type -- 13413 ---------------------------------- 13414 13415 function Build_Constrained_Array_Type 13416 (Old_Type : Entity_Id) return Entity_Id 13417 is 13418 Lo_Expr : Node_Id; 13419 Hi_Expr : Node_Id; 13420 Old_Index : Node_Id; 13421 Range_Node : Node_Id; 13422 Constr_List : List_Id; 13423 13424 Need_To_Create_Itype : Boolean := False; 13425 13426 begin 13427 Old_Index := First_Index (Old_Type); 13428 while Present (Old_Index) loop 13429 Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); 13430 13431 if Is_Discriminant (Lo_Expr) 13432 or else 13433 Is_Discriminant (Hi_Expr) 13434 then 13435 Need_To_Create_Itype := True; 13436 end if; 13437 13438 Next_Index (Old_Index); 13439 end loop; 13440 13441 if Need_To_Create_Itype then 13442 Constr_List := New_List; 13443 13444 Old_Index := First_Index (Old_Type); 13445 while Present (Old_Index) loop 13446 Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); 13447 13448 if Is_Discriminant (Lo_Expr) then 13449 Lo_Expr := Get_Discr_Value (Lo_Expr); 13450 end if; 13451 13452 if Is_Discriminant (Hi_Expr) then 13453 Hi_Expr := Get_Discr_Value (Hi_Expr); 13454 end if; 13455 13456 Range_Node := 13457 Make_Range 13458 (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr)); 13459 13460 Append (Range_Node, To => Constr_List); 13461 13462 Next_Index (Old_Index); 13463 end loop; 13464 13465 return Build_Subtype (Old_Type, Constr_List); 13466 13467 else 13468 return Old_Type; 13469 end if; 13470 end Build_Constrained_Array_Type; 13471 13472 ------------------------------------------ 13473 -- Build_Constrained_Discriminated_Type -- 13474 ------------------------------------------ 13475 13476 function Build_Constrained_Discriminated_Type 13477 (Old_Type : Entity_Id) return Entity_Id 13478 is 13479 Expr : Node_Id; 13480 Constr_List : List_Id; 13481 Old_Constraint : Elmt_Id; 13482 13483 Need_To_Create_Itype : Boolean := False; 13484 13485 begin 13486 Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); 13487 while Present (Old_Constraint) loop 13488 Expr := Node (Old_Constraint); 13489 13490 if Is_Discriminant (Expr) then 13491 Need_To_Create_Itype := True; 13492 13493 -- After expansion of discriminated task types, the value 13494 -- of the discriminant may be converted to a run-time type 13495 -- for restricted run-times. Propagate the value of the 13496 -- discriminant as well, so that e.g. the secondary stack 13497 -- component has a static constraint. Necessary for LLVM. 13498 13499 elsif Nkind (Expr) = N_Type_Conversion 13500 and then Is_Discriminant (Expression (Expr)) 13501 then 13502 Need_To_Create_Itype := True; 13503 end if; 13504 13505 Next_Elmt (Old_Constraint); 13506 end loop; 13507 13508 if Need_To_Create_Itype then 13509 Constr_List := New_List; 13510 13511 Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); 13512 while Present (Old_Constraint) loop 13513 Expr := Node (Old_Constraint); 13514 13515 if Is_Discriminant (Expr) then 13516 Expr := Get_Discr_Value (Expr); 13517 13518 elsif Nkind (Expr) = N_Type_Conversion 13519 and then Is_Discriminant (Expression (Expr)) 13520 then 13521 Expr := New_Copy_Tree (Expr); 13522 Set_Expression (Expr, Get_Discr_Value (Expression (Expr))); 13523 end if; 13524 13525 Append (New_Copy_Tree (Expr), To => Constr_List); 13526 13527 Next_Elmt (Old_Constraint); 13528 end loop; 13529 13530 return Build_Subtype (Old_Type, Constr_List); 13531 13532 else 13533 return Old_Type; 13534 end if; 13535 end Build_Constrained_Discriminated_Type; 13536 13537 ------------------- 13538 -- Build_Subtype -- 13539 ------------------- 13540 13541 function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is 13542 Indic : Node_Id; 13543 Subtyp_Decl : Node_Id; 13544 Def_Id : Entity_Id; 13545 Btyp : Entity_Id := Base_Type (T); 13546 13547 begin 13548 -- The Related_Node better be here or else we won't be able to 13549 -- attach new itypes to a node in the tree. 13550 13551 pragma Assert (Present (Related_Node)); 13552 13553 -- If the view of the component's type is incomplete or private 13554 -- with unknown discriminants, then the constraint must be applied 13555 -- to the full type. 13556 13557 if Has_Unknown_Discriminants (Btyp) 13558 and then Present (Underlying_Type (Btyp)) 13559 then 13560 Btyp := Underlying_Type (Btyp); 13561 end if; 13562 13563 Indic := 13564 Make_Subtype_Indication (Loc, 13565 Subtype_Mark => New_Occurrence_Of (Btyp, Loc), 13566 Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C)); 13567 13568 Def_Id := Create_Itype (Ekind (T), Related_Node); 13569 13570 Subtyp_Decl := 13571 Make_Subtype_Declaration (Loc, 13572 Defining_Identifier => Def_Id, 13573 Subtype_Indication => Indic); 13574 13575 Set_Parent (Subtyp_Decl, Parent (Related_Node)); 13576 13577 -- Itypes must be analyzed with checks off (see package Itypes) 13578 13579 Analyze (Subtyp_Decl, Suppress => All_Checks); 13580 13581 if Is_Itype (Def_Id) and then Has_Predicates (T) then 13582 Inherit_Predicate_Flags (Def_Id, T); 13583 13584 -- Indicate where the predicate function may be found 13585 13586 if Is_Itype (T) then 13587 if Present (Predicate_Function (Def_Id)) then 13588 null; 13589 13590 elsif Present (Predicate_Function (T)) then 13591 Set_Predicate_Function (Def_Id, Predicate_Function (T)); 13592 13593 else 13594 Set_Predicated_Parent (Def_Id, Predicated_Parent (T)); 13595 end if; 13596 13597 elsif No (Predicate_Function (Def_Id)) then 13598 Set_Predicated_Parent (Def_Id, T); 13599 end if; 13600 end if; 13601 13602 return Def_Id; 13603 end Build_Subtype; 13604 13605 --------------------- 13606 -- Get_Discr_Value -- 13607 --------------------- 13608 13609 function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is 13610 D : Entity_Id; 13611 E : Elmt_Id; 13612 13613 begin 13614 -- The discriminant may be declared for the type, in which case we 13615 -- find it by iterating over the list of discriminants. If the 13616 -- discriminant is inherited from a parent type, it appears as the 13617 -- corresponding discriminant of the current type. This will be the 13618 -- case when constraining an inherited component whose constraint is 13619 -- given by a discriminant of the parent. 13620 13621 D := First_Discriminant (Typ); 13622 E := First_Elmt (Constraints); 13623 13624 while Present (D) loop 13625 if D = Entity (Discrim) 13626 or else D = CR_Discriminant (Entity (Discrim)) 13627 or else Corresponding_Discriminant (D) = Entity (Discrim) 13628 then 13629 return Node (E); 13630 end if; 13631 13632 Next_Discriminant (D); 13633 Next_Elmt (E); 13634 end loop; 13635 13636 -- The Corresponding_Discriminant mechanism is incomplete, because 13637 -- the correspondence between new and old discriminants is not one 13638 -- to one: one new discriminant can constrain several old ones. In 13639 -- that case, scan sequentially the stored_constraint, the list of 13640 -- discriminants of the parents, and the constraints. 13641 13642 -- Previous code checked for the present of the Stored_Constraint 13643 -- list for the derived type, but did not use it at all. Should it 13644 -- be present when the component is a discriminated task type? 13645 13646 if Is_Derived_Type (Typ) 13647 and then Scope (Entity (Discrim)) = Etype (Typ) 13648 then 13649 D := First_Discriminant (Etype (Typ)); 13650 E := First_Elmt (Constraints); 13651 while Present (D) loop 13652 if D = Entity (Discrim) then 13653 return Node (E); 13654 end if; 13655 13656 Next_Discriminant (D); 13657 Next_Elmt (E); 13658 end loop; 13659 end if; 13660 13661 -- Something is wrong if we did not find the value 13662 13663 raise Program_Error; 13664 end Get_Discr_Value; 13665 13666 --------------------- 13667 -- Is_Discriminant -- 13668 --------------------- 13669 13670 function Is_Discriminant (Expr : Node_Id) return Boolean is 13671 Discrim_Scope : Entity_Id; 13672 13673 begin 13674 if Denotes_Discriminant (Expr) then 13675 Discrim_Scope := Scope (Entity (Expr)); 13676 13677 -- Either we have a reference to one of Typ's discriminants, 13678 13679 pragma Assert (Discrim_Scope = Typ 13680 13681 -- or to the discriminants of the parent type, in the case 13682 -- of a derivation of a tagged type with variants. 13683 13684 or else Discrim_Scope = Etype (Typ) 13685 or else Full_View (Discrim_Scope) = Etype (Typ) 13686 13687 -- or same as above for the case where the discriminants 13688 -- were declared in Typ's private view. 13689 13690 or else (Is_Private_Type (Discrim_Scope) 13691 and then Chars (Discrim_Scope) = Chars (Typ)) 13692 13693 -- or else we are deriving from the full view and the 13694 -- discriminant is declared in the private entity. 13695 13696 or else (Is_Private_Type (Typ) 13697 and then Chars (Discrim_Scope) = Chars (Typ)) 13698 13699 -- Or we are constrained the corresponding record of a 13700 -- synchronized type that completes a private declaration. 13701 13702 or else (Is_Concurrent_Record_Type (Typ) 13703 and then 13704 Corresponding_Concurrent_Type (Typ) = Discrim_Scope) 13705 13706 -- or we have a class-wide type, in which case make sure the 13707 -- discriminant found belongs to the root type. 13708 13709 or else (Is_Class_Wide_Type (Typ) 13710 and then Etype (Typ) = Discrim_Scope)); 13711 13712 return True; 13713 end if; 13714 13715 -- In all other cases we have something wrong 13716 13717 return False; 13718 end Is_Discriminant; 13719 13720 -- Start of processing for Constrain_Component_Type 13721 13722 begin 13723 if Nkind (Parent (Comp)) = N_Component_Declaration 13724 and then Comes_From_Source (Parent (Comp)) 13725 and then Comes_From_Source 13726 (Subtype_Indication (Component_Definition (Parent (Comp)))) 13727 and then 13728 Is_Entity_Name 13729 (Subtype_Indication (Component_Definition (Parent (Comp)))) 13730 then 13731 return Compon_Type; 13732 13733 elsif Is_Array_Type (Compon_Type) then 13734 return Build_Constrained_Array_Type (Compon_Type); 13735 13736 elsif Has_Discriminants (Compon_Type) then 13737 return Build_Constrained_Discriminated_Type (Compon_Type); 13738 13739 elsif Is_Access_Type (Compon_Type) then 13740 return Build_Constrained_Access_Type (Compon_Type); 13741 13742 else 13743 return Compon_Type; 13744 end if; 13745 end Constrain_Component_Type; 13746 13747 -------------------------- 13748 -- Constrain_Concurrent -- 13749 -------------------------- 13750 13751 -- For concurrent types, the associated record value type carries the same 13752 -- discriminants, so when we constrain a concurrent type, we must constrain 13753 -- the corresponding record type as well. 13754 13755 procedure Constrain_Concurrent 13756 (Def_Id : in out Entity_Id; 13757 SI : Node_Id; 13758 Related_Nod : Node_Id; 13759 Related_Id : Entity_Id; 13760 Suffix : Character) 13761 is 13762 -- Retrieve Base_Type to ensure getting to the concurrent type in the 13763 -- case of a private subtype (needed when only doing semantic analysis). 13764 13765 T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI))); 13766 T_Val : Entity_Id; 13767 13768 begin 13769 if Is_Access_Type (T_Ent) then 13770 T_Ent := Designated_Type (T_Ent); 13771 end if; 13772 13773 T_Val := Corresponding_Record_Type (T_Ent); 13774 13775 if Present (T_Val) then 13776 13777 if No (Def_Id) then 13778 Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 13779 13780 -- Elaborate itype now, as it may be used in a subsequent 13781 -- synchronized operation in another scope. 13782 13783 if Nkind (Related_Nod) = N_Full_Type_Declaration then 13784 Build_Itype_Reference (Def_Id, Related_Nod); 13785 end if; 13786 end if; 13787 13788 Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); 13789 Set_First_Private_Entity (Def_Id, First_Private_Entity (T_Ent)); 13790 13791 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 13792 Set_Corresponding_Record_Type (Def_Id, 13793 Constrain_Corresponding_Record (Def_Id, T_Val, Related_Nod)); 13794 13795 else 13796 -- If there is no associated record, expansion is disabled and this 13797 -- is a generic context. Create a subtype in any case, so that 13798 -- semantic analysis can proceed. 13799 13800 if No (Def_Id) then 13801 Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 13802 end if; 13803 13804 Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); 13805 end if; 13806 end Constrain_Concurrent; 13807 13808 ------------------------------------ 13809 -- Constrain_Corresponding_Record -- 13810 ------------------------------------ 13811 13812 function Constrain_Corresponding_Record 13813 (Prot_Subt : Entity_Id; 13814 Corr_Rec : Entity_Id; 13815 Related_Nod : Node_Id) return Entity_Id 13816 is 13817 T_Sub : constant Entity_Id := 13818 Create_Itype 13819 (Ekind => E_Record_Subtype, 13820 Related_Nod => Related_Nod, 13821 Related_Id => Corr_Rec, 13822 Suffix => 'C', 13823 Suffix_Index => -1); 13824 13825 begin 13826 Set_Etype (T_Sub, Corr_Rec); 13827 Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt)); 13828 Set_Is_Tagged_Type (T_Sub, Is_Tagged_Type (Corr_Rec)); 13829 Set_Is_Constrained (T_Sub, True); 13830 Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); 13831 Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec)); 13832 13833 if Has_Discriminants (Prot_Subt) then -- False only if errors. 13834 Set_Discriminant_Constraint 13835 (T_Sub, Discriminant_Constraint (Prot_Subt)); 13836 Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub); 13837 Create_Constrained_Components 13838 (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub)); 13839 end if; 13840 13841 Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub)); 13842 13843 if Ekind (Scope (Prot_Subt)) /= E_Record_Type then 13844 Conditional_Delay (T_Sub, Corr_Rec); 13845 13846 else 13847 -- This is a component subtype: it will be frozen in the context of 13848 -- the enclosing record's init_proc, so that discriminant references 13849 -- are resolved to discriminals. (Note: we used to skip freezing 13850 -- altogether in that case, which caused errors downstream for 13851 -- components of a bit packed array type). 13852 13853 Set_Has_Delayed_Freeze (T_Sub); 13854 end if; 13855 13856 return T_Sub; 13857 end Constrain_Corresponding_Record; 13858 13859 ----------------------- 13860 -- Constrain_Decimal -- 13861 ----------------------- 13862 13863 procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is 13864 T : constant Entity_Id := Entity (Subtype_Mark (S)); 13865 C : constant Node_Id := Constraint (S); 13866 Loc : constant Source_Ptr := Sloc (C); 13867 Range_Expr : Node_Id; 13868 Digits_Expr : Node_Id; 13869 Digits_Val : Uint; 13870 Bound_Val : Ureal; 13871 13872 begin 13873 Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype); 13874 13875 if Nkind (C) = N_Range_Constraint then 13876 Range_Expr := Range_Expression (C); 13877 Digits_Val := Digits_Value (T); 13878 13879 else 13880 pragma Assert (Nkind (C) = N_Digits_Constraint); 13881 13882 Check_SPARK_05_Restriction ("digits constraint is not allowed", S); 13883 13884 Digits_Expr := Digits_Expression (C); 13885 Analyze_And_Resolve (Digits_Expr, Any_Integer); 13886 13887 Check_Digits_Expression (Digits_Expr); 13888 Digits_Val := Expr_Value (Digits_Expr); 13889 13890 if Digits_Val > Digits_Value (T) then 13891 Error_Msg_N 13892 ("digits expression is incompatible with subtype", C); 13893 Digits_Val := Digits_Value (T); 13894 end if; 13895 13896 if Present (Range_Constraint (C)) then 13897 Range_Expr := Range_Expression (Range_Constraint (C)); 13898 else 13899 Range_Expr := Empty; 13900 end if; 13901 end if; 13902 13903 Set_Etype (Def_Id, Base_Type (T)); 13904 Set_Size_Info (Def_Id, (T)); 13905 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 13906 Set_Delta_Value (Def_Id, Delta_Value (T)); 13907 Set_Scale_Value (Def_Id, Scale_Value (T)); 13908 Set_Small_Value (Def_Id, Small_Value (T)); 13909 Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T)); 13910 Set_Digits_Value (Def_Id, Digits_Val); 13911 13912 -- Manufacture range from given digits value if no range present 13913 13914 if No (Range_Expr) then 13915 Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T); 13916 Range_Expr := 13917 Make_Range (Loc, 13918 Low_Bound => 13919 Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))), 13920 High_Bound => 13921 Convert_To (T, Make_Real_Literal (Loc, Bound_Val))); 13922 end if; 13923 13924 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T); 13925 Set_Discrete_RM_Size (Def_Id); 13926 13927 -- Unconditionally delay the freeze, since we cannot set size 13928 -- information in all cases correctly until the freeze point. 13929 13930 Set_Has_Delayed_Freeze (Def_Id); 13931 end Constrain_Decimal; 13932 13933 ---------------------------------- 13934 -- Constrain_Discriminated_Type -- 13935 ---------------------------------- 13936 13937 procedure Constrain_Discriminated_Type 13938 (Def_Id : Entity_Id; 13939 S : Node_Id; 13940 Related_Nod : Node_Id; 13941 For_Access : Boolean := False) 13942 is 13943 E : Entity_Id := Entity (Subtype_Mark (S)); 13944 T : Entity_Id; 13945 13946 procedure Fixup_Bad_Constraint; 13947 -- Called after finding a bad constraint, and after having posted an 13948 -- appropriate error message. The goal is to leave type Def_Id in as 13949 -- reasonable state as possible. 13950 13951 -------------------------- 13952 -- Fixup_Bad_Constraint -- 13953 -------------------------- 13954 13955 procedure Fixup_Bad_Constraint is 13956 begin 13957 -- Set a reasonable Ekind for the entity, including incomplete types. 13958 13959 Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); 13960 13961 -- Set Etype to the known type, to reduce chances of cascaded errors 13962 13963 Set_Etype (Def_Id, E); 13964 Set_Error_Posted (Def_Id); 13965 end Fixup_Bad_Constraint; 13966 13967 -- Local variables 13968 13969 C : Node_Id; 13970 Constr : Elist_Id := New_Elmt_List; 13971 13972 -- Start of processing for Constrain_Discriminated_Type 13973 13974 begin 13975 C := Constraint (S); 13976 13977 -- A discriminant constraint is only allowed in a subtype indication, 13978 -- after a subtype mark. This subtype mark must denote either a type 13979 -- with discriminants, or an access type whose designated type is a 13980 -- type with discriminants. A discriminant constraint specifies the 13981 -- values of these discriminants (RM 3.7.2(5)). 13982 13983 T := Base_Type (Entity (Subtype_Mark (S))); 13984 13985 if Is_Access_Type (T) then 13986 T := Designated_Type (T); 13987 end if; 13988 13989 -- In an instance it may be necessary to retrieve the full view of a 13990 -- type with unknown discriminants, or a full view with defaulted 13991 -- discriminants. In other contexts the constraint is illegal. 13992 13993 if In_Instance 13994 and then Is_Private_Type (T) 13995 and then Present (Full_View (T)) 13996 and then 13997 (Has_Unknown_Discriminants (T) 13998 or else 13999 (not Has_Discriminants (T) 14000 and then Has_Discriminants (Full_View (T)) 14001 and then Present (Discriminant_Default_Value 14002 (First_Discriminant (Full_View (T)))))) 14003 then 14004 T := Full_View (T); 14005 E := Full_View (E); 14006 end if; 14007 14008 -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. Avoid 14009 -- generating an error for access-to-incomplete subtypes. 14010 14011 if Ada_Version >= Ada_2005 14012 and then Ekind (T) = E_Incomplete_Type 14013 and then Nkind (Parent (S)) = N_Subtype_Declaration 14014 and then not Is_Itype (Def_Id) 14015 then 14016 -- A little sanity check: emit an error message if the type has 14017 -- discriminants to begin with. Type T may be a regular incomplete 14018 -- type or imported via a limited with clause. 14019 14020 if Has_Discriminants (T) 14021 or else (From_Limited_With (T) 14022 and then Present (Non_Limited_View (T)) 14023 and then Nkind (Parent (Non_Limited_View (T))) = 14024 N_Full_Type_Declaration 14025 and then Present (Discriminant_Specifications 14026 (Parent (Non_Limited_View (T))))) 14027 then 14028 Error_Msg_N 14029 ("(Ada 2005) incomplete subtype may not be constrained", C); 14030 else 14031 Error_Msg_N ("invalid constraint: type has no discriminant", C); 14032 end if; 14033 14034 Fixup_Bad_Constraint; 14035 return; 14036 14037 -- Check that the type has visible discriminants. The type may be 14038 -- a private type with unknown discriminants whose full view has 14039 -- discriminants which are invisible. 14040 14041 elsif not Has_Discriminants (T) 14042 or else 14043 (Has_Unknown_Discriminants (T) 14044 and then Is_Private_Type (T)) 14045 then 14046 Error_Msg_N ("invalid constraint: type has no discriminant", C); 14047 Fixup_Bad_Constraint; 14048 return; 14049 14050 elsif Is_Constrained (E) 14051 or else (Ekind (E) = E_Class_Wide_Subtype 14052 and then Present (Discriminant_Constraint (E))) 14053 then 14054 Error_Msg_N ("type is already constrained", Subtype_Mark (S)); 14055 Fixup_Bad_Constraint; 14056 return; 14057 end if; 14058 14059 -- T may be an unconstrained subtype (e.g. a generic actual). Constraint 14060 -- applies to the base type. 14061 14062 T := Base_Type (T); 14063 14064 Constr := Build_Discriminant_Constraints (T, S); 14065 14066 -- If the list returned was empty we had an error in building the 14067 -- discriminant constraint. We have also already signalled an error 14068 -- in the incomplete type case 14069 14070 if Is_Empty_Elmt_List (Constr) then 14071 Fixup_Bad_Constraint; 14072 return; 14073 end if; 14074 14075 Build_Discriminated_Subtype (T, Def_Id, Constr, Related_Nod, For_Access); 14076 end Constrain_Discriminated_Type; 14077 14078 --------------------------- 14079 -- Constrain_Enumeration -- 14080 --------------------------- 14081 14082 procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is 14083 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14084 C : constant Node_Id := Constraint (S); 14085 14086 begin 14087 Set_Ekind (Def_Id, E_Enumeration_Subtype); 14088 14089 Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); 14090 14091 Set_Etype (Def_Id, Base_Type (T)); 14092 Set_Size_Info (Def_Id, (T)); 14093 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14094 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 14095 14096 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 14097 14098 Set_Discrete_RM_Size (Def_Id); 14099 end Constrain_Enumeration; 14100 14101 ---------------------- 14102 -- Constrain_Float -- 14103 ---------------------- 14104 14105 procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is 14106 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14107 C : Node_Id; 14108 D : Node_Id; 14109 Rais : Node_Id; 14110 14111 begin 14112 Set_Ekind (Def_Id, E_Floating_Point_Subtype); 14113 14114 Set_Etype (Def_Id, Base_Type (T)); 14115 Set_Size_Info (Def_Id, (T)); 14116 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14117 14118 -- Process the constraint 14119 14120 C := Constraint (S); 14121 14122 -- Digits constraint present 14123 14124 if Nkind (C) = N_Digits_Constraint then 14125 14126 Check_SPARK_05_Restriction ("digits constraint is not allowed", S); 14127 Check_Restriction (No_Obsolescent_Features, C); 14128 14129 if Warn_On_Obsolescent_Feature then 14130 Error_Msg_N 14131 ("subtype digits constraint is an " & 14132 "obsolescent feature (RM J.3(8))?j?", C); 14133 end if; 14134 14135 D := Digits_Expression (C); 14136 Analyze_And_Resolve (D, Any_Integer); 14137 Check_Digits_Expression (D); 14138 Set_Digits_Value (Def_Id, Expr_Value (D)); 14139 14140 -- Check that digits value is in range. Obviously we can do this 14141 -- at compile time, but it is strictly a runtime check, and of 14142 -- course there is an ACVC test that checks this. 14143 14144 if Digits_Value (Def_Id) > Digits_Value (T) then 14145 Error_Msg_Uint_1 := Digits_Value (T); 14146 Error_Msg_N ("??digits value is too large, maximum is ^", D); 14147 Rais := 14148 Make_Raise_Constraint_Error (Sloc (D), 14149 Reason => CE_Range_Check_Failed); 14150 Insert_Action (Declaration_Node (Def_Id), Rais); 14151 end if; 14152 14153 C := Range_Constraint (C); 14154 14155 -- No digits constraint present 14156 14157 else 14158 Set_Digits_Value (Def_Id, Digits_Value (T)); 14159 end if; 14160 14161 -- Range constraint present 14162 14163 if Nkind (C) = N_Range_Constraint then 14164 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 14165 14166 -- No range constraint present 14167 14168 else 14169 pragma Assert (No (C)); 14170 Set_Scalar_Range (Def_Id, Scalar_Range (T)); 14171 end if; 14172 14173 Set_Is_Constrained (Def_Id); 14174 end Constrain_Float; 14175 14176 --------------------- 14177 -- Constrain_Index -- 14178 --------------------- 14179 14180 procedure Constrain_Index 14181 (Index : Node_Id; 14182 S : Node_Id; 14183 Related_Nod : Node_Id; 14184 Related_Id : Entity_Id; 14185 Suffix : Character; 14186 Suffix_Index : Nat) 14187 is 14188 Def_Id : Entity_Id; 14189 R : Node_Id := Empty; 14190 T : constant Entity_Id := Etype (Index); 14191 14192 begin 14193 Def_Id := 14194 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index); 14195 Set_Etype (Def_Id, Base_Type (T)); 14196 14197 if Nkind (S) = N_Range 14198 or else 14199 (Nkind (S) = N_Attribute_Reference 14200 and then Attribute_Name (S) = Name_Range) 14201 then 14202 -- A Range attribute will be transformed into N_Range by Resolve 14203 14204 Analyze (S); 14205 Set_Etype (S, T); 14206 R := S; 14207 14208 Process_Range_Expr_In_Decl (R, T); 14209 14210 if not Error_Posted (S) 14211 and then 14212 (Nkind (S) /= N_Range 14213 or else not Covers (T, (Etype (Low_Bound (S)))) 14214 or else not Covers (T, (Etype (High_Bound (S))))) 14215 then 14216 if Base_Type (T) /= Any_Type 14217 and then Etype (Low_Bound (S)) /= Any_Type 14218 and then Etype (High_Bound (S)) /= Any_Type 14219 then 14220 Error_Msg_N ("range expected", S); 14221 end if; 14222 end if; 14223 14224 elsif Nkind (S) = N_Subtype_Indication then 14225 14226 -- The parser has verified that this is a discrete indication 14227 14228 Resolve_Discrete_Subtype_Indication (S, T); 14229 Bad_Predicated_Subtype_Use 14230 ("subtype& has predicate, not allowed in index constraint", 14231 S, Entity (Subtype_Mark (S))); 14232 14233 R := Range_Expression (Constraint (S)); 14234 14235 -- Capture values of bounds and generate temporaries for them if 14236 -- needed, since checks may cause duplication of the expressions 14237 -- which must not be reevaluated. 14238 14239 -- The forced evaluation removes side effects from expressions, which 14240 -- should occur also in GNATprove mode. Otherwise, we end up with 14241 -- unexpected insertions of actions at places where this is not 14242 -- supposed to occur, e.g. on default parameters of a call. 14243 14244 if Expander_Active or GNATprove_Mode then 14245 Force_Evaluation 14246 (Low_Bound (R), Related_Id => Def_Id, Is_Low_Bound => True); 14247 Force_Evaluation 14248 (High_Bound (R), Related_Id => Def_Id, Is_High_Bound => True); 14249 end if; 14250 14251 elsif Nkind (S) = N_Discriminant_Association then 14252 14253 -- Syntactically valid in subtype indication 14254 14255 Error_Msg_N ("invalid index constraint", S); 14256 Rewrite (S, New_Occurrence_Of (T, Sloc (S))); 14257 return; 14258 14259 -- Subtype_Mark case, no anonymous subtypes to construct 14260 14261 else 14262 Analyze (S); 14263 14264 if Is_Entity_Name (S) then 14265 if not Is_Type (Entity (S)) then 14266 Error_Msg_N ("expect subtype mark for index constraint", S); 14267 14268 elsif Base_Type (Entity (S)) /= Base_Type (T) then 14269 Wrong_Type (S, Base_Type (T)); 14270 14271 -- Check error of subtype with predicate in index constraint 14272 14273 else 14274 Bad_Predicated_Subtype_Use 14275 ("subtype& has predicate, not allowed in index constraint", 14276 S, Entity (S)); 14277 end if; 14278 14279 return; 14280 14281 else 14282 Error_Msg_N ("invalid index constraint", S); 14283 Rewrite (S, New_Occurrence_Of (T, Sloc (S))); 14284 return; 14285 end if; 14286 end if; 14287 14288 -- Complete construction of the Itype 14289 14290 if Is_Modular_Integer_Type (T) then 14291 Set_Ekind (Def_Id, E_Modular_Integer_Subtype); 14292 14293 elsif Is_Integer_Type (T) then 14294 Set_Ekind (Def_Id, E_Signed_Integer_Subtype); 14295 14296 else 14297 Set_Ekind (Def_Id, E_Enumeration_Subtype); 14298 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 14299 Set_First_Literal (Def_Id, First_Literal (T)); 14300 end if; 14301 14302 Set_Size_Info (Def_Id, (T)); 14303 Set_RM_Size (Def_Id, RM_Size (T)); 14304 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14305 14306 Set_Scalar_Range (Def_Id, R); 14307 14308 Set_Etype (S, Def_Id); 14309 Set_Discrete_RM_Size (Def_Id); 14310 end Constrain_Index; 14311 14312 ----------------------- 14313 -- Constrain_Integer -- 14314 ----------------------- 14315 14316 procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is 14317 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14318 C : constant Node_Id := Constraint (S); 14319 14320 begin 14321 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 14322 14323 if Is_Modular_Integer_Type (T) then 14324 Set_Ekind (Def_Id, E_Modular_Integer_Subtype); 14325 else 14326 Set_Ekind (Def_Id, E_Signed_Integer_Subtype); 14327 end if; 14328 14329 Set_Etype (Def_Id, Base_Type (T)); 14330 Set_Size_Info (Def_Id, (T)); 14331 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14332 Set_Discrete_RM_Size (Def_Id); 14333 end Constrain_Integer; 14334 14335 ------------------------------ 14336 -- Constrain_Ordinary_Fixed -- 14337 ------------------------------ 14338 14339 procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is 14340 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14341 C : Node_Id; 14342 D : Node_Id; 14343 Rais : Node_Id; 14344 14345 begin 14346 Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); 14347 Set_Etype (Def_Id, Base_Type (T)); 14348 Set_Size_Info (Def_Id, (T)); 14349 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14350 Set_Small_Value (Def_Id, Small_Value (T)); 14351 14352 -- Process the constraint 14353 14354 C := Constraint (S); 14355 14356 -- Delta constraint present 14357 14358 if Nkind (C) = N_Delta_Constraint then 14359 14360 Check_SPARK_05_Restriction ("delta constraint is not allowed", S); 14361 Check_Restriction (No_Obsolescent_Features, C); 14362 14363 if Warn_On_Obsolescent_Feature then 14364 Error_Msg_S 14365 ("subtype delta constraint is an " & 14366 "obsolescent feature (RM J.3(7))?j?"); 14367 end if; 14368 14369 D := Delta_Expression (C); 14370 Analyze_And_Resolve (D, Any_Real); 14371 Check_Delta_Expression (D); 14372 Set_Delta_Value (Def_Id, Expr_Value_R (D)); 14373 14374 -- Check that delta value is in range. Obviously we can do this 14375 -- at compile time, but it is strictly a runtime check, and of 14376 -- course there is an ACVC test that checks this. 14377 14378 if Delta_Value (Def_Id) < Delta_Value (T) then 14379 Error_Msg_N ("??delta value is too small", D); 14380 Rais := 14381 Make_Raise_Constraint_Error (Sloc (D), 14382 Reason => CE_Range_Check_Failed); 14383 Insert_Action (Declaration_Node (Def_Id), Rais); 14384 end if; 14385 14386 C := Range_Constraint (C); 14387 14388 -- No delta constraint present 14389 14390 else 14391 Set_Delta_Value (Def_Id, Delta_Value (T)); 14392 end if; 14393 14394 -- Range constraint present 14395 14396 if Nkind (C) = N_Range_Constraint then 14397 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 14398 14399 -- No range constraint present 14400 14401 else 14402 pragma Assert (No (C)); 14403 Set_Scalar_Range (Def_Id, Scalar_Range (T)); 14404 end if; 14405 14406 Set_Discrete_RM_Size (Def_Id); 14407 14408 -- Unconditionally delay the freeze, since we cannot set size 14409 -- information in all cases correctly until the freeze point. 14410 14411 Set_Has_Delayed_Freeze (Def_Id); 14412 end Constrain_Ordinary_Fixed; 14413 14414 ----------------------- 14415 -- Contain_Interface -- 14416 ----------------------- 14417 14418 function Contain_Interface 14419 (Iface : Entity_Id; 14420 Ifaces : Elist_Id) return Boolean 14421 is 14422 Iface_Elmt : Elmt_Id; 14423 14424 begin 14425 if Present (Ifaces) then 14426 Iface_Elmt := First_Elmt (Ifaces); 14427 while Present (Iface_Elmt) loop 14428 if Node (Iface_Elmt) = Iface then 14429 return True; 14430 end if; 14431 14432 Next_Elmt (Iface_Elmt); 14433 end loop; 14434 end if; 14435 14436 return False; 14437 end Contain_Interface; 14438 14439 --------------------------- 14440 -- Convert_Scalar_Bounds -- 14441 --------------------------- 14442 14443 procedure Convert_Scalar_Bounds 14444 (N : Node_Id; 14445 Parent_Type : Entity_Id; 14446 Derived_Type : Entity_Id; 14447 Loc : Source_Ptr) 14448 is 14449 Implicit_Base : constant Entity_Id := Base_Type (Derived_Type); 14450 14451 Lo : Node_Id; 14452 Hi : Node_Id; 14453 Rng : Node_Id; 14454 14455 begin 14456 -- Defend against previous errors 14457 14458 if No (Scalar_Range (Derived_Type)) then 14459 Check_Error_Detected; 14460 return; 14461 end if; 14462 14463 Lo := Build_Scalar_Bound 14464 (Type_Low_Bound (Derived_Type), 14465 Parent_Type, Implicit_Base); 14466 14467 Hi := Build_Scalar_Bound 14468 (Type_High_Bound (Derived_Type), 14469 Parent_Type, Implicit_Base); 14470 14471 Rng := 14472 Make_Range (Loc, 14473 Low_Bound => Lo, 14474 High_Bound => Hi); 14475 14476 Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type)); 14477 14478 Set_Parent (Rng, N); 14479 Set_Scalar_Range (Derived_Type, Rng); 14480 14481 -- Analyze the bounds 14482 14483 Analyze_And_Resolve (Lo, Implicit_Base); 14484 Analyze_And_Resolve (Hi, Implicit_Base); 14485 14486 -- Analyze the range itself, except that we do not analyze it if 14487 -- the bounds are real literals, and we have a fixed-point type. 14488 -- The reason for this is that we delay setting the bounds in this 14489 -- case till we know the final Small and Size values (see circuit 14490 -- in Freeze.Freeze_Fixed_Point_Type for further details). 14491 14492 if Is_Fixed_Point_Type (Parent_Type) 14493 and then Nkind (Lo) = N_Real_Literal 14494 and then Nkind (Hi) = N_Real_Literal 14495 then 14496 return; 14497 14498 -- Here we do the analysis of the range 14499 14500 -- Note: we do this manually, since if we do a normal Analyze and 14501 -- Resolve call, there are problems with the conversions used for 14502 -- the derived type range. 14503 14504 else 14505 Set_Etype (Rng, Implicit_Base); 14506 Set_Analyzed (Rng, True); 14507 end if; 14508 end Convert_Scalar_Bounds; 14509 14510 ------------------- 14511 -- Copy_And_Swap -- 14512 ------------------- 14513 14514 procedure Copy_And_Swap (Priv, Full : Entity_Id) is 14515 begin 14516 -- Initialize new full declaration entity by copying the pertinent 14517 -- fields of the corresponding private declaration entity. 14518 14519 -- We temporarily set Ekind to a value appropriate for a type to 14520 -- avoid assert failures in Einfo from checking for setting type 14521 -- attributes on something that is not a type. Ekind (Priv) is an 14522 -- appropriate choice, since it allowed the attributes to be set 14523 -- in the first place. This Ekind value will be modified later. 14524 14525 Set_Ekind (Full, Ekind (Priv)); 14526 14527 -- Also set Etype temporarily to Any_Type, again, in the absence 14528 -- of errors, it will be properly reset, and if there are errors, 14529 -- then we want a value of Any_Type to remain. 14530 14531 Set_Etype (Full, Any_Type); 14532 14533 -- Now start copying attributes 14534 14535 Set_Has_Discriminants (Full, Has_Discriminants (Priv)); 14536 14537 if Has_Discriminants (Full) then 14538 Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv)); 14539 Set_Stored_Constraint (Full, Stored_Constraint (Priv)); 14540 end if; 14541 14542 Set_First_Rep_Item (Full, First_Rep_Item (Priv)); 14543 Set_Homonym (Full, Homonym (Priv)); 14544 Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv)); 14545 Set_Is_Public (Full, Is_Public (Priv)); 14546 Set_Is_Pure (Full, Is_Pure (Priv)); 14547 Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); 14548 Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv)); 14549 Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); 14550 Set_Has_Pragma_Unreferenced_Objects 14551 (Full, Has_Pragma_Unreferenced_Objects 14552 (Priv)); 14553 14554 Conditional_Delay (Full, Priv); 14555 14556 if Is_Tagged_Type (Full) then 14557 Set_Direct_Primitive_Operations 14558 (Full, Direct_Primitive_Operations (Priv)); 14559 Set_No_Tagged_Streams_Pragma 14560 (Full, No_Tagged_Streams_Pragma (Priv)); 14561 14562 if Is_Base_Type (Priv) then 14563 Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); 14564 end if; 14565 end if; 14566 14567 Set_Is_Volatile (Full, Is_Volatile (Priv)); 14568 Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv)); 14569 Set_Scope (Full, Scope (Priv)); 14570 Set_Prev_Entity (Full, Prev_Entity (Priv)); 14571 Set_Next_Entity (Full, Next_Entity (Priv)); 14572 Set_First_Entity (Full, First_Entity (Priv)); 14573 Set_Last_Entity (Full, Last_Entity (Priv)); 14574 14575 -- If access types have been recorded for later handling, keep them in 14576 -- the full view so that they get handled when the full view freeze 14577 -- node is expanded. 14578 14579 if Present (Freeze_Node (Priv)) 14580 and then Present (Access_Types_To_Process (Freeze_Node (Priv))) 14581 then 14582 Ensure_Freeze_Node (Full); 14583 Set_Access_Types_To_Process 14584 (Freeze_Node (Full), 14585 Access_Types_To_Process (Freeze_Node (Priv))); 14586 end if; 14587 14588 -- Swap the two entities. Now Private is the full type entity and Full 14589 -- is the private one. They will be swapped back at the end of the 14590 -- private part. This swapping ensures that the entity that is visible 14591 -- in the private part is the full declaration. 14592 14593 Exchange_Entities (Priv, Full); 14594 Append_Entity (Full, Scope (Full)); 14595 end Copy_And_Swap; 14596 14597 ------------------------------------- 14598 -- Copy_Array_Base_Type_Attributes -- 14599 ------------------------------------- 14600 14601 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is 14602 begin 14603 Set_Component_Alignment (T1, Component_Alignment (T2)); 14604 Set_Component_Type (T1, Component_Type (T2)); 14605 Set_Component_Size (T1, Component_Size (T2)); 14606 Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); 14607 Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); 14608 Propagate_Concurrent_Flags (T1, T2); 14609 Set_Is_Packed (T1, Is_Packed (T2)); 14610 Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); 14611 Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2)); 14612 Set_Has_Independent_Components (T1, Has_Independent_Components (T2)); 14613 Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2)); 14614 end Copy_Array_Base_Type_Attributes; 14615 14616 ----------------------------------- 14617 -- Copy_Array_Subtype_Attributes -- 14618 ----------------------------------- 14619 14620 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is 14621 begin 14622 Set_Size_Info (T1, T2); 14623 14624 Set_First_Index (T1, First_Index (T2)); 14625 Set_Is_Aliased (T1, Is_Aliased (T2)); 14626 Set_Is_Atomic (T1, Is_Atomic (T2)); 14627 Set_Is_Independent (T1, Is_Independent (T2)); 14628 Set_Is_Volatile (T1, Is_Volatile (T2)); 14629 Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2)); 14630 Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); 14631 Set_Is_Constrained (T1, Is_Constrained (T2)); 14632 Set_Depends_On_Private (T1, Has_Private_Component (T2)); 14633 Inherit_Rep_Item_Chain (T1, T2); 14634 Set_Convention (T1, Convention (T2)); 14635 Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2)); 14636 Set_Is_Private_Composite (T1, Is_Private_Composite (T2)); 14637 Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2)); 14638 end Copy_Array_Subtype_Attributes; 14639 14640 ----------------------------------- 14641 -- Create_Constrained_Components -- 14642 ----------------------------------- 14643 14644 procedure Create_Constrained_Components 14645 (Subt : Entity_Id; 14646 Decl_Node : Node_Id; 14647 Typ : Entity_Id; 14648 Constraints : Elist_Id) 14649 is 14650 Loc : constant Source_Ptr := Sloc (Subt); 14651 Comp_List : constant Elist_Id := New_Elmt_List; 14652 Parent_Type : constant Entity_Id := Etype (Typ); 14653 Assoc_List : constant List_Id := New_List; 14654 Discr_Val : Elmt_Id; 14655 Errors : Boolean; 14656 New_C : Entity_Id; 14657 Old_C : Entity_Id; 14658 Is_Static : Boolean := True; 14659 14660 procedure Collect_Fixed_Components (Typ : Entity_Id); 14661 -- Collect parent type components that do not appear in a variant part 14662 14663 procedure Create_All_Components; 14664 -- Iterate over Comp_List to create the components of the subtype 14665 14666 function Create_Component (Old_Compon : Entity_Id) return Entity_Id; 14667 -- Creates a new component from Old_Compon, copying all the fields from 14668 -- it, including its Etype, inserts the new component in the Subt entity 14669 -- chain and returns the new component. 14670 14671 function Is_Variant_Record (T : Entity_Id) return Boolean; 14672 -- If true, and discriminants are static, collect only components from 14673 -- variants selected by discriminant values. 14674 14675 ------------------------------ 14676 -- Collect_Fixed_Components -- 14677 ------------------------------ 14678 14679 procedure Collect_Fixed_Components (Typ : Entity_Id) is 14680 begin 14681 -- Build association list for discriminants, and find components of the 14682 -- variant part selected by the values of the discriminants. 14683 14684 Old_C := First_Discriminant (Typ); 14685 Discr_Val := First_Elmt (Constraints); 14686 while Present (Old_C) loop 14687 Append_To (Assoc_List, 14688 Make_Component_Association (Loc, 14689 Choices => New_List (New_Occurrence_Of (Old_C, Loc)), 14690 Expression => New_Copy (Node (Discr_Val)))); 14691 14692 Next_Elmt (Discr_Val); 14693 Next_Discriminant (Old_C); 14694 end loop; 14695 14696 -- The tag and the possible parent component are unconditionally in 14697 -- the subtype. 14698 14699 if Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 14700 Old_C := First_Component (Typ); 14701 while Present (Old_C) loop 14702 if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then 14703 Append_Elmt (Old_C, Comp_List); 14704 end if; 14705 14706 Next_Component (Old_C); 14707 end loop; 14708 end if; 14709 end Collect_Fixed_Components; 14710 14711 --------------------------- 14712 -- Create_All_Components -- 14713 --------------------------- 14714 14715 procedure Create_All_Components is 14716 Comp : Elmt_Id; 14717 14718 begin 14719 Comp := First_Elmt (Comp_List); 14720 while Present (Comp) loop 14721 Old_C := Node (Comp); 14722 New_C := Create_Component (Old_C); 14723 14724 Set_Etype 14725 (New_C, 14726 Constrain_Component_Type 14727 (Old_C, Subt, Decl_Node, Typ, Constraints)); 14728 Set_Is_Public (New_C, Is_Public (Subt)); 14729 14730 Next_Elmt (Comp); 14731 end loop; 14732 end Create_All_Components; 14733 14734 ---------------------- 14735 -- Create_Component -- 14736 ---------------------- 14737 14738 function Create_Component (Old_Compon : Entity_Id) return Entity_Id is 14739 New_Compon : constant Entity_Id := New_Copy (Old_Compon); 14740 14741 begin 14742 if Ekind (Old_Compon) = E_Discriminant 14743 and then Is_Completely_Hidden (Old_Compon) 14744 then 14745 -- This is a shadow discriminant created for a discriminant of 14746 -- the parent type, which needs to be present in the subtype. 14747 -- Give the shadow discriminant an internal name that cannot 14748 -- conflict with that of visible components. 14749 14750 Set_Chars (New_Compon, New_Internal_Name ('C')); 14751 end if; 14752 14753 -- Set the parent so we have a proper link for freezing etc. This is 14754 -- not a real parent pointer, since of course our parent does not own 14755 -- up to us and reference us, we are an illegitimate child of the 14756 -- original parent. 14757 14758 Set_Parent (New_Compon, Parent (Old_Compon)); 14759 14760 -- We do not want this node marked as Comes_From_Source, since 14761 -- otherwise it would get first class status and a separate cross- 14762 -- reference line would be generated. Illegitimate children do not 14763 -- rate such recognition. 14764 14765 Set_Comes_From_Source (New_Compon, False); 14766 14767 -- But it is a real entity, and a birth certificate must be properly 14768 -- registered by entering it into the entity list, and setting its 14769 -- scope to the given subtype. This turns out to be useful for the 14770 -- LLVM code generator, but that scope is not used otherwise. 14771 14772 Enter_Name (New_Compon); 14773 Set_Scope (New_Compon, Subt); 14774 14775 return New_Compon; 14776 end Create_Component; 14777 14778 ----------------------- 14779 -- Is_Variant_Record -- 14780 ----------------------- 14781 14782 function Is_Variant_Record (T : Entity_Id) return Boolean is 14783 begin 14784 return Nkind (Parent (T)) = N_Full_Type_Declaration 14785 and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition 14786 and then Present (Component_List (Type_Definition (Parent (T)))) 14787 and then 14788 Present 14789 (Variant_Part (Component_List (Type_Definition (Parent (T))))); 14790 end Is_Variant_Record; 14791 14792 -- Start of processing for Create_Constrained_Components 14793 14794 begin 14795 pragma Assert (Subt /= Base_Type (Subt)); 14796 pragma Assert (Typ = Base_Type (Typ)); 14797 14798 Set_First_Entity (Subt, Empty); 14799 Set_Last_Entity (Subt, Empty); 14800 14801 -- Check whether constraint is fully static, in which case we can 14802 -- optimize the list of components. 14803 14804 Discr_Val := First_Elmt (Constraints); 14805 while Present (Discr_Val) loop 14806 if not Is_OK_Static_Expression (Node (Discr_Val)) then 14807 Is_Static := False; 14808 exit; 14809 end if; 14810 14811 Next_Elmt (Discr_Val); 14812 end loop; 14813 14814 Set_Has_Static_Discriminants (Subt, Is_Static); 14815 14816 Push_Scope (Subt); 14817 14818 -- Inherit the discriminants of the parent type 14819 14820 Add_Discriminants : declare 14821 Num_Disc : Nat; 14822 Num_Gird : Nat; 14823 14824 begin 14825 Num_Disc := 0; 14826 Old_C := First_Discriminant (Typ); 14827 14828 while Present (Old_C) loop 14829 Num_Disc := Num_Disc + 1; 14830 New_C := Create_Component (Old_C); 14831 Set_Is_Public (New_C, Is_Public (Subt)); 14832 Next_Discriminant (Old_C); 14833 end loop; 14834 14835 -- For an untagged derived subtype, the number of discriminants may 14836 -- be smaller than the number of inherited discriminants, because 14837 -- several of them may be renamed by a single new discriminant or 14838 -- constrained. In this case, add the hidden discriminants back into 14839 -- the subtype, because they need to be present if the optimizer of 14840 -- the GCC 4.x back-end decides to break apart assignments between 14841 -- objects using the parent view into member-wise assignments. 14842 14843 Num_Gird := 0; 14844 14845 if Is_Derived_Type (Typ) 14846 and then not Is_Tagged_Type (Typ) 14847 then 14848 Old_C := First_Stored_Discriminant (Typ); 14849 14850 while Present (Old_C) loop 14851 Num_Gird := Num_Gird + 1; 14852 Next_Stored_Discriminant (Old_C); 14853 end loop; 14854 end if; 14855 14856 if Num_Gird > Num_Disc then 14857 14858 -- Find out multiple uses of new discriminants, and add hidden 14859 -- components for the extra renamed discriminants. We recognize 14860 -- multiple uses through the Corresponding_Discriminant of a 14861 -- new discriminant: if it constrains several old discriminants, 14862 -- this field points to the last one in the parent type. The 14863 -- stored discriminants of the derived type have the same name 14864 -- as those of the parent. 14865 14866 declare 14867 Constr : Elmt_Id; 14868 New_Discr : Entity_Id; 14869 Old_Discr : Entity_Id; 14870 14871 begin 14872 Constr := First_Elmt (Stored_Constraint (Typ)); 14873 Old_Discr := First_Stored_Discriminant (Typ); 14874 while Present (Constr) loop 14875 if Is_Entity_Name (Node (Constr)) 14876 and then Ekind (Entity (Node (Constr))) = E_Discriminant 14877 then 14878 New_Discr := Entity (Node (Constr)); 14879 14880 if Chars (Corresponding_Discriminant (New_Discr)) /= 14881 Chars (Old_Discr) 14882 then 14883 -- The new discriminant has been used to rename a 14884 -- subsequent old discriminant. Introduce a shadow 14885 -- component for the current old discriminant. 14886 14887 New_C := Create_Component (Old_Discr); 14888 Set_Original_Record_Component (New_C, Old_Discr); 14889 end if; 14890 14891 else 14892 -- The constraint has eliminated the old discriminant. 14893 -- Introduce a shadow component. 14894 14895 New_C := Create_Component (Old_Discr); 14896 Set_Original_Record_Component (New_C, Old_Discr); 14897 end if; 14898 14899 Next_Elmt (Constr); 14900 Next_Stored_Discriminant (Old_Discr); 14901 end loop; 14902 end; 14903 end if; 14904 end Add_Discriminants; 14905 14906 if Is_Static 14907 and then Is_Variant_Record (Typ) 14908 then 14909 Collect_Fixed_Components (Typ); 14910 14911 Gather_Components ( 14912 Typ, 14913 Component_List (Type_Definition (Parent (Typ))), 14914 Governed_By => Assoc_List, 14915 Into => Comp_List, 14916 Report_Errors => Errors); 14917 pragma Assert (not Errors 14918 or else Serious_Errors_Detected > 0); 14919 14920 Create_All_Components; 14921 14922 -- If the subtype declaration is created for a tagged type derivation 14923 -- with constraints, we retrieve the record definition of the parent 14924 -- type to select the components of the proper variant. 14925 14926 elsif Is_Static 14927 and then Is_Tagged_Type (Typ) 14928 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 14929 and then 14930 Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition 14931 and then Is_Variant_Record (Parent_Type) 14932 then 14933 Collect_Fixed_Components (Typ); 14934 14935 Gather_Components 14936 (Typ, 14937 Component_List (Type_Definition (Parent (Parent_Type))), 14938 Governed_By => Assoc_List, 14939 Into => Comp_List, 14940 Report_Errors => Errors); 14941 14942 -- Note: previously there was a check at this point that no errors 14943 -- were detected. As a consequence of AI05-220 there may be an error 14944 -- if an inherited discriminant that controls a variant has a non- 14945 -- static constraint. 14946 14947 -- If the tagged derivation has a type extension, collect all the 14948 -- new components therein. 14949 14950 if Present (Record_Extension_Part (Type_Definition (Parent (Typ)))) 14951 then 14952 Old_C := First_Component (Typ); 14953 while Present (Old_C) loop 14954 if Original_Record_Component (Old_C) = Old_C 14955 and then Chars (Old_C) /= Name_uTag 14956 and then Chars (Old_C) /= Name_uParent 14957 then 14958 Append_Elmt (Old_C, Comp_List); 14959 end if; 14960 14961 Next_Component (Old_C); 14962 end loop; 14963 end if; 14964 14965 Create_All_Components; 14966 14967 else 14968 -- If discriminants are not static, or if this is a multi-level type 14969 -- extension, we have to include all components of the parent type. 14970 14971 Old_C := First_Component (Typ); 14972 while Present (Old_C) loop 14973 New_C := Create_Component (Old_C); 14974 14975 Set_Etype 14976 (New_C, 14977 Constrain_Component_Type 14978 (Old_C, Subt, Decl_Node, Typ, Constraints)); 14979 Set_Is_Public (New_C, Is_Public (Subt)); 14980 14981 Next_Component (Old_C); 14982 end loop; 14983 end if; 14984 14985 End_Scope; 14986 end Create_Constrained_Components; 14987 14988 ------------------------------------------ 14989 -- Decimal_Fixed_Point_Type_Declaration -- 14990 ------------------------------------------ 14991 14992 procedure Decimal_Fixed_Point_Type_Declaration 14993 (T : Entity_Id; 14994 Def : Node_Id) 14995 is 14996 Loc : constant Source_Ptr := Sloc (Def); 14997 Digs_Expr : constant Node_Id := Digits_Expression (Def); 14998 Delta_Expr : constant Node_Id := Delta_Expression (Def); 14999 Implicit_Base : Entity_Id; 15000 Digs_Val : Uint; 15001 Delta_Val : Ureal; 15002 Scale_Val : Uint; 15003 Bound_Val : Ureal; 15004 15005 begin 15006 Check_SPARK_05_Restriction 15007 ("decimal fixed point type is not allowed", Def); 15008 Check_Restriction (No_Fixed_Point, Def); 15009 15010 -- Create implicit base type 15011 15012 Implicit_Base := 15013 Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B'); 15014 Set_Etype (Implicit_Base, Implicit_Base); 15015 15016 -- Analyze and process delta expression 15017 15018 Analyze_And_Resolve (Delta_Expr, Universal_Real); 15019 15020 Check_Delta_Expression (Delta_Expr); 15021 Delta_Val := Expr_Value_R (Delta_Expr); 15022 15023 -- Check delta is power of 10, and determine scale value from it 15024 15025 declare 15026 Val : Ureal; 15027 15028 begin 15029 Scale_Val := Uint_0; 15030 Val := Delta_Val; 15031 15032 if Val < Ureal_1 then 15033 while Val < Ureal_1 loop 15034 Val := Val * Ureal_10; 15035 Scale_Val := Scale_Val + 1; 15036 end loop; 15037 15038 if Scale_Val > 18 then 15039 Error_Msg_N ("scale exceeds maximum value of 18", Def); 15040 Scale_Val := UI_From_Int (+18); 15041 end if; 15042 15043 else 15044 while Val > Ureal_1 loop 15045 Val := Val / Ureal_10; 15046 Scale_Val := Scale_Val - 1; 15047 end loop; 15048 15049 if Scale_Val < -18 then 15050 Error_Msg_N ("scale is less than minimum value of -18", Def); 15051 Scale_Val := UI_From_Int (-18); 15052 end if; 15053 end if; 15054 15055 if Val /= Ureal_1 then 15056 Error_Msg_N ("delta expression must be a power of 10", Def); 15057 Delta_Val := Ureal_10 ** (-Scale_Val); 15058 end if; 15059 end; 15060 15061 -- Set delta, scale and small (small = delta for decimal type) 15062 15063 Set_Delta_Value (Implicit_Base, Delta_Val); 15064 Set_Scale_Value (Implicit_Base, Scale_Val); 15065 Set_Small_Value (Implicit_Base, Delta_Val); 15066 15067 -- Analyze and process digits expression 15068 15069 Analyze_And_Resolve (Digs_Expr, Any_Integer); 15070 Check_Digits_Expression (Digs_Expr); 15071 Digs_Val := Expr_Value (Digs_Expr); 15072 15073 if Digs_Val > 18 then 15074 Digs_Val := UI_From_Int (+18); 15075 Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr); 15076 end if; 15077 15078 Set_Digits_Value (Implicit_Base, Digs_Val); 15079 Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val; 15080 15081 -- Set range of base type from digits value for now. This will be 15082 -- expanded to represent the true underlying base range by Freeze. 15083 15084 Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); 15085 15086 -- Note: We leave size as zero for now, size will be set at freeze 15087 -- time. We have to do this for ordinary fixed-point, because the size 15088 -- depends on the specified small, and we might as well do the same for 15089 -- decimal fixed-point. 15090 15091 pragma Assert (Esize (Implicit_Base) = Uint_0); 15092 15093 -- If there are bounds given in the declaration use them as the 15094 -- bounds of the first named subtype. 15095 15096 if Present (Real_Range_Specification (Def)) then 15097 declare 15098 RRS : constant Node_Id := Real_Range_Specification (Def); 15099 Low : constant Node_Id := Low_Bound (RRS); 15100 High : constant Node_Id := High_Bound (RRS); 15101 Low_Val : Ureal; 15102 High_Val : Ureal; 15103 15104 begin 15105 Analyze_And_Resolve (Low, Any_Real); 15106 Analyze_And_Resolve (High, Any_Real); 15107 Check_Real_Bound (Low); 15108 Check_Real_Bound (High); 15109 Low_Val := Expr_Value_R (Low); 15110 High_Val := Expr_Value_R (High); 15111 15112 if Low_Val < (-Bound_Val) then 15113 Error_Msg_N 15114 ("range low bound too small for digits value", Low); 15115 Low_Val := -Bound_Val; 15116 end if; 15117 15118 if High_Val > Bound_Val then 15119 Error_Msg_N 15120 ("range high bound too large for digits value", High); 15121 High_Val := Bound_Val; 15122 end if; 15123 15124 Set_Fixed_Range (T, Loc, Low_Val, High_Val); 15125 end; 15126 15127 -- If no explicit range, use range that corresponds to given 15128 -- digits value. This will end up as the final range for the 15129 -- first subtype. 15130 15131 else 15132 Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val); 15133 end if; 15134 15135 -- Complete entity for first subtype. The inheritance of the rep item 15136 -- chain ensures that SPARK-related pragmas are not clobbered when the 15137 -- decimal fixed point type acts as a full view of a private type. 15138 15139 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); 15140 Set_Etype (T, Implicit_Base); 15141 Set_Size_Info (T, Implicit_Base); 15142 Inherit_Rep_Item_Chain (T, Implicit_Base); 15143 Set_Digits_Value (T, Digs_Val); 15144 Set_Delta_Value (T, Delta_Val); 15145 Set_Small_Value (T, Delta_Val); 15146 Set_Scale_Value (T, Scale_Val); 15147 Set_Is_Constrained (T); 15148 end Decimal_Fixed_Point_Type_Declaration; 15149 15150 ----------------------------------- 15151 -- Derive_Progenitor_Subprograms -- 15152 ----------------------------------- 15153 15154 procedure Derive_Progenitor_Subprograms 15155 (Parent_Type : Entity_Id; 15156 Tagged_Type : Entity_Id) 15157 is 15158 E : Entity_Id; 15159 Elmt : Elmt_Id; 15160 Iface : Entity_Id; 15161 Iface_Alias : Entity_Id; 15162 Iface_Elmt : Elmt_Id; 15163 Iface_Subp : Entity_Id; 15164 New_Subp : Entity_Id := Empty; 15165 Prim_Elmt : Elmt_Id; 15166 Subp : Entity_Id; 15167 Typ : Entity_Id; 15168 15169 begin 15170 pragma Assert (Ada_Version >= Ada_2005 15171 and then Is_Record_Type (Tagged_Type) 15172 and then Is_Tagged_Type (Tagged_Type) 15173 and then Has_Interfaces (Tagged_Type)); 15174 15175 -- Step 1: Transfer to the full-view primitives associated with the 15176 -- partial-view that cover interface primitives. Conceptually this 15177 -- work should be done later by Process_Full_View; done here to 15178 -- simplify its implementation at later stages. It can be safely 15179 -- done here because interfaces must be visible in the partial and 15180 -- private view (RM 7.3(7.3/2)). 15181 15182 -- Small optimization: This work is only required if the parent may 15183 -- have entities whose Alias attribute reference an interface primitive. 15184 -- Such a situation may occur if the parent is an abstract type and the 15185 -- primitive has not been yet overridden or if the parent is a generic 15186 -- formal type covering interfaces. 15187 15188 -- If the tagged type is not abstract, it cannot have abstract 15189 -- primitives (the only entities in the list of primitives of 15190 -- non-abstract tagged types that can reference abstract primitives 15191 -- through its Alias attribute are the internal entities that have 15192 -- attribute Interface_Alias, and these entities are generated later 15193 -- by Add_Internal_Interface_Entities). 15194 15195 if In_Private_Part (Current_Scope) 15196 and then (Is_Abstract_Type (Parent_Type) 15197 or else 15198 Is_Generic_Type (Parent_Type)) 15199 then 15200 Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); 15201 while Present (Elmt) loop 15202 Subp := Node (Elmt); 15203 15204 -- At this stage it is not possible to have entities in the list 15205 -- of primitives that have attribute Interface_Alias. 15206 15207 pragma Assert (No (Interface_Alias (Subp))); 15208 15209 Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); 15210 15211 if Is_Interface (Typ) then 15212 E := Find_Primitive_Covering_Interface 15213 (Tagged_Type => Tagged_Type, 15214 Iface_Prim => Subp); 15215 15216 if Present (E) 15217 and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ 15218 then 15219 Replace_Elmt (Elmt, E); 15220 Remove_Homonym (Subp); 15221 end if; 15222 end if; 15223 15224 Next_Elmt (Elmt); 15225 end loop; 15226 end if; 15227 15228 -- Step 2: Add primitives of progenitors that are not implemented by 15229 -- parents of Tagged_Type. 15230 15231 if Present (Interfaces (Base_Type (Tagged_Type))) then 15232 Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type))); 15233 while Present (Iface_Elmt) loop 15234 Iface := Node (Iface_Elmt); 15235 15236 Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); 15237 while Present (Prim_Elmt) loop 15238 Iface_Subp := Node (Prim_Elmt); 15239 Iface_Alias := Ultimate_Alias (Iface_Subp); 15240 15241 -- Exclude derivation of predefined primitives except those 15242 -- that come from source, or are inherited from one that comes 15243 -- from source. Required to catch declarations of equality 15244 -- operators of interfaces. For example: 15245 15246 -- type Iface is interface; 15247 -- function "=" (Left, Right : Iface) return Boolean; 15248 15249 if not Is_Predefined_Dispatching_Operation (Iface_Subp) 15250 or else Comes_From_Source (Iface_Alias) 15251 then 15252 E := 15253 Find_Primitive_Covering_Interface 15254 (Tagged_Type => Tagged_Type, 15255 Iface_Prim => Iface_Subp); 15256 15257 -- If not found we derive a new primitive leaving its alias 15258 -- attribute referencing the interface primitive. 15259 15260 if No (E) then 15261 Derive_Subprogram 15262 (New_Subp, Iface_Subp, Tagged_Type, Iface); 15263 15264 -- Ada 2012 (AI05-0197): If the covering primitive's name 15265 -- differs from the name of the interface primitive then it 15266 -- is a private primitive inherited from a parent type. In 15267 -- such case, given that Tagged_Type covers the interface, 15268 -- the inherited private primitive becomes visible. For such 15269 -- purpose we add a new entity that renames the inherited 15270 -- private primitive. 15271 15272 elsif Chars (E) /= Chars (Iface_Subp) then 15273 pragma Assert (Has_Suffix (E, 'P')); 15274 Derive_Subprogram 15275 (New_Subp, Iface_Subp, Tagged_Type, Iface); 15276 Set_Alias (New_Subp, E); 15277 Set_Is_Abstract_Subprogram (New_Subp, 15278 Is_Abstract_Subprogram (E)); 15279 15280 -- Propagate to the full view interface entities associated 15281 -- with the partial view. 15282 15283 elsif In_Private_Part (Current_Scope) 15284 and then Present (Alias (E)) 15285 and then Alias (E) = Iface_Subp 15286 and then 15287 List_Containing (Parent (E)) /= 15288 Private_Declarations 15289 (Specification 15290 (Unit_Declaration_Node (Current_Scope))) 15291 then 15292 Append_Elmt (E, Primitive_Operations (Tagged_Type)); 15293 end if; 15294 end if; 15295 15296 Next_Elmt (Prim_Elmt); 15297 end loop; 15298 15299 Next_Elmt (Iface_Elmt); 15300 end loop; 15301 end if; 15302 end Derive_Progenitor_Subprograms; 15303 15304 ----------------------- 15305 -- Derive_Subprogram -- 15306 ----------------------- 15307 15308 procedure Derive_Subprogram 15309 (New_Subp : out Entity_Id; 15310 Parent_Subp : Entity_Id; 15311 Derived_Type : Entity_Id; 15312 Parent_Type : Entity_Id; 15313 Actual_Subp : Entity_Id := Empty) 15314 is 15315 Formal : Entity_Id; 15316 -- Formal parameter of parent primitive operation 15317 15318 Formal_Of_Actual : Entity_Id; 15319 -- Formal parameter of actual operation, when the derivation is to 15320 -- create a renaming for a primitive operation of an actual in an 15321 -- instantiation. 15322 15323 New_Formal : Entity_Id; 15324 -- Formal of inherited operation 15325 15326 Visible_Subp : Entity_Id := Parent_Subp; 15327 15328 function Is_Private_Overriding return Boolean; 15329 -- If Subp is a private overriding of a visible operation, the inherited 15330 -- operation derives from the overridden op (even though its body is the 15331 -- overriding one) and the inherited operation is visible now. See 15332 -- sem_disp to see the full details of the handling of the overridden 15333 -- subprogram, which is removed from the list of primitive operations of 15334 -- the type. The overridden subprogram is saved locally in Visible_Subp, 15335 -- and used to diagnose abstract operations that need overriding in the 15336 -- derived type. 15337 15338 procedure Replace_Type (Id, New_Id : Entity_Id); 15339 -- When the type is an anonymous access type, create a new access type 15340 -- designating the derived type. 15341 15342 procedure Set_Derived_Name; 15343 -- This procedure sets the appropriate Chars name for New_Subp. This 15344 -- is normally just a copy of the parent name. An exception arises for 15345 -- type support subprograms, where the name is changed to reflect the 15346 -- name of the derived type, e.g. if type foo is derived from type bar, 15347 -- then a procedure barDA is derived with a name fooDA. 15348 15349 --------------------------- 15350 -- Is_Private_Overriding -- 15351 --------------------------- 15352 15353 function Is_Private_Overriding return Boolean is 15354 Prev : Entity_Id; 15355 15356 begin 15357 -- If the parent is not a dispatching operation there is no 15358 -- need to investigate overridings 15359 15360 if not Is_Dispatching_Operation (Parent_Subp) then 15361 return False; 15362 end if; 15363 15364 -- The visible operation that is overridden is a homonym of the 15365 -- parent subprogram. We scan the homonym chain to find the one 15366 -- whose alias is the subprogram we are deriving. 15367 15368 Prev := Current_Entity (Parent_Subp); 15369 while Present (Prev) loop 15370 if Ekind (Prev) = Ekind (Parent_Subp) 15371 and then Alias (Prev) = Parent_Subp 15372 and then Scope (Parent_Subp) = Scope (Prev) 15373 and then not Is_Hidden (Prev) 15374 then 15375 Visible_Subp := Prev; 15376 return True; 15377 end if; 15378 15379 Prev := Homonym (Prev); 15380 end loop; 15381 15382 return False; 15383 end Is_Private_Overriding; 15384 15385 ------------------ 15386 -- Replace_Type -- 15387 ------------------ 15388 15389 procedure Replace_Type (Id, New_Id : Entity_Id) is 15390 Id_Type : constant Entity_Id := Etype (Id); 15391 Acc_Type : Entity_Id; 15392 Par : constant Node_Id := Parent (Derived_Type); 15393 15394 begin 15395 -- When the type is an anonymous access type, create a new access 15396 -- type designating the derived type. This itype must be elaborated 15397 -- at the point of the derivation, not on subsequent calls that may 15398 -- be out of the proper scope for Gigi, so we insert a reference to 15399 -- it after the derivation. 15400 15401 if Ekind (Id_Type) = E_Anonymous_Access_Type then 15402 declare 15403 Desig_Typ : Entity_Id := Designated_Type (Id_Type); 15404 15405 begin 15406 if Ekind (Desig_Typ) = E_Record_Type_With_Private 15407 and then Present (Full_View (Desig_Typ)) 15408 and then not Is_Private_Type (Parent_Type) 15409 then 15410 Desig_Typ := Full_View (Desig_Typ); 15411 end if; 15412 15413 if Base_Type (Desig_Typ) = Base_Type (Parent_Type) 15414 15415 -- Ada 2005 (AI-251): Handle also derivations of abstract 15416 -- interface primitives. 15417 15418 or else (Is_Interface (Desig_Typ) 15419 and then not Is_Class_Wide_Type (Desig_Typ)) 15420 then 15421 Acc_Type := New_Copy (Id_Type); 15422 Set_Etype (Acc_Type, Acc_Type); 15423 Set_Scope (Acc_Type, New_Subp); 15424 15425 -- Set size of anonymous access type. If we have an access 15426 -- to an unconstrained array, this is a fat pointer, so it 15427 -- is sizes at twice addtress size. 15428 15429 if Is_Array_Type (Desig_Typ) 15430 and then not Is_Constrained (Desig_Typ) 15431 then 15432 Init_Size (Acc_Type, 2 * System_Address_Size); 15433 15434 -- Other cases use a thin pointer 15435 15436 else 15437 Init_Size (Acc_Type, System_Address_Size); 15438 end if; 15439 15440 -- Set remaining characterstics of anonymous access type 15441 15442 Init_Alignment (Acc_Type); 15443 Set_Directly_Designated_Type (Acc_Type, Derived_Type); 15444 15445 Set_Etype (New_Id, Acc_Type); 15446 Set_Scope (New_Id, New_Subp); 15447 15448 -- Create a reference to it 15449 15450 Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); 15451 15452 else 15453 Set_Etype (New_Id, Id_Type); 15454 end if; 15455 end; 15456 15457 -- In Ada2012, a formal may have an incomplete type but the type 15458 -- derivation that inherits the primitive follows the full view. 15459 15460 elsif Base_Type (Id_Type) = Base_Type (Parent_Type) 15461 or else 15462 (Ekind (Id_Type) = E_Record_Type_With_Private 15463 and then Present (Full_View (Id_Type)) 15464 and then 15465 Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type)) 15466 or else 15467 (Ada_Version >= Ada_2012 15468 and then Ekind (Id_Type) = E_Incomplete_Type 15469 and then Full_View (Id_Type) = Parent_Type) 15470 then 15471 -- Constraint checks on formals are generated during expansion, 15472 -- based on the signature of the original subprogram. The bounds 15473 -- of the derived type are not relevant, and thus we can use 15474 -- the base type for the formals. However, the return type may be 15475 -- used in a context that requires that the proper static bounds 15476 -- be used (a case statement, for example) and for those cases 15477 -- we must use the derived type (first subtype), not its base. 15478 15479 -- If the derived_type_definition has no constraints, we know that 15480 -- the derived type has the same constraints as the first subtype 15481 -- of the parent, and we can also use it rather than its base, 15482 -- which can lead to more efficient code. 15483 15484 if Etype (Id) = Parent_Type then 15485 if Is_Scalar_Type (Parent_Type) 15486 and then 15487 Subtypes_Statically_Compatible (Parent_Type, Derived_Type) 15488 then 15489 Set_Etype (New_Id, Derived_Type); 15490 15491 elsif Nkind (Par) = N_Full_Type_Declaration 15492 and then 15493 Nkind (Type_Definition (Par)) = N_Derived_Type_Definition 15494 and then 15495 Is_Entity_Name 15496 (Subtype_Indication (Type_Definition (Par))) 15497 then 15498 Set_Etype (New_Id, Derived_Type); 15499 15500 else 15501 Set_Etype (New_Id, Base_Type (Derived_Type)); 15502 end if; 15503 15504 else 15505 Set_Etype (New_Id, Base_Type (Derived_Type)); 15506 end if; 15507 15508 else 15509 Set_Etype (New_Id, Etype (Id)); 15510 end if; 15511 end Replace_Type; 15512 15513 ---------------------- 15514 -- Set_Derived_Name -- 15515 ---------------------- 15516 15517 procedure Set_Derived_Name is 15518 Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp); 15519 begin 15520 if Nm = TSS_Null then 15521 Set_Chars (New_Subp, Chars (Parent_Subp)); 15522 else 15523 Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm)); 15524 end if; 15525 end Set_Derived_Name; 15526 15527 -- Start of processing for Derive_Subprogram 15528 15529 begin 15530 New_Subp := New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); 15531 Set_Ekind (New_Subp, Ekind (Parent_Subp)); 15532 15533 -- Check whether the inherited subprogram is a private operation that 15534 -- should be inherited but not yet made visible. Such subprograms can 15535 -- become visible at a later point (e.g., the private part of a public 15536 -- child unit) via Declare_Inherited_Private_Subprograms. If the 15537 -- following predicate is true, then this is not such a private 15538 -- operation and the subprogram simply inherits the name of the parent 15539 -- subprogram. Note the special check for the names of controlled 15540 -- operations, which are currently exempted from being inherited with 15541 -- a hidden name because they must be findable for generation of 15542 -- implicit run-time calls. 15543 15544 if not Is_Hidden (Parent_Subp) 15545 or else Is_Internal (Parent_Subp) 15546 or else Is_Private_Overriding 15547 or else Is_Internal_Name (Chars (Parent_Subp)) 15548 or else (Is_Controlled (Parent_Type) 15549 and then Nam_In (Chars (Parent_Subp), Name_Adjust, 15550 Name_Finalize, 15551 Name_Initialize)) 15552 then 15553 Set_Derived_Name; 15554 15555 -- An inherited dispatching equality will be overridden by an internally 15556 -- generated one, or by an explicit one, so preserve its name and thus 15557 -- its entry in the dispatch table. Otherwise, if Parent_Subp is a 15558 -- private operation it may become invisible if the full view has 15559 -- progenitors, and the dispatch table will be malformed. 15560 -- We check that the type is limited to handle the anomalous declaration 15561 -- of Limited_Controlled, which is derived from a non-limited type, and 15562 -- which is handled specially elsewhere as well. 15563 15564 elsif Chars (Parent_Subp) = Name_Op_Eq 15565 and then Is_Dispatching_Operation (Parent_Subp) 15566 and then Etype (Parent_Subp) = Standard_Boolean 15567 and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp))) 15568 and then 15569 Etype (First_Formal (Parent_Subp)) = 15570 Etype (Next_Formal (First_Formal (Parent_Subp))) 15571 then 15572 Set_Derived_Name; 15573 15574 -- If parent is hidden, this can be a regular derivation if the 15575 -- parent is immediately visible in a non-instantiating context, 15576 -- or if we are in the private part of an instance. This test 15577 -- should still be refined ??? 15578 15579 -- The test for In_Instance_Not_Visible avoids inheriting the derived 15580 -- operation as a non-visible operation in cases where the parent 15581 -- subprogram might not be visible now, but was visible within the 15582 -- original generic, so it would be wrong to make the inherited 15583 -- subprogram non-visible now. (Not clear if this test is fully 15584 -- correct; are there any cases where we should declare the inherited 15585 -- operation as not visible to avoid it being overridden, e.g., when 15586 -- the parent type is a generic actual with private primitives ???) 15587 15588 -- (they should be treated the same as other private inherited 15589 -- subprograms, but it's not clear how to do this cleanly). ??? 15590 15591 elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type))) 15592 and then Is_Immediately_Visible (Parent_Subp) 15593 and then not In_Instance) 15594 or else In_Instance_Not_Visible 15595 then 15596 Set_Derived_Name; 15597 15598 -- Ada 2005 (AI-251): Regular derivation if the parent subprogram 15599 -- overrides an interface primitive because interface primitives 15600 -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) 15601 15602 elsif Ada_Version >= Ada_2005 15603 and then Is_Dispatching_Operation (Parent_Subp) 15604 and then Present (Covered_Interface_Op (Parent_Subp)) 15605 then 15606 Set_Derived_Name; 15607 15608 -- Otherwise, the type is inheriting a private operation, so enter it 15609 -- with a special name so it can't be overridden. See also below, where 15610 -- we check for this case, and if so avoid setting Requires_Overriding. 15611 15612 else 15613 Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P')); 15614 end if; 15615 15616 Set_Parent (New_Subp, Parent (Derived_Type)); 15617 15618 if Present (Actual_Subp) then 15619 Replace_Type (Actual_Subp, New_Subp); 15620 else 15621 Replace_Type (Parent_Subp, New_Subp); 15622 end if; 15623 15624 Conditional_Delay (New_Subp, Parent_Subp); 15625 15626 -- If we are creating a renaming for a primitive operation of an 15627 -- actual of a generic derived type, we must examine the signature 15628 -- of the actual primitive, not that of the generic formal, which for 15629 -- example may be an interface. However the name and initial value 15630 -- of the inherited operation are those of the formal primitive. 15631 15632 Formal := First_Formal (Parent_Subp); 15633 15634 if Present (Actual_Subp) then 15635 Formal_Of_Actual := First_Formal (Actual_Subp); 15636 else 15637 Formal_Of_Actual := Empty; 15638 end if; 15639 15640 while Present (Formal) loop 15641 New_Formal := New_Copy (Formal); 15642 15643 -- Normally we do not go copying parents, but in the case of 15644 -- formals, we need to link up to the declaration (which is the 15645 -- parameter specification), and it is fine to link up to the 15646 -- original formal's parameter specification in this case. 15647 15648 Set_Parent (New_Formal, Parent (Formal)); 15649 Append_Entity (New_Formal, New_Subp); 15650 15651 if Present (Formal_Of_Actual) then 15652 Replace_Type (Formal_Of_Actual, New_Formal); 15653 Next_Formal (Formal_Of_Actual); 15654 else 15655 Replace_Type (Formal, New_Formal); 15656 end if; 15657 15658 Next_Formal (Formal); 15659 end loop; 15660 15661 -- If this derivation corresponds to a tagged generic actual, then 15662 -- primitive operations rename those of the actual. Otherwise the 15663 -- primitive operations rename those of the parent type, If the parent 15664 -- renames an intrinsic operator, so does the new subprogram. We except 15665 -- concatenation, which is always properly typed, and does not get 15666 -- expanded as other intrinsic operations. 15667 15668 if No (Actual_Subp) then 15669 if Is_Intrinsic_Subprogram (Parent_Subp) then 15670 Set_Is_Intrinsic_Subprogram (New_Subp); 15671 15672 if Present (Alias (Parent_Subp)) 15673 and then Chars (Parent_Subp) /= Name_Op_Concat 15674 then 15675 Set_Alias (New_Subp, Alias (Parent_Subp)); 15676 else 15677 Set_Alias (New_Subp, Parent_Subp); 15678 end if; 15679 15680 else 15681 Set_Alias (New_Subp, Parent_Subp); 15682 end if; 15683 15684 else 15685 Set_Alias (New_Subp, Actual_Subp); 15686 end if; 15687 15688 -- Derived subprograms of a tagged type must inherit the convention 15689 -- of the parent subprogram (a requirement of AI-117). Derived 15690 -- subprograms of untagged types simply get convention Ada by default. 15691 15692 -- If the derived type is a tagged generic formal type with unknown 15693 -- discriminants, its convention is intrinsic (RM 6.3.1 (8)). 15694 15695 -- However, if the type is derived from a generic formal, the further 15696 -- inherited subprogram has the convention of the non-generic ancestor. 15697 -- Otherwise there would be no way to override the operation. 15698 -- (This is subject to forthcoming ARG discussions). 15699 15700 if Is_Tagged_Type (Derived_Type) then 15701 if Is_Generic_Type (Derived_Type) 15702 and then Has_Unknown_Discriminants (Derived_Type) 15703 then 15704 Set_Convention (New_Subp, Convention_Intrinsic); 15705 15706 else 15707 if Is_Generic_Type (Parent_Type) 15708 and then Has_Unknown_Discriminants (Parent_Type) 15709 then 15710 Set_Convention (New_Subp, Convention (Alias (Parent_Subp))); 15711 else 15712 Set_Convention (New_Subp, Convention (Parent_Subp)); 15713 end if; 15714 end if; 15715 end if; 15716 15717 -- Predefined controlled operations retain their name even if the parent 15718 -- is hidden (see above), but they are not primitive operations if the 15719 -- ancestor is not visible, for example if the parent is a private 15720 -- extension completed with a controlled extension. Note that a full 15721 -- type that is controlled can break privacy: the flag Is_Controlled is 15722 -- set on both views of the type. 15723 15724 if Is_Controlled (Parent_Type) 15725 and then Nam_In (Chars (Parent_Subp), Name_Initialize, 15726 Name_Adjust, 15727 Name_Finalize) 15728 and then Is_Hidden (Parent_Subp) 15729 and then not Is_Visibly_Controlled (Parent_Type) 15730 then 15731 Set_Is_Hidden (New_Subp); 15732 end if; 15733 15734 Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp)); 15735 Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp)); 15736 15737 if Ekind (Parent_Subp) = E_Procedure then 15738 Set_Is_Valued_Procedure 15739 (New_Subp, Is_Valued_Procedure (Parent_Subp)); 15740 else 15741 Set_Has_Controlling_Result 15742 (New_Subp, Has_Controlling_Result (Parent_Subp)); 15743 end if; 15744 15745 -- No_Return must be inherited properly. If this is overridden in the 15746 -- case of a dispatching operation, then a check is made in Sem_Disp 15747 -- that the overriding operation is also No_Return (no such check is 15748 -- required for the case of non-dispatching operation. 15749 15750 Set_No_Return (New_Subp, No_Return (Parent_Subp)); 15751 15752 -- A derived function with a controlling result is abstract. If the 15753 -- Derived_Type is a nonabstract formal generic derived type, then 15754 -- inherited operations are not abstract: the required check is done at 15755 -- instantiation time. If the derivation is for a generic actual, the 15756 -- function is not abstract unless the actual is. 15757 15758 if Is_Generic_Type (Derived_Type) 15759 and then not Is_Abstract_Type (Derived_Type) 15760 then 15761 null; 15762 15763 -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" 15764 -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). 15765 15766 -- A subprogram subject to pragma Extensions_Visible with value False 15767 -- requires overriding if the subprogram has at least one controlling 15768 -- OUT parameter (SPARK RM 6.1.7(6)). 15769 15770 elsif Ada_Version >= Ada_2005 15771 and then (Is_Abstract_Subprogram (Alias (New_Subp)) 15772 or else (Is_Tagged_Type (Derived_Type) 15773 and then Etype (New_Subp) = Derived_Type 15774 and then not Is_Null_Extension (Derived_Type)) 15775 or else (Is_Tagged_Type (Derived_Type) 15776 and then Ekind (Etype (New_Subp)) = 15777 E_Anonymous_Access_Type 15778 and then Designated_Type (Etype (New_Subp)) = 15779 Derived_Type 15780 and then not Is_Null_Extension (Derived_Type)) 15781 or else (Comes_From_Source (Alias (New_Subp)) 15782 and then Is_EVF_Procedure (Alias (New_Subp)))) 15783 and then No (Actual_Subp) 15784 then 15785 if not Is_Tagged_Type (Derived_Type) 15786 or else Is_Abstract_Type (Derived_Type) 15787 or else Is_Abstract_Subprogram (Alias (New_Subp)) 15788 then 15789 Set_Is_Abstract_Subprogram (New_Subp); 15790 15791 -- If the Chars of the new subprogram is different from that of the 15792 -- parent's one, it means that we entered it with a special name so 15793 -- it can't be overridden (see above). In that case we had better not 15794 -- *require* it to be overridden. This is the case where the parent 15795 -- type inherited the operation privately, so there's no danger of 15796 -- dangling dispatching. 15797 15798 elsif Chars (New_Subp) = Chars (Alias (New_Subp)) then 15799 Set_Requires_Overriding (New_Subp); 15800 end if; 15801 15802 elsif Ada_Version < Ada_2005 15803 and then (Is_Abstract_Subprogram (Alias (New_Subp)) 15804 or else (Is_Tagged_Type (Derived_Type) 15805 and then Etype (New_Subp) = Derived_Type 15806 and then No (Actual_Subp))) 15807 then 15808 Set_Is_Abstract_Subprogram (New_Subp); 15809 15810 -- AI05-0097 : an inherited operation that dispatches on result is 15811 -- abstract if the derived type is abstract, even if the parent type 15812 -- is concrete and the derived type is a null extension. 15813 15814 elsif Has_Controlling_Result (Alias (New_Subp)) 15815 and then Is_Abstract_Type (Etype (New_Subp)) 15816 then 15817 Set_Is_Abstract_Subprogram (New_Subp); 15818 15819 -- Finally, if the parent type is abstract we must verify that all 15820 -- inherited operations are either non-abstract or overridden, or that 15821 -- the derived type itself is abstract (this check is performed at the 15822 -- end of a package declaration, in Check_Abstract_Overriding). A 15823 -- private overriding in the parent type will not be visible in the 15824 -- derivation if we are not in an inner package or in a child unit of 15825 -- the parent type, in which case the abstractness of the inherited 15826 -- operation is carried to the new subprogram. 15827 15828 elsif Is_Abstract_Type (Parent_Type) 15829 and then not In_Open_Scopes (Scope (Parent_Type)) 15830 and then Is_Private_Overriding 15831 and then Is_Abstract_Subprogram (Visible_Subp) 15832 then 15833 if No (Actual_Subp) then 15834 Set_Alias (New_Subp, Visible_Subp); 15835 Set_Is_Abstract_Subprogram (New_Subp, True); 15836 15837 else 15838 -- If this is a derivation for an instance of a formal derived 15839 -- type, abstractness comes from the primitive operation of the 15840 -- actual, not from the operation inherited from the ancestor. 15841 15842 Set_Is_Abstract_Subprogram 15843 (New_Subp, Is_Abstract_Subprogram (Actual_Subp)); 15844 end if; 15845 end if; 15846 15847 New_Overloaded_Entity (New_Subp, Derived_Type); 15848 15849 -- Ada RM 6.1.1 (15): If a subprogram inherits nonconforming class-wide 15850 -- preconditions and the derived type is abstract, the derived operation 15851 -- is abstract as well if parent subprogram is not abstract or null. 15852 15853 if Is_Abstract_Type (Derived_Type) 15854 and then Has_Non_Trivial_Precondition (Parent_Subp) 15855 and then Present (Interfaces (Derived_Type)) 15856 then 15857 15858 -- Add useful attributes of subprogram before the freeze point, 15859 -- in case freezing is delayed or there are previous errors. 15860 15861 Set_Is_Dispatching_Operation (New_Subp); 15862 15863 declare 15864 Iface_Prim : constant Entity_Id := Covered_Interface_Op (New_Subp); 15865 15866 begin 15867 if Present (Iface_Prim) 15868 and then Has_Non_Trivial_Precondition (Iface_Prim) 15869 then 15870 Set_Is_Abstract_Subprogram (New_Subp); 15871 end if; 15872 end; 15873 end if; 15874 15875 -- Check for case of a derived subprogram for the instantiation of a 15876 -- formal derived tagged type, if so mark the subprogram as dispatching 15877 -- and inherit the dispatching attributes of the actual subprogram. The 15878 -- derived subprogram is effectively renaming of the actual subprogram, 15879 -- so it needs to have the same attributes as the actual. 15880 15881 if Present (Actual_Subp) 15882 and then Is_Dispatching_Operation (Actual_Subp) 15883 then 15884 Set_Is_Dispatching_Operation (New_Subp); 15885 15886 if Present (DTC_Entity (Actual_Subp)) then 15887 Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp)); 15888 Set_DT_Position_Value (New_Subp, DT_Position (Actual_Subp)); 15889 end if; 15890 end if; 15891 15892 -- Indicate that a derived subprogram does not require a body and that 15893 -- it does not require processing of default expressions. 15894 15895 Set_Has_Completion (New_Subp); 15896 Set_Default_Expressions_Processed (New_Subp); 15897 15898 if Ekind (New_Subp) = E_Function then 15899 Set_Mechanism (New_Subp, Mechanism (Parent_Subp)); 15900 end if; 15901 end Derive_Subprogram; 15902 15903 ------------------------ 15904 -- Derive_Subprograms -- 15905 ------------------------ 15906 15907 procedure Derive_Subprograms 15908 (Parent_Type : Entity_Id; 15909 Derived_Type : Entity_Id; 15910 Generic_Actual : Entity_Id := Empty) 15911 is 15912 Op_List : constant Elist_Id := 15913 Collect_Primitive_Operations (Parent_Type); 15914 15915 function Check_Derived_Type return Boolean; 15916 -- Check that all the entities derived from Parent_Type are found in 15917 -- the list of primitives of Derived_Type exactly in the same order. 15918 15919 procedure Derive_Interface_Subprogram 15920 (New_Subp : out Entity_Id; 15921 Subp : Entity_Id; 15922 Actual_Subp : Entity_Id); 15923 -- Derive New_Subp from the ultimate alias of the parent subprogram Subp 15924 -- (which is an interface primitive). If Generic_Actual is present then 15925 -- Actual_Subp is the actual subprogram corresponding with the generic 15926 -- subprogram Subp. 15927 15928 ------------------------ 15929 -- Check_Derived_Type -- 15930 ------------------------ 15931 15932 function Check_Derived_Type return Boolean is 15933 E : Entity_Id; 15934 Elmt : Elmt_Id; 15935 List : Elist_Id; 15936 New_Subp : Entity_Id; 15937 Op_Elmt : Elmt_Id; 15938 Subp : Entity_Id; 15939 15940 begin 15941 -- Traverse list of entities in the current scope searching for 15942 -- an incomplete type whose full-view is derived type. 15943 15944 E := First_Entity (Scope (Derived_Type)); 15945 while Present (E) and then E /= Derived_Type loop 15946 if Ekind (E) = E_Incomplete_Type 15947 and then Present (Full_View (E)) 15948 and then Full_View (E) = Derived_Type 15949 then 15950 -- Disable this test if Derived_Type completes an incomplete 15951 -- type because in such case more primitives can be added 15952 -- later to the list of primitives of Derived_Type by routine 15953 -- Process_Incomplete_Dependents 15954 15955 return True; 15956 end if; 15957 15958 E := Next_Entity (E); 15959 end loop; 15960 15961 List := Collect_Primitive_Operations (Derived_Type); 15962 Elmt := First_Elmt (List); 15963 15964 Op_Elmt := First_Elmt (Op_List); 15965 while Present (Op_Elmt) loop 15966 Subp := Node (Op_Elmt); 15967 New_Subp := Node (Elmt); 15968 15969 -- At this early stage Derived_Type has no entities with attribute 15970 -- Interface_Alias. In addition, such primitives are always 15971 -- located at the end of the list of primitives of Parent_Type. 15972 -- Therefore, if found we can safely stop processing pending 15973 -- entities. 15974 15975 exit when Present (Interface_Alias (Subp)); 15976 15977 -- Handle hidden entities 15978 15979 if not Is_Predefined_Dispatching_Operation (Subp) 15980 and then Is_Hidden (Subp) 15981 then 15982 if Present (New_Subp) 15983 and then Primitive_Names_Match (Subp, New_Subp) 15984 then 15985 Next_Elmt (Elmt); 15986 end if; 15987 15988 else 15989 if not Present (New_Subp) 15990 or else Ekind (Subp) /= Ekind (New_Subp) 15991 or else not Primitive_Names_Match (Subp, New_Subp) 15992 then 15993 return False; 15994 end if; 15995 15996 Next_Elmt (Elmt); 15997 end if; 15998 15999 Next_Elmt (Op_Elmt); 16000 end loop; 16001 16002 return True; 16003 end Check_Derived_Type; 16004 16005 --------------------------------- 16006 -- Derive_Interface_Subprogram -- 16007 --------------------------------- 16008 16009 procedure Derive_Interface_Subprogram 16010 (New_Subp : out Entity_Id; 16011 Subp : Entity_Id; 16012 Actual_Subp : Entity_Id) 16013 is 16014 Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp); 16015 Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp); 16016 16017 begin 16018 pragma Assert (Is_Interface (Iface_Type)); 16019 16020 Derive_Subprogram 16021 (New_Subp => New_Subp, 16022 Parent_Subp => Iface_Subp, 16023 Derived_Type => Derived_Type, 16024 Parent_Type => Iface_Type, 16025 Actual_Subp => Actual_Subp); 16026 16027 -- Given that this new interface entity corresponds with a primitive 16028 -- of the parent that was not overridden we must leave it associated 16029 -- with its parent primitive to ensure that it will share the same 16030 -- dispatch table slot when overridden. We must set the Alias to Subp 16031 -- (instead of Iface_Subp), and we must fix Is_Abstract_Subprogram 16032 -- (in case we inherited Subp from Iface_Type via a nonabstract 16033 -- generic formal type). 16034 16035 if No (Actual_Subp) then 16036 Set_Alias (New_Subp, Subp); 16037 16038 declare 16039 T : Entity_Id := Find_Dispatching_Type (Subp); 16040 begin 16041 while Etype (T) /= T loop 16042 if Is_Generic_Type (T) and then not Is_Abstract_Type (T) then 16043 Set_Is_Abstract_Subprogram (New_Subp, False); 16044 exit; 16045 end if; 16046 16047 T := Etype (T); 16048 end loop; 16049 end; 16050 16051 -- For instantiations this is not needed since the previous call to 16052 -- Derive_Subprogram leaves the entity well decorated. 16053 16054 else 16055 pragma Assert (Alias (New_Subp) = Actual_Subp); 16056 null; 16057 end if; 16058 end Derive_Interface_Subprogram; 16059 16060 -- Local variables 16061 16062 Alias_Subp : Entity_Id; 16063 Act_List : Elist_Id; 16064 Act_Elmt : Elmt_Id; 16065 Act_Subp : Entity_Id := Empty; 16066 Elmt : Elmt_Id; 16067 Need_Search : Boolean := False; 16068 New_Subp : Entity_Id := Empty; 16069 Parent_Base : Entity_Id; 16070 Subp : Entity_Id; 16071 16072 -- Start of processing for Derive_Subprograms 16073 16074 begin 16075 if Ekind (Parent_Type) = E_Record_Type_With_Private 16076 and then Has_Discriminants (Parent_Type) 16077 and then Present (Full_View (Parent_Type)) 16078 then 16079 Parent_Base := Full_View (Parent_Type); 16080 else 16081 Parent_Base := Parent_Type; 16082 end if; 16083 16084 if Present (Generic_Actual) then 16085 Act_List := Collect_Primitive_Operations (Generic_Actual); 16086 Act_Elmt := First_Elmt (Act_List); 16087 else 16088 Act_List := No_Elist; 16089 Act_Elmt := No_Elmt; 16090 end if; 16091 16092 -- Derive primitives inherited from the parent. Note that if the generic 16093 -- actual is present, this is not really a type derivation, it is a 16094 -- completion within an instance. 16095 16096 -- Case 1: Derived_Type does not implement interfaces 16097 16098 if not Is_Tagged_Type (Derived_Type) 16099 or else (not Has_Interfaces (Derived_Type) 16100 and then not (Present (Generic_Actual) 16101 and then Has_Interfaces (Generic_Actual))) 16102 then 16103 Elmt := First_Elmt (Op_List); 16104 while Present (Elmt) loop 16105 Subp := Node (Elmt); 16106 16107 -- Literals are derived earlier in the process of building the 16108 -- derived type, and are skipped here. 16109 16110 if Ekind (Subp) = E_Enumeration_Literal then 16111 null; 16112 16113 -- The actual is a direct descendant and the common primitive 16114 -- operations appear in the same order. 16115 16116 -- If the generic parent type is present, the derived type is an 16117 -- instance of a formal derived type, and within the instance its 16118 -- operations are those of the actual. We derive from the formal 16119 -- type but make the inherited operations aliases of the 16120 -- corresponding operations of the actual. 16121 16122 else 16123 pragma Assert (No (Node (Act_Elmt)) 16124 or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) 16125 and then 16126 Type_Conformant 16127 (Subp, Node (Act_Elmt), 16128 Skip_Controlling_Formals => True))); 16129 16130 Derive_Subprogram 16131 (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); 16132 16133 if Present (Act_Elmt) then 16134 Next_Elmt (Act_Elmt); 16135 end if; 16136 end if; 16137 16138 Next_Elmt (Elmt); 16139 end loop; 16140 16141 -- Case 2: Derived_Type implements interfaces 16142 16143 else 16144 -- If the parent type has no predefined primitives we remove 16145 -- predefined primitives from the list of primitives of generic 16146 -- actual to simplify the complexity of this algorithm. 16147 16148 if Present (Generic_Actual) then 16149 declare 16150 Has_Predefined_Primitives : Boolean := False; 16151 16152 begin 16153 -- Check if the parent type has predefined primitives 16154 16155 Elmt := First_Elmt (Op_List); 16156 while Present (Elmt) loop 16157 Subp := Node (Elmt); 16158 16159 if Is_Predefined_Dispatching_Operation (Subp) 16160 and then not Comes_From_Source (Ultimate_Alias (Subp)) 16161 then 16162 Has_Predefined_Primitives := True; 16163 exit; 16164 end if; 16165 16166 Next_Elmt (Elmt); 16167 end loop; 16168 16169 -- Remove predefined primitives of Generic_Actual. We must use 16170 -- an auxiliary list because in case of tagged types the value 16171 -- returned by Collect_Primitive_Operations is the value stored 16172 -- in its Primitive_Operations attribute (and we don't want to 16173 -- modify its current contents). 16174 16175 if not Has_Predefined_Primitives then 16176 declare 16177 Aux_List : constant Elist_Id := New_Elmt_List; 16178 16179 begin 16180 Elmt := First_Elmt (Act_List); 16181 while Present (Elmt) loop 16182 Subp := Node (Elmt); 16183 16184 if not Is_Predefined_Dispatching_Operation (Subp) 16185 or else Comes_From_Source (Subp) 16186 then 16187 Append_Elmt (Subp, Aux_List); 16188 end if; 16189 16190 Next_Elmt (Elmt); 16191 end loop; 16192 16193 Act_List := Aux_List; 16194 end; 16195 end if; 16196 16197 Act_Elmt := First_Elmt (Act_List); 16198 Act_Subp := Node (Act_Elmt); 16199 end; 16200 end if; 16201 16202 -- Stage 1: If the generic actual is not present we derive the 16203 -- primitives inherited from the parent type. If the generic parent 16204 -- type is present, the derived type is an instance of a formal 16205 -- derived type, and within the instance its operations are those of 16206 -- the actual. We derive from the formal type but make the inherited 16207 -- operations aliases of the corresponding operations of the actual. 16208 16209 Elmt := First_Elmt (Op_List); 16210 while Present (Elmt) loop 16211 Subp := Node (Elmt); 16212 Alias_Subp := Ultimate_Alias (Subp); 16213 16214 -- Do not derive internal entities of the parent that link 16215 -- interface primitives with their covering primitive. These 16216 -- entities will be added to this type when frozen. 16217 16218 if Present (Interface_Alias (Subp)) then 16219 goto Continue; 16220 end if; 16221 16222 -- If the generic actual is present find the corresponding 16223 -- operation in the generic actual. If the parent type is a 16224 -- direct ancestor of the derived type then, even if it is an 16225 -- interface, the operations are inherited from the primary 16226 -- dispatch table and are in the proper order. If we detect here 16227 -- that primitives are not in the same order we traverse the list 16228 -- of primitive operations of the actual to find the one that 16229 -- implements the interface primitive. 16230 16231 if Need_Search 16232 or else 16233 (Present (Generic_Actual) 16234 and then Present (Act_Subp) 16235 and then not 16236 (Primitive_Names_Match (Subp, Act_Subp) 16237 and then 16238 Type_Conformant (Subp, Act_Subp, 16239 Skip_Controlling_Formals => True))) 16240 then 16241 pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual, 16242 Use_Full_View => True)); 16243 16244 -- Remember that we need searching for all pending primitives 16245 16246 Need_Search := True; 16247 16248 -- Handle entities associated with interface primitives 16249 16250 if Present (Alias_Subp) 16251 and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) 16252 and then not Is_Predefined_Dispatching_Operation (Subp) 16253 then 16254 -- Search for the primitive in the homonym chain 16255 16256 Act_Subp := 16257 Find_Primitive_Covering_Interface 16258 (Tagged_Type => Generic_Actual, 16259 Iface_Prim => Alias_Subp); 16260 16261 -- Previous search may not locate primitives covering 16262 -- interfaces defined in generics units or instantiations. 16263 -- (it fails if the covering primitive has formals whose 16264 -- type is also defined in generics or instantiations). 16265 -- In such case we search in the list of primitives of the 16266 -- generic actual for the internal entity that links the 16267 -- interface primitive and the covering primitive. 16268 16269 if No (Act_Subp) 16270 and then Is_Generic_Type (Parent_Type) 16271 then 16272 -- This code has been designed to handle only generic 16273 -- formals that implement interfaces that are defined 16274 -- in a generic unit or instantiation. If this code is 16275 -- needed for other cases we must review it because 16276 -- (given that it relies on Original_Location to locate 16277 -- the primitive of Generic_Actual that covers the 16278 -- interface) it could leave linked through attribute 16279 -- Alias entities of unrelated instantiations). 16280 16281 pragma Assert 16282 (Is_Generic_Unit 16283 (Scope (Find_Dispatching_Type (Alias_Subp))) 16284 or else 16285 Instantiation_Depth 16286 (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); 16287 16288 declare 16289 Iface_Prim_Loc : constant Source_Ptr := 16290 Original_Location (Sloc (Alias_Subp)); 16291 16292 Elmt : Elmt_Id; 16293 Prim : Entity_Id; 16294 16295 begin 16296 Elmt := 16297 First_Elmt (Primitive_Operations (Generic_Actual)); 16298 16299 Search : while Present (Elmt) loop 16300 Prim := Node (Elmt); 16301 16302 if Present (Interface_Alias (Prim)) 16303 and then Original_Location 16304 (Sloc (Interface_Alias (Prim))) = 16305 Iface_Prim_Loc 16306 then 16307 Act_Subp := Alias (Prim); 16308 exit Search; 16309 end if; 16310 16311 Next_Elmt (Elmt); 16312 end loop Search; 16313 end; 16314 end if; 16315 16316 pragma Assert (Present (Act_Subp) 16317 or else Is_Abstract_Type (Generic_Actual) 16318 or else Serious_Errors_Detected > 0); 16319 16320 -- Handle predefined primitives plus the rest of user-defined 16321 -- primitives 16322 16323 else 16324 Act_Elmt := First_Elmt (Act_List); 16325 while Present (Act_Elmt) loop 16326 Act_Subp := Node (Act_Elmt); 16327 16328 exit when Primitive_Names_Match (Subp, Act_Subp) 16329 and then Type_Conformant 16330 (Subp, Act_Subp, 16331 Skip_Controlling_Formals => True) 16332 and then No (Interface_Alias (Act_Subp)); 16333 16334 Next_Elmt (Act_Elmt); 16335 end loop; 16336 16337 if No (Act_Elmt) then 16338 Act_Subp := Empty; 16339 end if; 16340 end if; 16341 end if; 16342 16343 -- Case 1: If the parent is a limited interface then it has the 16344 -- predefined primitives of synchronized interfaces. However, the 16345 -- actual type may be a non-limited type and hence it does not 16346 -- have such primitives. 16347 16348 if Present (Generic_Actual) 16349 and then not Present (Act_Subp) 16350 and then Is_Limited_Interface (Parent_Base) 16351 and then Is_Predefined_Interface_Primitive (Subp) 16352 then 16353 null; 16354 16355 -- Case 2: Inherit entities associated with interfaces that were 16356 -- not covered by the parent type. We exclude here null interface 16357 -- primitives because they do not need special management. 16358 16359 -- We also exclude interface operations that are renamings. If the 16360 -- subprogram is an explicit renaming of an interface primitive, 16361 -- it is a regular primitive operation, and the presence of its 16362 -- alias is not relevant: it has to be derived like any other 16363 -- primitive. 16364 16365 elsif Present (Alias (Subp)) 16366 and then Nkind (Unit_Declaration_Node (Subp)) /= 16367 N_Subprogram_Renaming_Declaration 16368 and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) 16369 and then not 16370 (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification 16371 and then Null_Present (Parent (Alias_Subp))) 16372 then 16373 -- If this is an abstract private type then we transfer the 16374 -- derivation of the interface primitive from the partial view 16375 -- to the full view. This is safe because all the interfaces 16376 -- must be visible in the partial view. Done to avoid adding 16377 -- a new interface derivation to the private part of the 16378 -- enclosing package; otherwise this new derivation would be 16379 -- decorated as hidden when the analysis of the enclosing 16380 -- package completes. 16381 16382 if Is_Abstract_Type (Derived_Type) 16383 and then In_Private_Part (Current_Scope) 16384 and then Has_Private_Declaration (Derived_Type) 16385 then 16386 declare 16387 Partial_View : Entity_Id; 16388 Elmt : Elmt_Id; 16389 Ent : Entity_Id; 16390 16391 begin 16392 Partial_View := First_Entity (Current_Scope); 16393 loop 16394 exit when No (Partial_View) 16395 or else (Has_Private_Declaration (Partial_View) 16396 and then 16397 Full_View (Partial_View) = Derived_Type); 16398 16399 Next_Entity (Partial_View); 16400 end loop; 16401 16402 -- If the partial view was not found then the source code 16403 -- has errors and the derivation is not needed. 16404 16405 if Present (Partial_View) then 16406 Elmt := 16407 First_Elmt (Primitive_Operations (Partial_View)); 16408 while Present (Elmt) loop 16409 Ent := Node (Elmt); 16410 16411 if Present (Alias (Ent)) 16412 and then Ultimate_Alias (Ent) = Alias (Subp) 16413 then 16414 Append_Elmt 16415 (Ent, Primitive_Operations (Derived_Type)); 16416 exit; 16417 end if; 16418 16419 Next_Elmt (Elmt); 16420 end loop; 16421 16422 -- If the interface primitive was not found in the 16423 -- partial view then this interface primitive was 16424 -- overridden. We add a derivation to activate in 16425 -- Derive_Progenitor_Subprograms the machinery to 16426 -- search for it. 16427 16428 if No (Elmt) then 16429 Derive_Interface_Subprogram 16430 (New_Subp => New_Subp, 16431 Subp => Subp, 16432 Actual_Subp => Act_Subp); 16433 end if; 16434 end if; 16435 end; 16436 else 16437 Derive_Interface_Subprogram 16438 (New_Subp => New_Subp, 16439 Subp => Subp, 16440 Actual_Subp => Act_Subp); 16441 end if; 16442 16443 -- Case 3: Common derivation 16444 16445 else 16446 Derive_Subprogram 16447 (New_Subp => New_Subp, 16448 Parent_Subp => Subp, 16449 Derived_Type => Derived_Type, 16450 Parent_Type => Parent_Base, 16451 Actual_Subp => Act_Subp); 16452 end if; 16453 16454 -- No need to update Act_Elm if we must search for the 16455 -- corresponding operation in the generic actual 16456 16457 if not Need_Search 16458 and then Present (Act_Elmt) 16459 then 16460 Next_Elmt (Act_Elmt); 16461 Act_Subp := Node (Act_Elmt); 16462 end if; 16463 16464 <<Continue>> 16465 Next_Elmt (Elmt); 16466 end loop; 16467 16468 -- Inherit additional operations from progenitors. If the derived 16469 -- type is a generic actual, there are not new primitive operations 16470 -- for the type because it has those of the actual, and therefore 16471 -- nothing needs to be done. The renamings generated above are not 16472 -- primitive operations, and their purpose is simply to make the 16473 -- proper operations visible within an instantiation. 16474 16475 if No (Generic_Actual) then 16476 Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); 16477 end if; 16478 end if; 16479 16480 -- Final check: Direct descendants must have their primitives in the 16481 -- same order. We exclude from this test untagged types and instances 16482 -- of formal derived types. We skip this test if we have already 16483 -- reported serious errors in the sources. 16484 16485 pragma Assert (not Is_Tagged_Type (Derived_Type) 16486 or else Present (Generic_Actual) 16487 or else Serious_Errors_Detected > 0 16488 or else Check_Derived_Type); 16489 end Derive_Subprograms; 16490 16491 -------------------------------- 16492 -- Derived_Standard_Character -- 16493 -------------------------------- 16494 16495 procedure Derived_Standard_Character 16496 (N : Node_Id; 16497 Parent_Type : Entity_Id; 16498 Derived_Type : Entity_Id) 16499 is 16500 Loc : constant Source_Ptr := Sloc (N); 16501 Def : constant Node_Id := Type_Definition (N); 16502 Indic : constant Node_Id := Subtype_Indication (Def); 16503 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 16504 Implicit_Base : constant Entity_Id := 16505 Create_Itype 16506 (E_Enumeration_Type, N, Derived_Type, 'B'); 16507 16508 Lo : Node_Id; 16509 Hi : Node_Id; 16510 16511 begin 16512 Discard_Node (Process_Subtype (Indic, N)); 16513 16514 Set_Etype (Implicit_Base, Parent_Base); 16515 Set_Size_Info (Implicit_Base, Root_Type (Parent_Type)); 16516 Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type))); 16517 16518 Set_Is_Character_Type (Implicit_Base, True); 16519 Set_Has_Delayed_Freeze (Implicit_Base); 16520 16521 -- The bounds of the implicit base are the bounds of the parent base. 16522 -- Note that their type is the parent base. 16523 16524 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); 16525 Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); 16526 16527 Set_Scalar_Range (Implicit_Base, 16528 Make_Range (Loc, 16529 Low_Bound => Lo, 16530 High_Bound => Hi)); 16531 16532 Conditional_Delay (Derived_Type, Parent_Type); 16533 16534 Set_Ekind (Derived_Type, E_Enumeration_Subtype); 16535 Set_Etype (Derived_Type, Implicit_Base); 16536 Set_Size_Info (Derived_Type, Parent_Type); 16537 16538 if Unknown_RM_Size (Derived_Type) then 16539 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 16540 end if; 16541 16542 Set_Is_Character_Type (Derived_Type, True); 16543 16544 if Nkind (Indic) /= N_Subtype_Indication then 16545 16546 -- If no explicit constraint, the bounds are those 16547 -- of the parent type. 16548 16549 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type)); 16550 Hi := New_Copy_Tree (Type_High_Bound (Parent_Type)); 16551 Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi)); 16552 end if; 16553 16554 Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); 16555 16556 -- Because the implicit base is used in the conversion of the bounds, we 16557 -- have to freeze it now. This is similar to what is done for numeric 16558 -- types, and it equally suspicious, but otherwise a nonstatic bound 16559 -- will have a reference to an unfrozen type, which is rejected by Gigi 16560 -- (???). This requires specific care for definition of stream 16561 -- attributes. For details, see comments at the end of 16562 -- Build_Derived_Numeric_Type. 16563 16564 Freeze_Before (N, Implicit_Base); 16565 end Derived_Standard_Character; 16566 16567 ------------------------------ 16568 -- Derived_Type_Declaration -- 16569 ------------------------------ 16570 16571 procedure Derived_Type_Declaration 16572 (T : Entity_Id; 16573 N : Node_Id; 16574 Is_Completion : Boolean) 16575 is 16576 Parent_Type : Entity_Id; 16577 16578 function Comes_From_Generic (Typ : Entity_Id) return Boolean; 16579 -- Check whether the parent type is a generic formal, or derives 16580 -- directly or indirectly from one. 16581 16582 ------------------------ 16583 -- Comes_From_Generic -- 16584 ------------------------ 16585 16586 function Comes_From_Generic (Typ : Entity_Id) return Boolean is 16587 begin 16588 if Is_Generic_Type (Typ) then 16589 return True; 16590 16591 elsif Is_Generic_Type (Root_Type (Parent_Type)) then 16592 return True; 16593 16594 elsif Is_Private_Type (Typ) 16595 and then Present (Full_View (Typ)) 16596 and then Is_Generic_Type (Root_Type (Full_View (Typ))) 16597 then 16598 return True; 16599 16600 elsif Is_Generic_Actual_Type (Typ) then 16601 return True; 16602 16603 else 16604 return False; 16605 end if; 16606 end Comes_From_Generic; 16607 16608 -- Local variables 16609 16610 Def : constant Node_Id := Type_Definition (N); 16611 Iface_Def : Node_Id; 16612 Indic : constant Node_Id := Subtype_Indication (Def); 16613 Extension : constant Node_Id := Record_Extension_Part (Def); 16614 Parent_Node : Node_Id; 16615 Taggd : Boolean; 16616 16617 -- Start of processing for Derived_Type_Declaration 16618 16619 begin 16620 Parent_Type := Find_Type_Of_Subtype_Indic (Indic); 16621 16622 if SPARK_Mode = On 16623 and then Is_Tagged_Type (Parent_Type) 16624 then 16625 declare 16626 Partial_View : constant Entity_Id := 16627 Incomplete_Or_Partial_View (Parent_Type); 16628 16629 begin 16630 -- If the partial view was not found then the parent type is not 16631 -- a private type. Otherwise check if the partial view is a tagged 16632 -- private type. 16633 16634 if Present (Partial_View) 16635 and then Is_Private_Type (Partial_View) 16636 and then not Is_Tagged_Type (Partial_View) 16637 then 16638 Error_Msg_NE 16639 ("cannot derive from & declared as untagged private " 16640 & "(SPARK RM 3.4(1))", N, Partial_View); 16641 end if; 16642 end; 16643 end if; 16644 16645 -- Ada 2005 (AI-251): In case of interface derivation check that the 16646 -- parent is also an interface. 16647 16648 if Interface_Present (Def) then 16649 Check_SPARK_05_Restriction ("interface is not allowed", Def); 16650 16651 if not Is_Interface (Parent_Type) then 16652 Diagnose_Interface (Indic, Parent_Type); 16653 16654 else 16655 Parent_Node := Parent (Base_Type (Parent_Type)); 16656 Iface_Def := Type_Definition (Parent_Node); 16657 16658 -- Ada 2005 (AI-251): Limited interfaces can only inherit from 16659 -- other limited interfaces. 16660 16661 if Limited_Present (Def) then 16662 if Limited_Present (Iface_Def) then 16663 null; 16664 16665 elsif Protected_Present (Iface_Def) then 16666 Error_Msg_NE 16667 ("descendant of & must be declared as a protected " 16668 & "interface", N, Parent_Type); 16669 16670 elsif Synchronized_Present (Iface_Def) then 16671 Error_Msg_NE 16672 ("descendant of & must be declared as a synchronized " 16673 & "interface", N, Parent_Type); 16674 16675 elsif Task_Present (Iface_Def) then 16676 Error_Msg_NE 16677 ("descendant of & must be declared as a task interface", 16678 N, Parent_Type); 16679 16680 else 16681 Error_Msg_N 16682 ("(Ada 2005) limited interface cannot inherit from " 16683 & "non-limited interface", Indic); 16684 end if; 16685 16686 -- Ada 2005 (AI-345): Non-limited interfaces can only inherit 16687 -- from non-limited or limited interfaces. 16688 16689 elsif not Protected_Present (Def) 16690 and then not Synchronized_Present (Def) 16691 and then not Task_Present (Def) 16692 then 16693 if Limited_Present (Iface_Def) then 16694 null; 16695 16696 elsif Protected_Present (Iface_Def) then 16697 Error_Msg_NE 16698 ("descendant of & must be declared as a protected " 16699 & "interface", N, Parent_Type); 16700 16701 elsif Synchronized_Present (Iface_Def) then 16702 Error_Msg_NE 16703 ("descendant of & must be declared as a synchronized " 16704 & "interface", N, Parent_Type); 16705 16706 elsif Task_Present (Iface_Def) then 16707 Error_Msg_NE 16708 ("descendant of & must be declared as a task interface", 16709 N, Parent_Type); 16710 else 16711 null; 16712 end if; 16713 end if; 16714 end if; 16715 end if; 16716 16717 if Is_Tagged_Type (Parent_Type) 16718 and then Is_Concurrent_Type (Parent_Type) 16719 and then not Is_Interface (Parent_Type) 16720 then 16721 Error_Msg_N 16722 ("parent type of a record extension cannot be a synchronized " 16723 & "tagged type (RM 3.9.1 (3/1))", N); 16724 Set_Etype (T, Any_Type); 16725 return; 16726 end if; 16727 16728 -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor 16729 -- interfaces 16730 16731 if Is_Tagged_Type (Parent_Type) 16732 and then Is_Non_Empty_List (Interface_List (Def)) 16733 then 16734 declare 16735 Intf : Node_Id; 16736 T : Entity_Id; 16737 16738 begin 16739 Intf := First (Interface_List (Def)); 16740 while Present (Intf) loop 16741 T := Find_Type_Of_Subtype_Indic (Intf); 16742 16743 if not Is_Interface (T) then 16744 Diagnose_Interface (Intf, T); 16745 16746 -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow 16747 -- a limited type from having a nonlimited progenitor. 16748 16749 elsif (Limited_Present (Def) 16750 or else (not Is_Interface (Parent_Type) 16751 and then Is_Limited_Type (Parent_Type))) 16752 and then not Is_Limited_Interface (T) 16753 then 16754 Error_Msg_NE 16755 ("progenitor interface& of limited type must be limited", 16756 N, T); 16757 end if; 16758 16759 Next (Intf); 16760 end loop; 16761 end; 16762 end if; 16763 16764 if Parent_Type = Any_Type 16765 or else Etype (Parent_Type) = Any_Type 16766 or else (Is_Class_Wide_Type (Parent_Type) 16767 and then Etype (Parent_Type) = T) 16768 then 16769 -- If Parent_Type is undefined or illegal, make new type into a 16770 -- subtype of Any_Type, and set a few attributes to prevent cascaded 16771 -- errors. If this is a self-definition, emit error now. 16772 16773 if T = Parent_Type or else T = Etype (Parent_Type) then 16774 Error_Msg_N ("type cannot be used in its own definition", Indic); 16775 end if; 16776 16777 Set_Ekind (T, Ekind (Parent_Type)); 16778 Set_Etype (T, Any_Type); 16779 Set_Scalar_Range (T, Scalar_Range (Any_Type)); 16780 16781 if Is_Tagged_Type (T) 16782 and then Is_Record_Type (T) 16783 then 16784 Set_Direct_Primitive_Operations (T, New_Elmt_List); 16785 end if; 16786 16787 return; 16788 end if; 16789 16790 -- Ada 2005 (AI-251): The case in which the parent of the full-view is 16791 -- an interface is special because the list of interfaces in the full 16792 -- view can be given in any order. For example: 16793 16794 -- type A is interface; 16795 -- type B is interface and A; 16796 -- type D is new B with private; 16797 -- private 16798 -- type D is new A and B with null record; -- 1 -- 16799 16800 -- In this case we perform the following transformation of -1-: 16801 16802 -- type D is new B and A with null record; 16803 16804 -- If the parent of the full-view covers the parent of the partial-view 16805 -- we have two possible cases: 16806 16807 -- 1) They have the same parent 16808 -- 2) The parent of the full-view implements some further interfaces 16809 16810 -- In both cases we do not need to perform the transformation. In the 16811 -- first case the source program is correct and the transformation is 16812 -- not needed; in the second case the source program does not fulfill 16813 -- the no-hidden interfaces rule (AI-396) and the error will be reported 16814 -- later. 16815 16816 -- This transformation not only simplifies the rest of the analysis of 16817 -- this type declaration but also simplifies the correct generation of 16818 -- the object layout to the expander. 16819 16820 if In_Private_Part (Current_Scope) 16821 and then Is_Interface (Parent_Type) 16822 then 16823 declare 16824 Iface : Node_Id; 16825 Partial_View : Entity_Id; 16826 Partial_View_Parent : Entity_Id; 16827 New_Iface : Node_Id; 16828 16829 begin 16830 -- Look for the associated private type declaration 16831 16832 Partial_View := Incomplete_Or_Partial_View (T); 16833 16834 -- If the partial view was not found then the source code has 16835 -- errors and the transformation is not needed. 16836 16837 if Present (Partial_View) then 16838 Partial_View_Parent := Etype (Partial_View); 16839 16840 -- If the parent of the full-view covers the parent of the 16841 -- partial-view we have nothing else to do. 16842 16843 if Interface_Present_In_Ancestor 16844 (Parent_Type, Partial_View_Parent) 16845 then 16846 null; 16847 16848 -- Traverse the list of interfaces of the full-view to look 16849 -- for the parent of the partial-view and perform the tree 16850 -- transformation. 16851 16852 else 16853 Iface := First (Interface_List (Def)); 16854 while Present (Iface) loop 16855 if Etype (Iface) = Etype (Partial_View) then 16856 Rewrite (Subtype_Indication (Def), 16857 New_Copy (Subtype_Indication 16858 (Parent (Partial_View)))); 16859 16860 New_Iface := 16861 Make_Identifier (Sloc (N), Chars (Parent_Type)); 16862 Append (New_Iface, Interface_List (Def)); 16863 16864 -- Analyze the transformed code 16865 16866 Derived_Type_Declaration (T, N, Is_Completion); 16867 return; 16868 end if; 16869 16870 Next (Iface); 16871 end loop; 16872 end if; 16873 end if; 16874 end; 16875 end if; 16876 16877 -- Only composite types other than array types are allowed to have 16878 -- discriminants. 16879 16880 if Present (Discriminant_Specifications (N)) then 16881 if (Is_Elementary_Type (Parent_Type) 16882 or else 16883 Is_Array_Type (Parent_Type)) 16884 and then not Error_Posted (N) 16885 then 16886 Error_Msg_N 16887 ("elementary or array type cannot have discriminants", 16888 Defining_Identifier (First (Discriminant_Specifications (N)))); 16889 16890 -- Unset Has_Discriminants flag to prevent cascaded errors, but 16891 -- only if we are not already processing a malformed syntax tree. 16892 16893 if Is_Type (T) then 16894 Set_Has_Discriminants (T, False); 16895 end if; 16896 16897 -- The type is allowed to have discriminants 16898 16899 else 16900 Check_SPARK_05_Restriction ("discriminant type is not allowed", N); 16901 end if; 16902 end if; 16903 16904 -- In Ada 83, a derived type defined in a package specification cannot 16905 -- be used for further derivation until the end of its visible part. 16906 -- Note that derivation in the private part of the package is allowed. 16907 16908 if Ada_Version = Ada_83 16909 and then Is_Derived_Type (Parent_Type) 16910 and then In_Visible_Part (Scope (Parent_Type)) 16911 then 16912 if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then 16913 Error_Msg_N 16914 ("(Ada 83): premature use of type for derivation", Indic); 16915 end if; 16916 end if; 16917 16918 -- Check for early use of incomplete or private type 16919 16920 if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then 16921 Error_Msg_N ("premature derivation of incomplete type", Indic); 16922 return; 16923 16924 elsif (Is_Incomplete_Or_Private_Type (Parent_Type) 16925 and then not Comes_From_Generic (Parent_Type)) 16926 or else Has_Private_Component (Parent_Type) 16927 then 16928 -- The ancestor type of a formal type can be incomplete, in which 16929 -- case only the operations of the partial view are available in the 16930 -- generic. Subsequent checks may be required when the full view is 16931 -- analyzed to verify that a derivation from a tagged type has an 16932 -- extension. 16933 16934 if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then 16935 null; 16936 16937 elsif No (Underlying_Type (Parent_Type)) 16938 or else Has_Private_Component (Parent_Type) 16939 then 16940 Error_Msg_N 16941 ("premature derivation of derived or private type", Indic); 16942 16943 -- Flag the type itself as being in error, this prevents some 16944 -- nasty problems with subsequent uses of the malformed type. 16945 16946 Set_Error_Posted (T); 16947 16948 -- Check that within the immediate scope of an untagged partial 16949 -- view it's illegal to derive from the partial view if the 16950 -- full view is tagged. (7.3(7)) 16951 16952 -- We verify that the Parent_Type is a partial view by checking 16953 -- that it is not a Full_Type_Declaration (i.e. a private type or 16954 -- private extension declaration), to distinguish a partial view 16955 -- from a derivation from a private type which also appears as 16956 -- E_Private_Type. If the parent base type is not declared in an 16957 -- enclosing scope there is no need to check. 16958 16959 elsif Present (Full_View (Parent_Type)) 16960 and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration 16961 and then not Is_Tagged_Type (Parent_Type) 16962 and then Is_Tagged_Type (Full_View (Parent_Type)) 16963 and then In_Open_Scopes (Scope (Base_Type (Parent_Type))) 16964 then 16965 Error_Msg_N 16966 ("premature derivation from type with tagged full view", 16967 Indic); 16968 end if; 16969 end if; 16970 16971 -- Check that form of derivation is appropriate 16972 16973 Taggd := Is_Tagged_Type (Parent_Type); 16974 16975 -- Set the parent type to the class-wide type's specific type in this 16976 -- case to prevent cascading errors 16977 16978 if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then 16979 Error_Msg_N ("parent type must not be a class-wide type", Indic); 16980 Set_Etype (T, Etype (Parent_Type)); 16981 return; 16982 end if; 16983 16984 if Present (Extension) and then not Taggd then 16985 Error_Msg_N 16986 ("type derived from untagged type cannot have extension", Indic); 16987 16988 elsif No (Extension) and then Taggd then 16989 16990 -- If this declaration is within a private part (or body) of a 16991 -- generic instantiation then the derivation is allowed (the parent 16992 -- type can only appear tagged in this case if it's a generic actual 16993 -- type, since it would otherwise have been rejected in the analysis 16994 -- of the generic template). 16995 16996 if not Is_Generic_Actual_Type (Parent_Type) 16997 or else In_Visible_Part (Scope (Parent_Type)) 16998 then 16999 if Is_Class_Wide_Type (Parent_Type) then 17000 Error_Msg_N 17001 ("parent type must not be a class-wide type", Indic); 17002 17003 -- Use specific type to prevent cascaded errors. 17004 17005 Parent_Type := Etype (Parent_Type); 17006 17007 else 17008 Error_Msg_N 17009 ("type derived from tagged type must have extension", Indic); 17010 end if; 17011 end if; 17012 end if; 17013 17014 -- AI-443: Synchronized formal derived types require a private 17015 -- extension. There is no point in checking the ancestor type or 17016 -- the progenitors since the construct is wrong to begin with. 17017 17018 if Ada_Version >= Ada_2005 17019 and then Is_Generic_Type (T) 17020 and then Present (Original_Node (N)) 17021 then 17022 declare 17023 Decl : constant Node_Id := Original_Node (N); 17024 17025 begin 17026 if Nkind (Decl) = N_Formal_Type_Declaration 17027 and then Nkind (Formal_Type_Definition (Decl)) = 17028 N_Formal_Derived_Type_Definition 17029 and then Synchronized_Present (Formal_Type_Definition (Decl)) 17030 and then No (Extension) 17031 17032 -- Avoid emitting a duplicate error message 17033 17034 and then not Error_Posted (Indic) 17035 then 17036 Error_Msg_N 17037 ("synchronized derived type must have extension", N); 17038 end if; 17039 end; 17040 end if; 17041 17042 if Null_Exclusion_Present (Def) 17043 and then not Is_Access_Type (Parent_Type) 17044 then 17045 Error_Msg_N ("null exclusion can only apply to an access type", N); 17046 end if; 17047 17048 -- Avoid deriving parent primitives of underlying record views 17049 17050 Build_Derived_Type (N, Parent_Type, T, Is_Completion, 17051 Derive_Subps => not Is_Underlying_Record_View (T)); 17052 17053 -- AI-419: The parent type of an explicitly limited derived type must 17054 -- be a limited type or a limited interface. 17055 17056 if Limited_Present (Def) then 17057 Set_Is_Limited_Record (T); 17058 17059 if Is_Interface (T) then 17060 Set_Is_Limited_Interface (T); 17061 end if; 17062 17063 if not Is_Limited_Type (Parent_Type) 17064 and then 17065 (not Is_Interface (Parent_Type) 17066 or else not Is_Limited_Interface (Parent_Type)) 17067 then 17068 -- AI05-0096: a derivation in the private part of an instance is 17069 -- legal if the generic formal is untagged limited, and the actual 17070 -- is non-limited. 17071 17072 if Is_Generic_Actual_Type (Parent_Type) 17073 and then In_Private_Part (Current_Scope) 17074 and then 17075 not Is_Tagged_Type 17076 (Generic_Parent_Type (Parent (Parent_Type))) 17077 then 17078 null; 17079 17080 else 17081 Error_Msg_NE 17082 ("parent type& of limited type must be limited", 17083 N, Parent_Type); 17084 end if; 17085 end if; 17086 end if; 17087 17088 -- In SPARK, there are no derived type definitions other than type 17089 -- extensions of tagged record types. 17090 17091 if No (Extension) then 17092 Check_SPARK_05_Restriction 17093 ("derived type is not allowed", Original_Node (N)); 17094 end if; 17095 end Derived_Type_Declaration; 17096 17097 ------------------------ 17098 -- Diagnose_Interface -- 17099 ------------------------ 17100 17101 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is 17102 begin 17103 if not Is_Interface (E) and then E /= Any_Type then 17104 Error_Msg_NE ("(Ada 2005) & must be an interface", N, E); 17105 end if; 17106 end Diagnose_Interface; 17107 17108 ---------------------------------- 17109 -- Enumeration_Type_Declaration -- 17110 ---------------------------------- 17111 17112 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is 17113 Ev : Uint; 17114 L : Node_Id; 17115 R_Node : Node_Id; 17116 B_Node : Node_Id; 17117 17118 begin 17119 -- Create identifier node representing lower bound 17120 17121 B_Node := New_Node (N_Identifier, Sloc (Def)); 17122 L := First (Literals (Def)); 17123 Set_Chars (B_Node, Chars (L)); 17124 Set_Entity (B_Node, L); 17125 Set_Etype (B_Node, T); 17126 Set_Is_Static_Expression (B_Node, True); 17127 17128 R_Node := New_Node (N_Range, Sloc (Def)); 17129 Set_Low_Bound (R_Node, B_Node); 17130 17131 Set_Ekind (T, E_Enumeration_Type); 17132 Set_First_Literal (T, L); 17133 Set_Etype (T, T); 17134 Set_Is_Constrained (T); 17135 17136 Ev := Uint_0; 17137 17138 -- Loop through literals of enumeration type setting pos and rep values 17139 -- except that if the Ekind is already set, then it means the literal 17140 -- was already constructed (case of a derived type declaration and we 17141 -- should not disturb the Pos and Rep values. 17142 17143 while Present (L) loop 17144 if Ekind (L) /= E_Enumeration_Literal then 17145 Set_Ekind (L, E_Enumeration_Literal); 17146 Set_Enumeration_Pos (L, Ev); 17147 Set_Enumeration_Rep (L, Ev); 17148 Set_Is_Known_Valid (L, True); 17149 end if; 17150 17151 Set_Etype (L, T); 17152 New_Overloaded_Entity (L); 17153 Generate_Definition (L); 17154 Set_Convention (L, Convention_Intrinsic); 17155 17156 -- Case of character literal 17157 17158 if Nkind (L) = N_Defining_Character_Literal then 17159 Set_Is_Character_Type (T, True); 17160 17161 -- Check violation of No_Wide_Characters 17162 17163 if Restriction_Check_Required (No_Wide_Characters) then 17164 Get_Name_String (Chars (L)); 17165 17166 if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then 17167 Check_Restriction (No_Wide_Characters, L); 17168 end if; 17169 end if; 17170 end if; 17171 17172 Ev := Ev + 1; 17173 Next (L); 17174 end loop; 17175 17176 -- Now create a node representing upper bound 17177 17178 B_Node := New_Node (N_Identifier, Sloc (Def)); 17179 Set_Chars (B_Node, Chars (Last (Literals (Def)))); 17180 Set_Entity (B_Node, Last (Literals (Def))); 17181 Set_Etype (B_Node, T); 17182 Set_Is_Static_Expression (B_Node, True); 17183 17184 Set_High_Bound (R_Node, B_Node); 17185 17186 -- Initialize various fields of the type. Some of this information 17187 -- may be overwritten later through rep.clauses. 17188 17189 Set_Scalar_Range (T, R_Node); 17190 Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); 17191 Set_Enum_Esize (T); 17192 Set_Enum_Pos_To_Rep (T, Empty); 17193 17194 -- Set Discard_Names if configuration pragma set, or if there is 17195 -- a parameterless pragma in the current declarative region 17196 17197 if Global_Discard_Names or else Discard_Names (Scope (T)) then 17198 Set_Discard_Names (T); 17199 end if; 17200 17201 -- Process end label if there is one 17202 17203 if Present (Def) then 17204 Process_End_Label (Def, 'e', T); 17205 end if; 17206 end Enumeration_Type_Declaration; 17207 17208 --------------------------------- 17209 -- Expand_To_Stored_Constraint -- 17210 --------------------------------- 17211 17212 function Expand_To_Stored_Constraint 17213 (Typ : Entity_Id; 17214 Constraint : Elist_Id) return Elist_Id 17215 is 17216 Explicitly_Discriminated_Type : Entity_Id; 17217 Expansion : Elist_Id; 17218 Discriminant : Entity_Id; 17219 17220 function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id; 17221 -- Find the nearest type that actually specifies discriminants 17222 17223 --------------------------------- 17224 -- Type_With_Explicit_Discrims -- 17225 --------------------------------- 17226 17227 function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is 17228 Typ : constant E := Base_Type (Id); 17229 17230 begin 17231 if Ekind (Typ) in Incomplete_Or_Private_Kind then 17232 if Present (Full_View (Typ)) then 17233 return Type_With_Explicit_Discrims (Full_View (Typ)); 17234 end if; 17235 17236 else 17237 if Has_Discriminants (Typ) then 17238 return Typ; 17239 end if; 17240 end if; 17241 17242 if Etype (Typ) = Typ then 17243 return Empty; 17244 elsif Has_Discriminants (Typ) then 17245 return Typ; 17246 else 17247 return Type_With_Explicit_Discrims (Etype (Typ)); 17248 end if; 17249 17250 end Type_With_Explicit_Discrims; 17251 17252 -- Start of processing for Expand_To_Stored_Constraint 17253 17254 begin 17255 if No (Constraint) or else Is_Empty_Elmt_List (Constraint) then 17256 return No_Elist; 17257 end if; 17258 17259 Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ); 17260 17261 if No (Explicitly_Discriminated_Type) then 17262 return No_Elist; 17263 end if; 17264 17265 Expansion := New_Elmt_List; 17266 17267 Discriminant := 17268 First_Stored_Discriminant (Explicitly_Discriminated_Type); 17269 while Present (Discriminant) loop 17270 Append_Elmt 17271 (Get_Discriminant_Value 17272 (Discriminant, Explicitly_Discriminated_Type, Constraint), 17273 To => Expansion); 17274 Next_Stored_Discriminant (Discriminant); 17275 end loop; 17276 17277 return Expansion; 17278 end Expand_To_Stored_Constraint; 17279 17280 --------------------------- 17281 -- Find_Hidden_Interface -- 17282 --------------------------- 17283 17284 function Find_Hidden_Interface 17285 (Src : Elist_Id; 17286 Dest : Elist_Id) return Entity_Id 17287 is 17288 Iface : Entity_Id; 17289 Iface_Elmt : Elmt_Id; 17290 17291 begin 17292 if Present (Src) and then Present (Dest) then 17293 Iface_Elmt := First_Elmt (Src); 17294 while Present (Iface_Elmt) loop 17295 Iface := Node (Iface_Elmt); 17296 17297 if Is_Interface (Iface) 17298 and then not Contain_Interface (Iface, Dest) 17299 then 17300 return Iface; 17301 end if; 17302 17303 Next_Elmt (Iface_Elmt); 17304 end loop; 17305 end if; 17306 17307 return Empty; 17308 end Find_Hidden_Interface; 17309 17310 -------------------- 17311 -- Find_Type_Name -- 17312 -------------------- 17313 17314 function Find_Type_Name (N : Node_Id) return Entity_Id is 17315 Id : constant Entity_Id := Defining_Identifier (N); 17316 New_Id : Entity_Id; 17317 Prev : Entity_Id; 17318 Prev_Par : Node_Id; 17319 17320 procedure Check_Duplicate_Aspects; 17321 -- Check that aspects specified in a completion have not been specified 17322 -- already in the partial view. 17323 17324 procedure Tag_Mismatch; 17325 -- Diagnose a tagged partial view whose full view is untagged. We post 17326 -- the message on the full view, with a reference to the previous 17327 -- partial view. The partial view can be private or incomplete, and 17328 -- these are handled in a different manner, so we determine the position 17329 -- of the error message from the respective slocs of both. 17330 17331 ----------------------------- 17332 -- Check_Duplicate_Aspects -- 17333 ----------------------------- 17334 17335 procedure Check_Duplicate_Aspects is 17336 function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id; 17337 -- Return the corresponding aspect of the partial view which matches 17338 -- the aspect id of Asp. Return Empty is no such aspect exists. 17339 17340 ----------------------------- 17341 -- Get_Partial_View_Aspect -- 17342 ----------------------------- 17343 17344 function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id is 17345 Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp); 17346 Prev_Asps : constant List_Id := Aspect_Specifications (Prev_Par); 17347 Prev_Asp : Node_Id; 17348 17349 begin 17350 if Present (Prev_Asps) then 17351 Prev_Asp := First (Prev_Asps); 17352 while Present (Prev_Asp) loop 17353 if Get_Aspect_Id (Prev_Asp) = Asp_Id then 17354 return Prev_Asp; 17355 end if; 17356 17357 Next (Prev_Asp); 17358 end loop; 17359 end if; 17360 17361 return Empty; 17362 end Get_Partial_View_Aspect; 17363 17364 -- Local variables 17365 17366 Full_Asps : constant List_Id := Aspect_Specifications (N); 17367 Full_Asp : Node_Id; 17368 Part_Asp : Node_Id; 17369 17370 -- Start of processing for Check_Duplicate_Aspects 17371 17372 begin 17373 if Present (Full_Asps) then 17374 Full_Asp := First (Full_Asps); 17375 while Present (Full_Asp) loop 17376 Part_Asp := Get_Partial_View_Aspect (Full_Asp); 17377 17378 -- An aspect and its class-wide counterpart are two distinct 17379 -- aspects and may apply to both views of an entity. 17380 17381 if Present (Part_Asp) 17382 and then Class_Present (Part_Asp) = Class_Present (Full_Asp) 17383 then 17384 Error_Msg_N 17385 ("aspect already specified in private declaration", 17386 Full_Asp); 17387 17388 Remove (Full_Asp); 17389 return; 17390 end if; 17391 17392 if Has_Discriminants (Prev) 17393 and then not Has_Unknown_Discriminants (Prev) 17394 and then Get_Aspect_Id (Full_Asp) = 17395 Aspect_Implicit_Dereference 17396 then 17397 Error_Msg_N 17398 ("cannot specify aspect if partial view has known " 17399 & "discriminants", Full_Asp); 17400 end if; 17401 17402 Next (Full_Asp); 17403 end loop; 17404 end if; 17405 end Check_Duplicate_Aspects; 17406 17407 ------------------ 17408 -- Tag_Mismatch -- 17409 ------------------ 17410 17411 procedure Tag_Mismatch is 17412 begin 17413 if Sloc (Prev) < Sloc (Id) then 17414 if Ada_Version >= Ada_2012 17415 and then Nkind (N) = N_Private_Type_Declaration 17416 then 17417 Error_Msg_NE 17418 ("declaration of private } must be a tagged type ", Id, Prev); 17419 else 17420 Error_Msg_NE 17421 ("full declaration of } must be a tagged type ", Id, Prev); 17422 end if; 17423 17424 else 17425 if Ada_Version >= Ada_2012 17426 and then Nkind (N) = N_Private_Type_Declaration 17427 then 17428 Error_Msg_NE 17429 ("declaration of private } must be a tagged type ", Prev, Id); 17430 else 17431 Error_Msg_NE 17432 ("full declaration of } must be a tagged type ", Prev, Id); 17433 end if; 17434 end if; 17435 end Tag_Mismatch; 17436 17437 -- Start of processing for Find_Type_Name 17438 17439 begin 17440 -- Find incomplete declaration, if one was given 17441 17442 Prev := Current_Entity_In_Scope (Id); 17443 17444 -- New type declaration 17445 17446 if No (Prev) then 17447 Enter_Name (Id); 17448 return Id; 17449 17450 -- Previous declaration exists 17451 17452 else 17453 Prev_Par := Parent (Prev); 17454 17455 -- Error if not incomplete/private case except if previous 17456 -- declaration is implicit, etc. Enter_Name will emit error if 17457 -- appropriate. 17458 17459 if not Is_Incomplete_Or_Private_Type (Prev) then 17460 Enter_Name (Id); 17461 New_Id := Id; 17462 17463 -- Check invalid completion of private or incomplete type 17464 17465 elsif not Nkind_In (N, N_Full_Type_Declaration, 17466 N_Task_Type_Declaration, 17467 N_Protected_Type_Declaration) 17468 and then 17469 (Ada_Version < Ada_2012 17470 or else not Is_Incomplete_Type (Prev) 17471 or else not Nkind_In (N, N_Private_Type_Declaration, 17472 N_Private_Extension_Declaration)) 17473 then 17474 -- Completion must be a full type declarations (RM 7.3(4)) 17475 17476 Error_Msg_Sloc := Sloc (Prev); 17477 Error_Msg_NE ("invalid completion of }", Id, Prev); 17478 17479 -- Set scope of Id to avoid cascaded errors. Entity is never 17480 -- examined again, except when saving globals in generics. 17481 17482 Set_Scope (Id, Current_Scope); 17483 New_Id := Id; 17484 17485 -- If this is a repeated incomplete declaration, no further 17486 -- checks are possible. 17487 17488 if Nkind (N) = N_Incomplete_Type_Declaration then 17489 return Prev; 17490 end if; 17491 17492 -- Case of full declaration of incomplete type 17493 17494 elsif Ekind (Prev) = E_Incomplete_Type 17495 and then (Ada_Version < Ada_2012 17496 or else No (Full_View (Prev)) 17497 or else not Is_Private_Type (Full_View (Prev))) 17498 then 17499 -- Indicate that the incomplete declaration has a matching full 17500 -- declaration. The defining occurrence of the incomplete 17501 -- declaration remains the visible one, and the procedure 17502 -- Get_Full_View dereferences it whenever the type is used. 17503 17504 if Present (Full_View (Prev)) then 17505 Error_Msg_NE ("invalid redeclaration of }", Id, Prev); 17506 end if; 17507 17508 Set_Full_View (Prev, Id); 17509 Append_Entity (Id, Current_Scope); 17510 Set_Is_Public (Id, Is_Public (Prev)); 17511 Set_Is_Internal (Id); 17512 New_Id := Prev; 17513 17514 -- If the incomplete view is tagged, a class_wide type has been 17515 -- created already. Use it for the private type as well, in order 17516 -- to prevent multiple incompatible class-wide types that may be 17517 -- created for self-referential anonymous access components. 17518 17519 if Is_Tagged_Type (Prev) 17520 and then Present (Class_Wide_Type (Prev)) 17521 then 17522 Set_Ekind (Id, Ekind (Prev)); -- will be reset later 17523 Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); 17524 17525 -- Type of the class-wide type is the current Id. Previously 17526 -- this was not done for private declarations because of order- 17527 -- of-elaboration issues in the back end, but gigi now handles 17528 -- this properly. 17529 17530 Set_Etype (Class_Wide_Type (Id), Id); 17531 end if; 17532 17533 -- Case of full declaration of private type 17534 17535 else 17536 -- If the private type was a completion of an incomplete type then 17537 -- update Prev to reference the private type 17538 17539 if Ada_Version >= Ada_2012 17540 and then Ekind (Prev) = E_Incomplete_Type 17541 and then Present (Full_View (Prev)) 17542 and then Is_Private_Type (Full_View (Prev)) 17543 then 17544 Prev := Full_View (Prev); 17545 Prev_Par := Parent (Prev); 17546 end if; 17547 17548 if Nkind (N) = N_Full_Type_Declaration 17549 and then Nkind_In 17550 (Type_Definition (N), N_Record_Definition, 17551 N_Derived_Type_Definition) 17552 and then Interface_Present (Type_Definition (N)) 17553 then 17554 Error_Msg_N 17555 ("completion of private type cannot be an interface", N); 17556 end if; 17557 17558 if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then 17559 if Etype (Prev) /= Prev then 17560 17561 -- Prev is a private subtype or a derived type, and needs 17562 -- no completion. 17563 17564 Error_Msg_NE ("invalid redeclaration of }", Id, Prev); 17565 New_Id := Id; 17566 17567 elsif Ekind (Prev) = E_Private_Type 17568 and then Nkind_In (N, N_Task_Type_Declaration, 17569 N_Protected_Type_Declaration) 17570 then 17571 Error_Msg_N 17572 ("completion of nonlimited type cannot be limited", N); 17573 17574 elsif Ekind (Prev) = E_Record_Type_With_Private 17575 and then Nkind_In (N, N_Task_Type_Declaration, 17576 N_Protected_Type_Declaration) 17577 then 17578 if not Is_Limited_Record (Prev) then 17579 Error_Msg_N 17580 ("completion of nonlimited type cannot be limited", N); 17581 17582 elsif No (Interface_List (N)) then 17583 Error_Msg_N 17584 ("completion of tagged private type must be tagged", 17585 N); 17586 end if; 17587 end if; 17588 17589 -- Ada 2005 (AI-251): Private extension declaration of a task 17590 -- type or a protected type. This case arises when covering 17591 -- interface types. 17592 17593 elsif Nkind_In (N, N_Task_Type_Declaration, 17594 N_Protected_Type_Declaration) 17595 then 17596 null; 17597 17598 elsif Nkind (N) /= N_Full_Type_Declaration 17599 or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition 17600 then 17601 Error_Msg_N 17602 ("full view of private extension must be an extension", N); 17603 17604 elsif not (Abstract_Present (Parent (Prev))) 17605 and then Abstract_Present (Type_Definition (N)) 17606 then 17607 Error_Msg_N 17608 ("full view of non-abstract extension cannot be abstract", N); 17609 end if; 17610 17611 if not In_Private_Part (Current_Scope) then 17612 Error_Msg_N 17613 ("declaration of full view must appear in private part", N); 17614 end if; 17615 17616 if Ada_Version >= Ada_2012 then 17617 Check_Duplicate_Aspects; 17618 end if; 17619 17620 Copy_And_Swap (Prev, Id); 17621 Set_Has_Private_Declaration (Prev); 17622 Set_Has_Private_Declaration (Id); 17623 17624 -- AI12-0133: Indicate whether we have a partial view with 17625 -- unknown discriminants, in which case initialization of objects 17626 -- of the type do not receive an invariant check. 17627 17628 Set_Partial_View_Has_Unknown_Discr 17629 (Prev, Has_Unknown_Discriminants (Id)); 17630 17631 -- Preserve aspect and iterator flags that may have been set on 17632 -- the partial view. 17633 17634 Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id)); 17635 Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id)); 17636 17637 -- If no error, propagate freeze_node from private to full view. 17638 -- It may have been generated for an early operational item. 17639 17640 if Present (Freeze_Node (Id)) 17641 and then Serious_Errors_Detected = 0 17642 and then No (Full_View (Id)) 17643 then 17644 Set_Freeze_Node (Prev, Freeze_Node (Id)); 17645 Set_Freeze_Node (Id, Empty); 17646 Set_First_Rep_Item (Prev, First_Rep_Item (Id)); 17647 end if; 17648 17649 Set_Full_View (Id, Prev); 17650 New_Id := Prev; 17651 end if; 17652 17653 -- Verify that full declaration conforms to partial one 17654 17655 if Is_Incomplete_Or_Private_Type (Prev) 17656 and then Present (Discriminant_Specifications (Prev_Par)) 17657 then 17658 if Present (Discriminant_Specifications (N)) then 17659 if Ekind (Prev) = E_Incomplete_Type then 17660 Check_Discriminant_Conformance (N, Prev, Prev); 17661 else 17662 Check_Discriminant_Conformance (N, Prev, Id); 17663 end if; 17664 17665 else 17666 Error_Msg_N 17667 ("missing discriminants in full type declaration", N); 17668 17669 -- To avoid cascaded errors on subsequent use, share the 17670 -- discriminants of the partial view. 17671 17672 Set_Discriminant_Specifications (N, 17673 Discriminant_Specifications (Prev_Par)); 17674 end if; 17675 end if; 17676 17677 -- A prior untagged partial view can have an associated class-wide 17678 -- type due to use of the class attribute, and in this case the full 17679 -- type must also be tagged. This Ada 95 usage is deprecated in favor 17680 -- of incomplete tagged declarations, but we check for it. 17681 17682 if Is_Type (Prev) 17683 and then (Is_Tagged_Type (Prev) 17684 or else Present (Class_Wide_Type (Prev))) 17685 then 17686 -- Ada 2012 (AI05-0162): A private type may be the completion of 17687 -- an incomplete type. 17688 17689 if Ada_Version >= Ada_2012 17690 and then Is_Incomplete_Type (Prev) 17691 and then Nkind_In (N, N_Private_Type_Declaration, 17692 N_Private_Extension_Declaration) 17693 then 17694 -- No need to check private extensions since they are tagged 17695 17696 if Nkind (N) = N_Private_Type_Declaration 17697 and then not Tagged_Present (N) 17698 then 17699 Tag_Mismatch; 17700 end if; 17701 17702 -- The full declaration is either a tagged type (including 17703 -- a synchronized type that implements interfaces) or a 17704 -- type extension, otherwise this is an error. 17705 17706 elsif Nkind_In (N, N_Task_Type_Declaration, 17707 N_Protected_Type_Declaration) 17708 then 17709 if No (Interface_List (N)) and then not Error_Posted (N) then 17710 Tag_Mismatch; 17711 end if; 17712 17713 elsif Nkind (Type_Definition (N)) = N_Record_Definition then 17714 17715 -- Indicate that the previous declaration (tagged incomplete 17716 -- or private declaration) requires the same on the full one. 17717 17718 if not Tagged_Present (Type_Definition (N)) then 17719 Tag_Mismatch; 17720 Set_Is_Tagged_Type (Id); 17721 end if; 17722 17723 elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 17724 if No (Record_Extension_Part (Type_Definition (N))) then 17725 Error_Msg_NE 17726 ("full declaration of } must be a record extension", 17727 Prev, Id); 17728 17729 -- Set some attributes to produce a usable full view 17730 17731 Set_Is_Tagged_Type (Id); 17732 end if; 17733 17734 else 17735 Tag_Mismatch; 17736 end if; 17737 end if; 17738 17739 if Present (Prev) 17740 and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration 17741 and then Present (Premature_Use (Parent (Prev))) 17742 then 17743 Error_Msg_Sloc := Sloc (N); 17744 Error_Msg_N 17745 ("\full declaration #", Premature_Use (Parent (Prev))); 17746 end if; 17747 17748 return New_Id; 17749 end if; 17750 end Find_Type_Name; 17751 17752 ------------------------- 17753 -- Find_Type_Of_Object -- 17754 ------------------------- 17755 17756 function Find_Type_Of_Object 17757 (Obj_Def : Node_Id; 17758 Related_Nod : Node_Id) return Entity_Id 17759 is 17760 Def_Kind : constant Node_Kind := Nkind (Obj_Def); 17761 P : Node_Id := Parent (Obj_Def); 17762 T : Entity_Id; 17763 Nam : Name_Id; 17764 17765 begin 17766 -- If the parent is a component_definition node we climb to the 17767 -- component_declaration node 17768 17769 if Nkind (P) = N_Component_Definition then 17770 P := Parent (P); 17771 end if; 17772 17773 -- Case of an anonymous array subtype 17774 17775 if Nkind_In (Def_Kind, N_Constrained_Array_Definition, 17776 N_Unconstrained_Array_Definition) 17777 then 17778 T := Empty; 17779 Array_Type_Declaration (T, Obj_Def); 17780 17781 -- Create an explicit subtype whenever possible 17782 17783 elsif Nkind (P) /= N_Component_Declaration 17784 and then Def_Kind = N_Subtype_Indication 17785 then 17786 -- Base name of subtype on object name, which will be unique in 17787 -- the current scope. 17788 17789 -- If this is a duplicate declaration, return base type, to avoid 17790 -- generating duplicate anonymous types. 17791 17792 if Error_Posted (P) then 17793 Analyze (Subtype_Mark (Obj_Def)); 17794 return Entity (Subtype_Mark (Obj_Def)); 17795 end if; 17796 17797 Nam := 17798 New_External_Name 17799 (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T'); 17800 17801 T := Make_Defining_Identifier (Sloc (P), Nam); 17802 17803 Insert_Action (Obj_Def, 17804 Make_Subtype_Declaration (Sloc (P), 17805 Defining_Identifier => T, 17806 Subtype_Indication => Relocate_Node (Obj_Def))); 17807 17808 -- This subtype may need freezing, and this will not be done 17809 -- automatically if the object declaration is not in declarative 17810 -- part. Since this is an object declaration, the type cannot always 17811 -- be frozen here. Deferred constants do not freeze their type 17812 -- (which often enough will be private). 17813 17814 if Nkind (P) = N_Object_Declaration 17815 and then Constant_Present (P) 17816 and then No (Expression (P)) 17817 then 17818 null; 17819 17820 -- Here we freeze the base type of object type to catch premature use 17821 -- of discriminated private type without a full view. 17822 17823 else 17824 Insert_Actions (Obj_Def, Freeze_Entity (Base_Type (T), P)); 17825 end if; 17826 17827 -- Ada 2005 AI-406: the object definition in an object declaration 17828 -- can be an access definition. 17829 17830 elsif Def_Kind = N_Access_Definition then 17831 T := Access_Definition (Related_Nod, Obj_Def); 17832 17833 Set_Is_Local_Anonymous_Access 17834 (T, 17835 V => (Ada_Version < Ada_2012) 17836 or else (Nkind (P) /= N_Object_Declaration) 17837 or else Is_Library_Level_Entity (Defining_Identifier (P))); 17838 17839 -- Otherwise, the object definition is just a subtype_mark 17840 17841 else 17842 T := Process_Subtype (Obj_Def, Related_Nod); 17843 17844 -- If expansion is disabled an object definition that is an aggregate 17845 -- will not get expanded and may lead to scoping problems in the back 17846 -- end, if the object is referenced in an inner scope. In that case 17847 -- create an itype reference for the object definition now. This 17848 -- may be redundant in some cases, but harmless. 17849 17850 if Is_Itype (T) 17851 and then Nkind (Related_Nod) = N_Object_Declaration 17852 and then ASIS_Mode 17853 then 17854 Build_Itype_Reference (T, Related_Nod); 17855 end if; 17856 end if; 17857 17858 return T; 17859 end Find_Type_Of_Object; 17860 17861 -------------------------------- 17862 -- Find_Type_Of_Subtype_Indic -- 17863 -------------------------------- 17864 17865 function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is 17866 Typ : Entity_Id; 17867 17868 begin 17869 -- Case of subtype mark with a constraint 17870 17871 if Nkind (S) = N_Subtype_Indication then 17872 Find_Type (Subtype_Mark (S)); 17873 Typ := Entity (Subtype_Mark (S)); 17874 17875 if not 17876 Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S))) 17877 then 17878 Error_Msg_N 17879 ("incorrect constraint for this kind of type", Constraint (S)); 17880 Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); 17881 end if; 17882 17883 -- Otherwise we have a subtype mark without a constraint 17884 17885 elsif Error_Posted (S) then 17886 Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S))); 17887 return Any_Type; 17888 17889 else 17890 Find_Type (S); 17891 Typ := Entity (S); 17892 end if; 17893 17894 -- Check No_Wide_Characters restriction 17895 17896 Check_Wide_Character_Restriction (Typ, S); 17897 17898 return Typ; 17899 end Find_Type_Of_Subtype_Indic; 17900 17901 ------------------------------------- 17902 -- Floating_Point_Type_Declaration -- 17903 ------------------------------------- 17904 17905 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is 17906 Digs : constant Node_Id := Digits_Expression (Def); 17907 Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float); 17908 Digs_Val : Uint; 17909 Base_Typ : Entity_Id; 17910 Implicit_Base : Entity_Id; 17911 17912 function Can_Derive_From (E : Entity_Id) return Boolean; 17913 -- Find if given digits value, and possibly a specified range, allows 17914 -- derivation from specified type 17915 17916 procedure Convert_Bound (B : Node_Id); 17917 -- If specified, the bounds must be static but may be of different 17918 -- types. They must be converted into machine numbers of the base type, 17919 -- in accordance with RM 4.9(38). 17920 17921 function Find_Base_Type return Entity_Id; 17922 -- Find a predefined base type that Def can derive from, or generate 17923 -- an error and substitute Long_Long_Float if none exists. 17924 17925 --------------------- 17926 -- Can_Derive_From -- 17927 --------------------- 17928 17929 function Can_Derive_From (E : Entity_Id) return Boolean is 17930 Spec : constant Entity_Id := Real_Range_Specification (Def); 17931 17932 begin 17933 -- Check specified "digits" constraint 17934 17935 if Digs_Val > Digits_Value (E) then 17936 return False; 17937 end if; 17938 17939 -- Check for matching range, if specified 17940 17941 if Present (Spec) then 17942 if Expr_Value_R (Type_Low_Bound (E)) > 17943 Expr_Value_R (Low_Bound (Spec)) 17944 then 17945 return False; 17946 end if; 17947 17948 if Expr_Value_R (Type_High_Bound (E)) < 17949 Expr_Value_R (High_Bound (Spec)) 17950 then 17951 return False; 17952 end if; 17953 end if; 17954 17955 return True; 17956 end Can_Derive_From; 17957 17958 ------------------- 17959 -- Convert_Bound -- 17960 -------------------- 17961 17962 procedure Convert_Bound (B : Node_Id) is 17963 begin 17964 -- If the bound is not a literal it can only be static if it is 17965 -- a static constant, possibly of a specified type. 17966 17967 if Is_Entity_Name (B) 17968 and then Ekind (Entity (B)) = E_Constant 17969 then 17970 Rewrite (B, Constant_Value (Entity (B))); 17971 end if; 17972 17973 if Nkind (B) = N_Real_Literal then 17974 Set_Realval (B, Machine (Base_Typ, Realval (B), Round, B)); 17975 Set_Is_Machine_Number (B); 17976 Set_Etype (B, Base_Typ); 17977 end if; 17978 end Convert_Bound; 17979 17980 -------------------- 17981 -- Find_Base_Type -- 17982 -------------------- 17983 17984 function Find_Base_Type return Entity_Id is 17985 Choice : Elmt_Id := First_Elmt (Predefined_Float_Types); 17986 17987 begin 17988 -- Iterate over the predefined types in order, returning the first 17989 -- one that Def can derive from. 17990 17991 while Present (Choice) loop 17992 if Can_Derive_From (Node (Choice)) then 17993 return Node (Choice); 17994 end if; 17995 17996 Next_Elmt (Choice); 17997 end loop; 17998 17999 -- If we can't derive from any existing type, use Long_Long_Float 18000 -- and give appropriate message explaining the problem. 18001 18002 if Digs_Val > Max_Digs_Val then 18003 -- It might be the case that there is a type with the requested 18004 -- range, just not the combination of digits and range. 18005 18006 Error_Msg_N 18007 ("no predefined type has requested range and precision", 18008 Real_Range_Specification (Def)); 18009 18010 else 18011 Error_Msg_N 18012 ("range too large for any predefined type", 18013 Real_Range_Specification (Def)); 18014 end if; 18015 18016 return Standard_Long_Long_Float; 18017 end Find_Base_Type; 18018 18019 -- Start of processing for Floating_Point_Type_Declaration 18020 18021 begin 18022 Check_Restriction (No_Floating_Point, Def); 18023 18024 -- Create an implicit base type 18025 18026 Implicit_Base := 18027 Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B'); 18028 18029 -- Analyze and verify digits value 18030 18031 Analyze_And_Resolve (Digs, Any_Integer); 18032 Check_Digits_Expression (Digs); 18033 Digs_Val := Expr_Value (Digs); 18034 18035 -- Process possible range spec and find correct type to derive from 18036 18037 Process_Real_Range_Specification (Def); 18038 18039 -- Check that requested number of digits is not too high. 18040 18041 if Digs_Val > Max_Digs_Val then 18042 18043 -- The check for Max_Base_Digits may be somewhat expensive, as it 18044 -- requires reading System, so only do it when necessary. 18045 18046 declare 18047 Max_Base_Digits : constant Uint := 18048 Expr_Value 18049 (Expression 18050 (Parent (RTE (RE_Max_Base_Digits)))); 18051 18052 begin 18053 if Digs_Val > Max_Base_Digits then 18054 Error_Msg_Uint_1 := Max_Base_Digits; 18055 Error_Msg_N ("digits value out of range, maximum is ^", Digs); 18056 18057 elsif No (Real_Range_Specification (Def)) then 18058 Error_Msg_Uint_1 := Max_Digs_Val; 18059 Error_Msg_N ("types with more than ^ digits need range spec " 18060 & "(RM 3.5.7(6))", Digs); 18061 end if; 18062 end; 18063 end if; 18064 18065 -- Find a suitable type to derive from or complain and use a substitute 18066 18067 Base_Typ := Find_Base_Type; 18068 18069 -- If there are bounds given in the declaration use them as the bounds 18070 -- of the type, otherwise use the bounds of the predefined base type 18071 -- that was chosen based on the Digits value. 18072 18073 if Present (Real_Range_Specification (Def)) then 18074 Set_Scalar_Range (T, Real_Range_Specification (Def)); 18075 Set_Is_Constrained (T); 18076 18077 Convert_Bound (Type_Low_Bound (T)); 18078 Convert_Bound (Type_High_Bound (T)); 18079 18080 else 18081 Set_Scalar_Range (T, Scalar_Range (Base_Typ)); 18082 end if; 18083 18084 -- Complete definition of implicit base and declared first subtype. The 18085 -- inheritance of the rep item chain ensures that SPARK-related pragmas 18086 -- are not clobbered when the floating point type acts as a full view of 18087 -- a private type. 18088 18089 Set_Etype (Implicit_Base, Base_Typ); 18090 Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); 18091 Set_Size_Info (Implicit_Base, Base_Typ); 18092 Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); 18093 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); 18094 Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); 18095 Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); 18096 18097 Set_Ekind (T, E_Floating_Point_Subtype); 18098 Set_Etype (T, Implicit_Base); 18099 Set_Size_Info (T, Implicit_Base); 18100 Set_RM_Size (T, RM_Size (Implicit_Base)); 18101 Inherit_Rep_Item_Chain (T, Implicit_Base); 18102 Set_Digits_Value (T, Digs_Val); 18103 end Floating_Point_Type_Declaration; 18104 18105 ---------------------------- 18106 -- Get_Discriminant_Value -- 18107 ---------------------------- 18108 18109 -- This is the situation: 18110 18111 -- There is a non-derived type 18112 18113 -- type T0 (Dx, Dy, Dz...) 18114 18115 -- There are zero or more levels of derivation, with each derivation 18116 -- either purely inheriting the discriminants, or defining its own. 18117 18118 -- type Ti is new Ti-1 18119 -- or 18120 -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y) 18121 -- or 18122 -- subtype Ti is ... 18123 18124 -- The subtype issue is avoided by the use of Original_Record_Component, 18125 -- and the fact that derived subtypes also derive the constraints. 18126 18127 -- This chain leads back from 18128 18129 -- Typ_For_Constraint 18130 18131 -- Typ_For_Constraint has discriminants, and the value for each 18132 -- discriminant is given by its corresponding Elmt of Constraints. 18133 18134 -- Discriminant is some discriminant in this hierarchy 18135 18136 -- We need to return its value 18137 18138 -- We do this by recursively searching each level, and looking for 18139 -- Discriminant. Once we get to the bottom, we start backing up 18140 -- returning the value for it which may in turn be a discriminant 18141 -- further up, so on the backup we continue the substitution. 18142 18143 function Get_Discriminant_Value 18144 (Discriminant : Entity_Id; 18145 Typ_For_Constraint : Entity_Id; 18146 Constraint : Elist_Id) return Node_Id 18147 is 18148 function Root_Corresponding_Discriminant 18149 (Discr : Entity_Id) return Entity_Id; 18150 -- Given a discriminant, traverse the chain of inherited discriminants 18151 -- and return the topmost discriminant. 18152 18153 function Search_Derivation_Levels 18154 (Ti : Entity_Id; 18155 Discrim_Values : Elist_Id; 18156 Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id; 18157 -- This is the routine that performs the recursive search of levels 18158 -- as described above. 18159 18160 ------------------------------------- 18161 -- Root_Corresponding_Discriminant -- 18162 ------------------------------------- 18163 18164 function Root_Corresponding_Discriminant 18165 (Discr : Entity_Id) return Entity_Id 18166 is 18167 D : Entity_Id; 18168 18169 begin 18170 D := Discr; 18171 while Present (Corresponding_Discriminant (D)) loop 18172 D := Corresponding_Discriminant (D); 18173 end loop; 18174 18175 return D; 18176 end Root_Corresponding_Discriminant; 18177 18178 ------------------------------ 18179 -- Search_Derivation_Levels -- 18180 ------------------------------ 18181 18182 function Search_Derivation_Levels 18183 (Ti : Entity_Id; 18184 Discrim_Values : Elist_Id; 18185 Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id 18186 is 18187 Assoc : Elmt_Id; 18188 Disc : Entity_Id; 18189 Result : Node_Or_Entity_Id; 18190 Result_Entity : Node_Id; 18191 18192 begin 18193 -- If inappropriate type, return Error, this happens only in 18194 -- cascaded error situations, and we want to avoid a blow up. 18195 18196 if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then 18197 return Error; 18198 end if; 18199 18200 -- Look deeper if possible. Use Stored_Constraints only for 18201 -- untagged types. For tagged types use the given constraint. 18202 -- This asymmetry needs explanation??? 18203 18204 if not Stored_Discrim_Values 18205 and then Present (Stored_Constraint (Ti)) 18206 and then not Is_Tagged_Type (Ti) 18207 then 18208 Result := 18209 Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True); 18210 18211 else 18212 declare 18213 Td : Entity_Id := Etype (Ti); 18214 18215 begin 18216 -- If the parent type is private, the full view may include 18217 -- renamed discriminants, and it is those stored values that 18218 -- may be needed (the partial view never has more information 18219 -- than the full view). 18220 18221 if Is_Private_Type (Td) and then Present (Full_View (Td)) then 18222 Td := Full_View (Td); 18223 end if; 18224 18225 if Td = Ti then 18226 Result := Discriminant; 18227 18228 else 18229 if Present (Stored_Constraint (Ti)) then 18230 Result := 18231 Search_Derivation_Levels 18232 (Td, Stored_Constraint (Ti), True); 18233 else 18234 Result := 18235 Search_Derivation_Levels 18236 (Td, Discrim_Values, Stored_Discrim_Values); 18237 end if; 18238 end if; 18239 end; 18240 end if; 18241 18242 -- Extra underlying places to search, if not found above. For 18243 -- concurrent types, the relevant discriminant appears in the 18244 -- corresponding record. For a type derived from a private type 18245 -- without discriminant, the full view inherits the discriminants 18246 -- of the full view of the parent. 18247 18248 if Result = Discriminant then 18249 if Is_Concurrent_Type (Ti) 18250 and then Present (Corresponding_Record_Type (Ti)) 18251 then 18252 Result := 18253 Search_Derivation_Levels ( 18254 Corresponding_Record_Type (Ti), 18255 Discrim_Values, 18256 Stored_Discrim_Values); 18257 18258 elsif Is_Private_Type (Ti) 18259 and then not Has_Discriminants (Ti) 18260 and then Present (Full_View (Ti)) 18261 and then Etype (Full_View (Ti)) /= Ti 18262 then 18263 Result := 18264 Search_Derivation_Levels ( 18265 Full_View (Ti), 18266 Discrim_Values, 18267 Stored_Discrim_Values); 18268 end if; 18269 end if; 18270 18271 -- If Result is not a (reference to a) discriminant, return it, 18272 -- otherwise set Result_Entity to the discriminant. 18273 18274 if Nkind (Result) = N_Defining_Identifier then 18275 pragma Assert (Result = Discriminant); 18276 Result_Entity := Result; 18277 18278 else 18279 if not Denotes_Discriminant (Result) then 18280 return Result; 18281 end if; 18282 18283 Result_Entity := Entity (Result); 18284 end if; 18285 18286 -- See if this level of derivation actually has discriminants because 18287 -- tagged derivations can add them, hence the lower levels need not 18288 -- have any. 18289 18290 if not Has_Discriminants (Ti) then 18291 return Result; 18292 end if; 18293 18294 -- Scan Ti's discriminants for Result_Entity, and return its 18295 -- corresponding value, if any. 18296 18297 Result_Entity := Original_Record_Component (Result_Entity); 18298 18299 Assoc := First_Elmt (Discrim_Values); 18300 18301 if Stored_Discrim_Values then 18302 Disc := First_Stored_Discriminant (Ti); 18303 else 18304 Disc := First_Discriminant (Ti); 18305 end if; 18306 18307 while Present (Disc) loop 18308 18309 -- If no further associations return the discriminant, value will 18310 -- be found on the second pass. 18311 18312 if No (Assoc) then 18313 return Result; 18314 end if; 18315 18316 if Original_Record_Component (Disc) = Result_Entity then 18317 return Node (Assoc); 18318 end if; 18319 18320 Next_Elmt (Assoc); 18321 18322 if Stored_Discrim_Values then 18323 Next_Stored_Discriminant (Disc); 18324 else 18325 Next_Discriminant (Disc); 18326 end if; 18327 end loop; 18328 18329 -- Could not find it 18330 18331 return Result; 18332 end Search_Derivation_Levels; 18333 18334 -- Local Variables 18335 18336 Result : Node_Or_Entity_Id; 18337 18338 -- Start of processing for Get_Discriminant_Value 18339 18340 begin 18341 -- ??? This routine is a gigantic mess and will be deleted. For the 18342 -- time being just test for the trivial case before calling recurse. 18343 18344 -- We are now celebrating the 20th anniversary of this comment! 18345 18346 if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then 18347 declare 18348 D : Entity_Id; 18349 E : Elmt_Id; 18350 18351 begin 18352 D := First_Discriminant (Typ_For_Constraint); 18353 E := First_Elmt (Constraint); 18354 while Present (D) loop 18355 if Chars (D) = Chars (Discriminant) then 18356 return Node (E); 18357 end if; 18358 18359 Next_Discriminant (D); 18360 Next_Elmt (E); 18361 end loop; 18362 end; 18363 end if; 18364 18365 Result := Search_Derivation_Levels 18366 (Typ_For_Constraint, Constraint, False); 18367 18368 -- ??? hack to disappear when this routine is gone 18369 18370 if Nkind (Result) = N_Defining_Identifier then 18371 declare 18372 D : Entity_Id; 18373 E : Elmt_Id; 18374 18375 begin 18376 D := First_Discriminant (Typ_For_Constraint); 18377 E := First_Elmt (Constraint); 18378 while Present (D) loop 18379 if Root_Corresponding_Discriminant (D) = Discriminant then 18380 return Node (E); 18381 end if; 18382 18383 Next_Discriminant (D); 18384 Next_Elmt (E); 18385 end loop; 18386 end; 18387 end if; 18388 18389 pragma Assert (Nkind (Result) /= N_Defining_Identifier); 18390 return Result; 18391 end Get_Discriminant_Value; 18392 18393 -------------------------- 18394 -- Has_Range_Constraint -- 18395 -------------------------- 18396 18397 function Has_Range_Constraint (N : Node_Id) return Boolean is 18398 C : constant Node_Id := Constraint (N); 18399 18400 begin 18401 if Nkind (C) = N_Range_Constraint then 18402 return True; 18403 18404 elsif Nkind (C) = N_Digits_Constraint then 18405 return 18406 Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N))) 18407 or else Present (Range_Constraint (C)); 18408 18409 elsif Nkind (C) = N_Delta_Constraint then 18410 return Present (Range_Constraint (C)); 18411 18412 else 18413 return False; 18414 end if; 18415 end Has_Range_Constraint; 18416 18417 ------------------------ 18418 -- Inherit_Components -- 18419 ------------------------ 18420 18421 function Inherit_Components 18422 (N : Node_Id; 18423 Parent_Base : Entity_Id; 18424 Derived_Base : Entity_Id; 18425 Is_Tagged : Boolean; 18426 Inherit_Discr : Boolean; 18427 Discs : Elist_Id) return Elist_Id 18428 is 18429 Assoc_List : constant Elist_Id := New_Elmt_List; 18430 18431 procedure Inherit_Component 18432 (Old_C : Entity_Id; 18433 Plain_Discrim : Boolean := False; 18434 Stored_Discrim : Boolean := False); 18435 -- Inherits component Old_C from Parent_Base to the Derived_Base. If 18436 -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is 18437 -- True, Old_C is a stored discriminant. If they are both false then 18438 -- Old_C is a regular component. 18439 18440 ----------------------- 18441 -- Inherit_Component -- 18442 ----------------------- 18443 18444 procedure Inherit_Component 18445 (Old_C : Entity_Id; 18446 Plain_Discrim : Boolean := False; 18447 Stored_Discrim : Boolean := False) 18448 is 18449 procedure Set_Anonymous_Type (Id : Entity_Id); 18450 -- Id denotes the entity of an access discriminant or anonymous 18451 -- access component. Set the type of Id to either the same type of 18452 -- Old_C or create a new one depending on whether the parent and 18453 -- the child types are in the same scope. 18454 18455 ------------------------ 18456 -- Set_Anonymous_Type -- 18457 ------------------------ 18458 18459 procedure Set_Anonymous_Type (Id : Entity_Id) is 18460 Old_Typ : constant Entity_Id := Etype (Old_C); 18461 18462 begin 18463 if Scope (Parent_Base) = Scope (Derived_Base) then 18464 Set_Etype (Id, Old_Typ); 18465 18466 -- The parent and the derived type are in two different scopes. 18467 -- Reuse the type of the original discriminant / component by 18468 -- copying it in order to preserve all attributes. 18469 18470 else 18471 declare 18472 Typ : constant Entity_Id := New_Copy (Old_Typ); 18473 18474 begin 18475 Set_Etype (Id, Typ); 18476 18477 -- Since we do not generate component declarations for 18478 -- inherited components, associate the itype with the 18479 -- derived type. 18480 18481 Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base)); 18482 Set_Scope (Typ, Derived_Base); 18483 end; 18484 end if; 18485 end Set_Anonymous_Type; 18486 18487 -- Local variables and constants 18488 18489 New_C : constant Entity_Id := New_Copy (Old_C); 18490 18491 Corr_Discrim : Entity_Id; 18492 Discrim : Entity_Id; 18493 18494 -- Start of processing for Inherit_Component 18495 18496 begin 18497 pragma Assert (not Is_Tagged or not Stored_Discrim); 18498 18499 Set_Parent (New_C, Parent (Old_C)); 18500 18501 -- Regular discriminants and components must be inserted in the scope 18502 -- of the Derived_Base. Do it here. 18503 18504 if not Stored_Discrim then 18505 Enter_Name (New_C); 18506 end if; 18507 18508 -- For tagged types the Original_Record_Component must point to 18509 -- whatever this field was pointing to in the parent type. This has 18510 -- already been achieved by the call to New_Copy above. 18511 18512 if not Is_Tagged then 18513 Set_Original_Record_Component (New_C, New_C); 18514 Set_Corresponding_Record_Component (New_C, Old_C); 18515 end if; 18516 18517 -- Set the proper type of an access discriminant 18518 18519 if Ekind (New_C) = E_Discriminant 18520 and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type 18521 then 18522 Set_Anonymous_Type (New_C); 18523 end if; 18524 18525 -- If we have inherited a component then see if its Etype contains 18526 -- references to Parent_Base discriminants. In this case, replace 18527 -- these references with the constraints given in Discs. We do not 18528 -- do this for the partial view of private types because this is 18529 -- not needed (only the components of the full view will be used 18530 -- for code generation) and cause problem. We also avoid this 18531 -- transformation in some error situations. 18532 18533 if Ekind (New_C) = E_Component then 18534 18535 -- Set the proper type of an anonymous access component 18536 18537 if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then 18538 Set_Anonymous_Type (New_C); 18539 18540 elsif (Is_Private_Type (Derived_Base) 18541 and then not Is_Generic_Type (Derived_Base)) 18542 or else (Is_Empty_Elmt_List (Discs) 18543 and then not Expander_Active) 18544 then 18545 Set_Etype (New_C, Etype (Old_C)); 18546 18547 else 18548 -- The current component introduces a circularity of the 18549 -- following kind: 18550 18551 -- limited with Pack_2; 18552 -- package Pack_1 is 18553 -- type T_1 is tagged record 18554 -- Comp : access Pack_2.T_2; 18555 -- ... 18556 -- end record; 18557 -- end Pack_1; 18558 18559 -- with Pack_1; 18560 -- package Pack_2 is 18561 -- type T_2 is new Pack_1.T_1 with ...; 18562 -- end Pack_2; 18563 18564 Set_Etype 18565 (New_C, 18566 Constrain_Component_Type 18567 (Old_C, Derived_Base, N, Parent_Base, Discs)); 18568 end if; 18569 end if; 18570 18571 -- In derived tagged types it is illegal to reference a non 18572 -- discriminant component in the parent type. To catch this, mark 18573 -- these components with an Ekind of E_Void. This will be reset in 18574 -- Record_Type_Definition after processing the record extension of 18575 -- the derived type. 18576 18577 -- If the declaration is a private extension, there is no further 18578 -- record extension to process, and the components retain their 18579 -- current kind, because they are visible at this point. 18580 18581 if Is_Tagged and then Ekind (New_C) = E_Component 18582 and then Nkind (N) /= N_Private_Extension_Declaration 18583 then 18584 Set_Ekind (New_C, E_Void); 18585 end if; 18586 18587 if Plain_Discrim then 18588 Set_Corresponding_Discriminant (New_C, Old_C); 18589 Build_Discriminal (New_C); 18590 18591 -- If we are explicitly inheriting a stored discriminant it will be 18592 -- completely hidden. 18593 18594 elsif Stored_Discrim then 18595 Set_Corresponding_Discriminant (New_C, Empty); 18596 Set_Discriminal (New_C, Empty); 18597 Set_Is_Completely_Hidden (New_C); 18598 18599 -- Set the Original_Record_Component of each discriminant in the 18600 -- derived base to point to the corresponding stored that we just 18601 -- created. 18602 18603 Discrim := First_Discriminant (Derived_Base); 18604 while Present (Discrim) loop 18605 Corr_Discrim := Corresponding_Discriminant (Discrim); 18606 18607 -- Corr_Discrim could be missing in an error situation 18608 18609 if Present (Corr_Discrim) 18610 and then Original_Record_Component (Corr_Discrim) = Old_C 18611 then 18612 Set_Original_Record_Component (Discrim, New_C); 18613 Set_Corresponding_Record_Component (Discrim, Empty); 18614 end if; 18615 18616 Next_Discriminant (Discrim); 18617 end loop; 18618 18619 Append_Entity (New_C, Derived_Base); 18620 end if; 18621 18622 if not Is_Tagged then 18623 Append_Elmt (Old_C, Assoc_List); 18624 Append_Elmt (New_C, Assoc_List); 18625 end if; 18626 end Inherit_Component; 18627 18628 -- Variables local to Inherit_Component 18629 18630 Loc : constant Source_Ptr := Sloc (N); 18631 18632 Parent_Discrim : Entity_Id; 18633 Stored_Discrim : Entity_Id; 18634 D : Entity_Id; 18635 Component : Entity_Id; 18636 18637 -- Start of processing for Inherit_Components 18638 18639 begin 18640 if not Is_Tagged then 18641 Append_Elmt (Parent_Base, Assoc_List); 18642 Append_Elmt (Derived_Base, Assoc_List); 18643 end if; 18644 18645 -- Inherit parent discriminants if needed 18646 18647 if Inherit_Discr then 18648 Parent_Discrim := First_Discriminant (Parent_Base); 18649 while Present (Parent_Discrim) loop 18650 Inherit_Component (Parent_Discrim, Plain_Discrim => True); 18651 Next_Discriminant (Parent_Discrim); 18652 end loop; 18653 end if; 18654 18655 -- Create explicit stored discrims for untagged types when necessary 18656 18657 if not Has_Unknown_Discriminants (Derived_Base) 18658 and then Has_Discriminants (Parent_Base) 18659 and then not Is_Tagged 18660 and then 18661 (not Inherit_Discr 18662 or else First_Discriminant (Parent_Base) /= 18663 First_Stored_Discriminant (Parent_Base)) 18664 then 18665 Stored_Discrim := First_Stored_Discriminant (Parent_Base); 18666 while Present (Stored_Discrim) loop 18667 Inherit_Component (Stored_Discrim, Stored_Discrim => True); 18668 Next_Stored_Discriminant (Stored_Discrim); 18669 end loop; 18670 end if; 18671 18672 -- See if we can apply the second transformation for derived types, as 18673 -- explained in point 6. in the comments above Build_Derived_Record_Type 18674 -- This is achieved by appending Derived_Base discriminants into Discs, 18675 -- which has the side effect of returning a non empty Discs list to the 18676 -- caller of Inherit_Components, which is what we want. This must be 18677 -- done for private derived types if there are explicit stored 18678 -- discriminants, to ensure that we can retrieve the values of the 18679 -- constraints provided in the ancestors. 18680 18681 if Inherit_Discr 18682 and then Is_Empty_Elmt_List (Discs) 18683 and then Present (First_Discriminant (Derived_Base)) 18684 and then 18685 (not Is_Private_Type (Derived_Base) 18686 or else Is_Completely_Hidden 18687 (First_Stored_Discriminant (Derived_Base)) 18688 or else Is_Generic_Type (Derived_Base)) 18689 then 18690 D := First_Discriminant (Derived_Base); 18691 while Present (D) loop 18692 Append_Elmt (New_Occurrence_Of (D, Loc), Discs); 18693 Next_Discriminant (D); 18694 end loop; 18695 end if; 18696 18697 -- Finally, inherit non-discriminant components unless they are not 18698 -- visible because defined or inherited from the full view of the 18699 -- parent. Don't inherit the _parent field of the parent type. 18700 18701 Component := First_Entity (Parent_Base); 18702 while Present (Component) loop 18703 18704 -- Ada 2005 (AI-251): Do not inherit components associated with 18705 -- secondary tags of the parent. 18706 18707 if Ekind (Component) = E_Component 18708 and then Present (Related_Type (Component)) 18709 then 18710 null; 18711 18712 elsif Ekind (Component) /= E_Component 18713 or else Chars (Component) = Name_uParent 18714 then 18715 null; 18716 18717 -- If the derived type is within the parent type's declarative 18718 -- region, then the components can still be inherited even though 18719 -- they aren't visible at this point. This can occur for cases 18720 -- such as within public child units where the components must 18721 -- become visible upon entering the child unit's private part. 18722 18723 elsif not Is_Visible_Component (Component) 18724 and then not In_Open_Scopes (Scope (Parent_Base)) 18725 then 18726 null; 18727 18728 elsif Ekind_In (Derived_Base, E_Private_Type, 18729 E_Limited_Private_Type) 18730 then 18731 null; 18732 18733 else 18734 Inherit_Component (Component); 18735 end if; 18736 18737 Next_Entity (Component); 18738 end loop; 18739 18740 -- For tagged derived types, inherited discriminants cannot be used in 18741 -- component declarations of the record extension part. To achieve this 18742 -- we mark the inherited discriminants as not visible. 18743 18744 if Is_Tagged and then Inherit_Discr then 18745 D := First_Discriminant (Derived_Base); 18746 while Present (D) loop 18747 Set_Is_Immediately_Visible (D, False); 18748 Next_Discriminant (D); 18749 end loop; 18750 end if; 18751 18752 return Assoc_List; 18753 end Inherit_Components; 18754 18755 ----------------------------- 18756 -- Inherit_Predicate_Flags -- 18757 ----------------------------- 18758 18759 procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is 18760 begin 18761 if Present (Predicate_Function (Subt)) then 18762 return; 18763 end if; 18764 18765 Set_Has_Predicates (Subt, Has_Predicates (Par)); 18766 Set_Has_Static_Predicate_Aspect 18767 (Subt, Has_Static_Predicate_Aspect (Par)); 18768 Set_Has_Dynamic_Predicate_Aspect 18769 (Subt, Has_Dynamic_Predicate_Aspect (Par)); 18770 18771 -- A named subtype does not inherit the predicate function of its 18772 -- parent but an itype declared for a loop index needs the discrete 18773 -- predicate information of its parent to execute the loop properly. 18774 -- A non-discrete type may has a static predicate (for example True) 18775 -- but has no static_discrete_predicate. 18776 18777 if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then 18778 Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par)); 18779 18780 if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then 18781 Set_Static_Discrete_Predicate 18782 (Subt, Static_Discrete_Predicate (Par)); 18783 end if; 18784 end if; 18785 end Inherit_Predicate_Flags; 18786 18787 ---------------------- 18788 -- Is_EVF_Procedure -- 18789 ---------------------- 18790 18791 function Is_EVF_Procedure (Subp : Entity_Id) return Boolean is 18792 Formal : Entity_Id; 18793 18794 begin 18795 -- Examine the formals of an Extensions_Visible False procedure looking 18796 -- for a controlling OUT parameter. 18797 18798 if Ekind (Subp) = E_Procedure 18799 and then Extensions_Visible_Status (Subp) = Extensions_Visible_False 18800 then 18801 Formal := First_Formal (Subp); 18802 while Present (Formal) loop 18803 if Ekind (Formal) = E_Out_Parameter 18804 and then Is_Controlling_Formal (Formal) 18805 then 18806 return True; 18807 end if; 18808 18809 Next_Formal (Formal); 18810 end loop; 18811 end if; 18812 18813 return False; 18814 end Is_EVF_Procedure; 18815 18816 ----------------------- 18817 -- Is_Null_Extension -- 18818 ----------------------- 18819 18820 function Is_Null_Extension (T : Entity_Id) return Boolean is 18821 Type_Decl : constant Node_Id := Parent (Base_Type (T)); 18822 Comp_List : Node_Id; 18823 Comp : Node_Id; 18824 18825 begin 18826 if Nkind (Type_Decl) /= N_Full_Type_Declaration 18827 or else not Is_Tagged_Type (T) 18828 or else Nkind (Type_Definition (Type_Decl)) /= 18829 N_Derived_Type_Definition 18830 or else No (Record_Extension_Part (Type_Definition (Type_Decl))) 18831 then 18832 return False; 18833 end if; 18834 18835 Comp_List := 18836 Component_List (Record_Extension_Part (Type_Definition (Type_Decl))); 18837 18838 if Present (Discriminant_Specifications (Type_Decl)) then 18839 return False; 18840 18841 elsif Present (Comp_List) 18842 and then Is_Non_Empty_List (Component_Items (Comp_List)) 18843 then 18844 Comp := First (Component_Items (Comp_List)); 18845 18846 -- Only user-defined components are relevant. The component list 18847 -- may also contain a parent component and internal components 18848 -- corresponding to secondary tags, but these do not determine 18849 -- whether this is a null extension. 18850 18851 while Present (Comp) loop 18852 if Comes_From_Source (Comp) then 18853 return False; 18854 end if; 18855 18856 Next (Comp); 18857 end loop; 18858 18859 return True; 18860 18861 else 18862 return True; 18863 end if; 18864 end Is_Null_Extension; 18865 18866 ------------------------------ 18867 -- Is_Valid_Constraint_Kind -- 18868 ------------------------------ 18869 18870 function Is_Valid_Constraint_Kind 18871 (T_Kind : Type_Kind; 18872 Constraint_Kind : Node_Kind) return Boolean 18873 is 18874 begin 18875 case T_Kind is 18876 when Enumeration_Kind 18877 | Integer_Kind 18878 => 18879 return Constraint_Kind = N_Range_Constraint; 18880 18881 when Decimal_Fixed_Point_Kind => 18882 return Nkind_In (Constraint_Kind, N_Digits_Constraint, 18883 N_Range_Constraint); 18884 18885 when Ordinary_Fixed_Point_Kind => 18886 return Nkind_In (Constraint_Kind, N_Delta_Constraint, 18887 N_Range_Constraint); 18888 18889 when Float_Kind => 18890 return Nkind_In (Constraint_Kind, N_Digits_Constraint, 18891 N_Range_Constraint); 18892 18893 when Access_Kind 18894 | Array_Kind 18895 | Class_Wide_Kind 18896 | Concurrent_Kind 18897 | Private_Kind 18898 | E_Incomplete_Type 18899 | E_Record_Subtype 18900 | E_Record_Type 18901 => 18902 return Constraint_Kind = N_Index_Or_Discriminant_Constraint; 18903 18904 when others => 18905 return True; -- Error will be detected later 18906 end case; 18907 end Is_Valid_Constraint_Kind; 18908 18909 -------------------------- 18910 -- Is_Visible_Component -- 18911 -------------------------- 18912 18913 function Is_Visible_Component 18914 (C : Entity_Id; 18915 N : Node_Id := Empty) return Boolean 18916 is 18917 Original_Comp : Entity_Id := Empty; 18918 Original_Type : Entity_Id; 18919 Type_Scope : Entity_Id; 18920 18921 function Is_Local_Type (Typ : Entity_Id) return Boolean; 18922 -- Check whether parent type of inherited component is declared locally, 18923 -- possibly within a nested package or instance. The current scope is 18924 -- the derived record itself. 18925 18926 ------------------- 18927 -- Is_Local_Type -- 18928 ------------------- 18929 18930 function Is_Local_Type (Typ : Entity_Id) return Boolean is 18931 Scop : Entity_Id; 18932 18933 begin 18934 Scop := Scope (Typ); 18935 while Present (Scop) 18936 and then Scop /= Standard_Standard 18937 loop 18938 if Scop = Scope (Current_Scope) then 18939 return True; 18940 end if; 18941 18942 Scop := Scope (Scop); 18943 end loop; 18944 18945 return False; 18946 end Is_Local_Type; 18947 18948 -- Start of processing for Is_Visible_Component 18949 18950 begin 18951 if Ekind_In (C, E_Component, E_Discriminant) then 18952 Original_Comp := Original_Record_Component (C); 18953 end if; 18954 18955 if No (Original_Comp) then 18956 18957 -- Premature usage, or previous error 18958 18959 return False; 18960 18961 else 18962 Original_Type := Scope (Original_Comp); 18963 Type_Scope := Scope (Base_Type (Scope (C))); 18964 end if; 18965 18966 -- This test only concerns tagged types 18967 18968 if not Is_Tagged_Type (Original_Type) then 18969 18970 -- Check if this is a renamed discriminant (hidden either by the 18971 -- derived type or by some ancestor), unless we are analyzing code 18972 -- generated by the expander since it may reference such components 18973 -- (for example see the expansion of Deep_Adjust). 18974 18975 if Ekind (C) = E_Discriminant and then Present (N) then 18976 return 18977 not Comes_From_Source (N) 18978 or else not Is_Completely_Hidden (C); 18979 else 18980 return True; 18981 end if; 18982 18983 -- If it is _Parent or _Tag, there is no visibility issue 18984 18985 elsif not Comes_From_Source (Original_Comp) then 18986 return True; 18987 18988 -- Discriminants are visible unless the (private) type has unknown 18989 -- discriminants. If the discriminant reference is inserted for a 18990 -- discriminant check on a full view it is also visible. 18991 18992 elsif Ekind (Original_Comp) = E_Discriminant 18993 and then 18994 (not Has_Unknown_Discriminants (Original_Type) 18995 or else (Present (N) 18996 and then Nkind (N) = N_Selected_Component 18997 and then Nkind (Prefix (N)) = N_Type_Conversion 18998 and then not Comes_From_Source (Prefix (N)))) 18999 then 19000 return True; 19001 19002 -- In the body of an instantiation, check the visibility of a component 19003 -- in case it has a homograph that is a primitive operation of a private 19004 -- type which was not visible in the generic unit. 19005 19006 -- Should Is_Prefixed_Call be propagated from template to instance??? 19007 19008 elsif In_Instance_Body then 19009 if not Is_Tagged_Type (Original_Type) 19010 or else not Is_Private_Type (Original_Type) 19011 then 19012 return True; 19013 19014 else 19015 declare 19016 Subp_Elmt : Elmt_Id; 19017 19018 begin 19019 Subp_Elmt := First_Elmt (Primitive_Operations (Original_Type)); 19020 while Present (Subp_Elmt) loop 19021 19022 -- The component is hidden by a primitive operation 19023 19024 if Chars (Node (Subp_Elmt)) = Chars (C) then 19025 return False; 19026 end if; 19027 19028 Next_Elmt (Subp_Elmt); 19029 end loop; 19030 19031 return True; 19032 end; 19033 end if; 19034 19035 -- If the component has been declared in an ancestor which is currently 19036 -- a private type, then it is not visible. The same applies if the 19037 -- component's containing type is not in an open scope and the original 19038 -- component's enclosing type is a visible full view of a private type 19039 -- (which can occur in cases where an attempt is being made to reference 19040 -- a component in a sibling package that is inherited from a visible 19041 -- component of a type in an ancestor package; the component in the 19042 -- sibling package should not be visible even though the component it 19043 -- inherited from is visible). This does not apply however in the case 19044 -- where the scope of the type is a private child unit, or when the 19045 -- parent comes from a local package in which the ancestor is currently 19046 -- visible. The latter suppression of visibility is needed for cases 19047 -- that are tested in B730006. 19048 19049 elsif Is_Private_Type (Original_Type) 19050 or else 19051 (not Is_Private_Descendant (Type_Scope) 19052 and then not In_Open_Scopes (Type_Scope) 19053 and then Has_Private_Declaration (Original_Type)) 19054 then 19055 -- If the type derives from an entity in a formal package, there 19056 -- are no additional visible components. 19057 19058 if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) = 19059 N_Formal_Package_Declaration 19060 then 19061 return False; 19062 19063 -- if we are not in the private part of the current package, there 19064 -- are no additional visible components. 19065 19066 elsif Ekind (Scope (Current_Scope)) = E_Package 19067 and then not In_Private_Part (Scope (Current_Scope)) 19068 then 19069 return False; 19070 else 19071 return 19072 Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) 19073 and then In_Open_Scopes (Scope (Original_Type)) 19074 and then Is_Local_Type (Type_Scope); 19075 end if; 19076 19077 -- There is another weird way in which a component may be invisible when 19078 -- the private and the full view are not derived from the same ancestor. 19079 -- Here is an example : 19080 19081 -- type A1 is tagged record F1 : integer; end record; 19082 -- type A2 is new A1 with record F2 : integer; end record; 19083 -- type T is new A1 with private; 19084 -- private 19085 -- type T is new A2 with null record; 19086 19087 -- In this case, the full view of T inherits F1 and F2 but the private 19088 -- view inherits only F1 19089 19090 else 19091 declare 19092 Ancestor : Entity_Id := Scope (C); 19093 19094 begin 19095 loop 19096 if Ancestor = Original_Type then 19097 return True; 19098 19099 -- The ancestor may have a partial view of the original type, 19100 -- but if the full view is in scope, as in a child body, the 19101 -- component is visible. 19102 19103 elsif In_Private_Part (Scope (Original_Type)) 19104 and then Full_View (Ancestor) = Original_Type 19105 then 19106 return True; 19107 19108 elsif Ancestor = Etype (Ancestor) then 19109 19110 -- No further ancestors to examine 19111 19112 return False; 19113 end if; 19114 19115 Ancestor := Etype (Ancestor); 19116 end loop; 19117 end; 19118 end if; 19119 end Is_Visible_Component; 19120 19121 -------------------------- 19122 -- Make_Class_Wide_Type -- 19123 -------------------------- 19124 19125 procedure Make_Class_Wide_Type (T : Entity_Id) is 19126 CW_Type : Entity_Id; 19127 CW_Name : Name_Id; 19128 Next_E : Entity_Id; 19129 Prev_E : Entity_Id; 19130 19131 begin 19132 if Present (Class_Wide_Type (T)) then 19133 19134 -- The class-wide type is a partially decorated entity created for a 19135 -- unanalyzed tagged type referenced through a limited with clause. 19136 -- When the tagged type is analyzed, its class-wide type needs to be 19137 -- redecorated. Note that we reuse the entity created by Decorate_ 19138 -- Tagged_Type in order to preserve all links. 19139 19140 if Materialize_Entity (Class_Wide_Type (T)) then 19141 CW_Type := Class_Wide_Type (T); 19142 Set_Materialize_Entity (CW_Type, False); 19143 19144 -- The class wide type can have been defined by the partial view, in 19145 -- which case everything is already done. 19146 19147 else 19148 return; 19149 end if; 19150 19151 -- Default case, we need to create a new class-wide type 19152 19153 else 19154 CW_Type := 19155 New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T'); 19156 end if; 19157 19158 -- Inherit root type characteristics 19159 19160 CW_Name := Chars (CW_Type); 19161 Next_E := Next_Entity (CW_Type); 19162 Prev_E := Prev_Entity (CW_Type); 19163 Copy_Node (T, CW_Type); 19164 Set_Comes_From_Source (CW_Type, False); 19165 Set_Chars (CW_Type, CW_Name); 19166 Set_Parent (CW_Type, Parent (T)); 19167 Set_Prev_Entity (CW_Type, Prev_E); 19168 Set_Next_Entity (CW_Type, Next_E); 19169 19170 -- Ensure we have a new freeze node for the class-wide type. The partial 19171 -- view may have freeze action of its own, requiring a proper freeze 19172 -- node, and the same freeze node cannot be shared between the two 19173 -- types. 19174 19175 Set_Has_Delayed_Freeze (CW_Type); 19176 Set_Freeze_Node (CW_Type, Empty); 19177 19178 -- Customize the class-wide type: It has no prim. op., it cannot be 19179 -- abstract, its Etype points back to the specific root type, and it 19180 -- cannot have any invariants. 19181 19182 Set_Ekind (CW_Type, E_Class_Wide_Type); 19183 Set_Is_Tagged_Type (CW_Type, True); 19184 Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); 19185 Set_Is_Abstract_Type (CW_Type, False); 19186 Set_Is_Constrained (CW_Type, False); 19187 Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); 19188 Set_Default_SSO (CW_Type); 19189 Set_Has_Inheritable_Invariants (CW_Type, False); 19190 Set_Has_Inherited_Invariants (CW_Type, False); 19191 Set_Has_Own_Invariants (CW_Type, False); 19192 19193 if Ekind (T) = E_Class_Wide_Subtype then 19194 Set_Etype (CW_Type, Etype (Base_Type (T))); 19195 else 19196 Set_Etype (CW_Type, T); 19197 end if; 19198 19199 Set_No_Tagged_Streams_Pragma (CW_Type, No_Tagged_Streams); 19200 19201 -- If this is the class_wide type of a constrained subtype, it does 19202 -- not have discriminants. 19203 19204 Set_Has_Discriminants (CW_Type, 19205 Has_Discriminants (T) and then not Is_Constrained (T)); 19206 19207 Set_Has_Unknown_Discriminants (CW_Type, True); 19208 Set_Class_Wide_Type (T, CW_Type); 19209 Set_Equivalent_Type (CW_Type, Empty); 19210 19211 -- The class-wide type of a class-wide type is itself (RM 3.9(14)) 19212 19213 Set_Class_Wide_Type (CW_Type, CW_Type); 19214 end Make_Class_Wide_Type; 19215 19216 ---------------- 19217 -- Make_Index -- 19218 ---------------- 19219 19220 procedure Make_Index 19221 (N : Node_Id; 19222 Related_Nod : Node_Id; 19223 Related_Id : Entity_Id := Empty; 19224 Suffix_Index : Nat := 1; 19225 In_Iter_Schm : Boolean := False) 19226 is 19227 R : Node_Id; 19228 T : Entity_Id; 19229 Def_Id : Entity_Id := Empty; 19230 Found : Boolean := False; 19231 19232 begin 19233 -- For a discrete range used in a constrained array definition and 19234 -- defined by a range, an implicit conversion to the predefined type 19235 -- INTEGER is assumed if each bound is either a numeric literal, a named 19236 -- number, or an attribute, and the type of both bounds (prior to the 19237 -- implicit conversion) is the type universal_integer. Otherwise, both 19238 -- bounds must be of the same discrete type, other than universal 19239 -- integer; this type must be determinable independently of the 19240 -- context, but using the fact that the type must be discrete and that 19241 -- both bounds must have the same type. 19242 19243 -- Character literals also have a universal type in the absence of 19244 -- of additional context, and are resolved to Standard_Character. 19245 19246 if Nkind (N) = N_Range then 19247 19248 -- The index is given by a range constraint. The bounds are known 19249 -- to be of a consistent type. 19250 19251 if not Is_Overloaded (N) then 19252 T := Etype (N); 19253 19254 -- For universal bounds, choose the specific predefined type 19255 19256 if T = Universal_Integer then 19257 T := Standard_Integer; 19258 19259 elsif T = Any_Character then 19260 Ambiguous_Character (Low_Bound (N)); 19261 19262 T := Standard_Character; 19263 end if; 19264 19265 -- The node may be overloaded because some user-defined operators 19266 -- are available, but if a universal interpretation exists it is 19267 -- also the selected one. 19268 19269 elsif Universal_Interpretation (N) = Universal_Integer then 19270 T := Standard_Integer; 19271 19272 else 19273 T := Any_Type; 19274 19275 declare 19276 Ind : Interp_Index; 19277 It : Interp; 19278 19279 begin 19280 Get_First_Interp (N, Ind, It); 19281 while Present (It.Typ) loop 19282 if Is_Discrete_Type (It.Typ) then 19283 19284 if Found 19285 and then not Covers (It.Typ, T) 19286 and then not Covers (T, It.Typ) 19287 then 19288 Error_Msg_N ("ambiguous bounds in discrete range", N); 19289 exit; 19290 else 19291 T := It.Typ; 19292 Found := True; 19293 end if; 19294 end if; 19295 19296 Get_Next_Interp (Ind, It); 19297 end loop; 19298 19299 if T = Any_Type then 19300 Error_Msg_N ("discrete type required for range", N); 19301 Set_Etype (N, Any_Type); 19302 return; 19303 19304 elsif T = Universal_Integer then 19305 T := Standard_Integer; 19306 end if; 19307 end; 19308 end if; 19309 19310 if not Is_Discrete_Type (T) then 19311 Error_Msg_N ("discrete type required for range", N); 19312 Set_Etype (N, Any_Type); 19313 return; 19314 end if; 19315 19316 if Nkind (Low_Bound (N)) = N_Attribute_Reference 19317 and then Attribute_Name (Low_Bound (N)) = Name_First 19318 and then Is_Entity_Name (Prefix (Low_Bound (N))) 19319 and then Is_Type (Entity (Prefix (Low_Bound (N)))) 19320 and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N)))) 19321 then 19322 -- The type of the index will be the type of the prefix, as long 19323 -- as the upper bound is 'Last of the same type. 19324 19325 Def_Id := Entity (Prefix (Low_Bound (N))); 19326 19327 if Nkind (High_Bound (N)) /= N_Attribute_Reference 19328 or else Attribute_Name (High_Bound (N)) /= Name_Last 19329 or else not Is_Entity_Name (Prefix (High_Bound (N))) 19330 or else Entity (Prefix (High_Bound (N))) /= Def_Id 19331 then 19332 Def_Id := Empty; 19333 end if; 19334 end if; 19335 19336 R := N; 19337 Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm); 19338 19339 elsif Nkind (N) = N_Subtype_Indication then 19340 19341 -- The index is given by a subtype with a range constraint 19342 19343 T := Base_Type (Entity (Subtype_Mark (N))); 19344 19345 if not Is_Discrete_Type (T) then 19346 Error_Msg_N ("discrete type required for range", N); 19347 Set_Etype (N, Any_Type); 19348 return; 19349 end if; 19350 19351 R := Range_Expression (Constraint (N)); 19352 19353 Resolve (R, T); 19354 Process_Range_Expr_In_Decl 19355 (R, Entity (Subtype_Mark (N)), In_Iter_Schm => In_Iter_Schm); 19356 19357 elsif Nkind (N) = N_Attribute_Reference then 19358 19359 -- Catch beginner's error (use of attribute other than 'Range) 19360 19361 if Attribute_Name (N) /= Name_Range then 19362 Error_Msg_N ("expect attribute ''Range", N); 19363 Set_Etype (N, Any_Type); 19364 return; 19365 end if; 19366 19367 -- If the node denotes the range of a type mark, that is also the 19368 -- resulting type, and we do not need to create an Itype for it. 19369 19370 if Is_Entity_Name (Prefix (N)) 19371 and then Comes_From_Source (N) 19372 and then Is_Type (Entity (Prefix (N))) 19373 and then Is_Discrete_Type (Entity (Prefix (N))) 19374 then 19375 Def_Id := Entity (Prefix (N)); 19376 end if; 19377 19378 Analyze_And_Resolve (N); 19379 T := Etype (N); 19380 R := N; 19381 19382 -- If none of the above, must be a subtype. We convert this to a 19383 -- range attribute reference because in the case of declared first 19384 -- named subtypes, the types in the range reference can be different 19385 -- from the type of the entity. A range attribute normalizes the 19386 -- reference and obtains the correct types for the bounds. 19387 19388 -- This transformation is in the nature of an expansion, is only 19389 -- done if expansion is active. In particular, it is not done on 19390 -- formal generic types, because we need to retain the name of the 19391 -- original index for instantiation purposes. 19392 19393 else 19394 if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then 19395 Error_Msg_N ("invalid subtype mark in discrete range ", N); 19396 Set_Etype (N, Any_Integer); 19397 return; 19398 19399 else 19400 -- The type mark may be that of an incomplete type. It is only 19401 -- now that we can get the full view, previous analysis does 19402 -- not look specifically for a type mark. 19403 19404 Set_Entity (N, Get_Full_View (Entity (N))); 19405 Set_Etype (N, Entity (N)); 19406 Def_Id := Entity (N); 19407 19408 if not Is_Discrete_Type (Def_Id) then 19409 Error_Msg_N ("discrete type required for index", N); 19410 Set_Etype (N, Any_Type); 19411 return; 19412 end if; 19413 end if; 19414 19415 if Expander_Active then 19416 Rewrite (N, 19417 Make_Attribute_Reference (Sloc (N), 19418 Attribute_Name => Name_Range, 19419 Prefix => Relocate_Node (N))); 19420 19421 -- The original was a subtype mark that does not freeze. This 19422 -- means that the rewritten version must not freeze either. 19423 19424 Set_Must_Not_Freeze (N); 19425 Set_Must_Not_Freeze (Prefix (N)); 19426 Analyze_And_Resolve (N); 19427 T := Etype (N); 19428 R := N; 19429 19430 -- If expander is inactive, type is legal, nothing else to construct 19431 19432 else 19433 return; 19434 end if; 19435 end if; 19436 19437 if not Is_Discrete_Type (T) then 19438 Error_Msg_N ("discrete type required for range", N); 19439 Set_Etype (N, Any_Type); 19440 return; 19441 19442 elsif T = Any_Type then 19443 Set_Etype (N, Any_Type); 19444 return; 19445 end if; 19446 19447 -- We will now create the appropriate Itype to describe the range, but 19448 -- first a check. If we originally had a subtype, then we just label 19449 -- the range with this subtype. Not only is there no need to construct 19450 -- a new subtype, but it is wrong to do so for two reasons: 19451 19452 -- 1. A legality concern, if we have a subtype, it must not freeze, 19453 -- and the Itype would cause freezing incorrectly 19454 19455 -- 2. An efficiency concern, if we created an Itype, it would not be 19456 -- recognized as the same type for the purposes of eliminating 19457 -- checks in some circumstances. 19458 19459 -- We signal this case by setting the subtype entity in Def_Id 19460 19461 if No (Def_Id) then 19462 Def_Id := 19463 Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index); 19464 Set_Etype (Def_Id, Base_Type (T)); 19465 19466 if Is_Signed_Integer_Type (T) then 19467 Set_Ekind (Def_Id, E_Signed_Integer_Subtype); 19468 19469 elsif Is_Modular_Integer_Type (T) then 19470 Set_Ekind (Def_Id, E_Modular_Integer_Subtype); 19471 19472 else 19473 Set_Ekind (Def_Id, E_Enumeration_Subtype); 19474 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 19475 Set_First_Literal (Def_Id, First_Literal (T)); 19476 end if; 19477 19478 Set_Size_Info (Def_Id, (T)); 19479 Set_RM_Size (Def_Id, RM_Size (T)); 19480 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 19481 19482 Set_Scalar_Range (Def_Id, R); 19483 Conditional_Delay (Def_Id, T); 19484 19485 if Nkind (N) = N_Subtype_Indication then 19486 Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N))); 19487 end if; 19488 19489 -- In the subtype indication case, if the immediate parent of the 19490 -- new subtype is nonstatic, then the subtype we create is nonstatic, 19491 -- even if its bounds are static. 19492 19493 if Nkind (N) = N_Subtype_Indication 19494 and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) 19495 then 19496 Set_Is_Non_Static_Subtype (Def_Id); 19497 end if; 19498 end if; 19499 19500 -- Final step is to label the index with this constructed type 19501 19502 Set_Etype (N, Def_Id); 19503 end Make_Index; 19504 19505 ------------------------------ 19506 -- Modular_Type_Declaration -- 19507 ------------------------------ 19508 19509 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is 19510 Mod_Expr : constant Node_Id := Expression (Def); 19511 M_Val : Uint; 19512 19513 procedure Set_Modular_Size (Bits : Int); 19514 -- Sets RM_Size to Bits, and Esize to normal word size above this 19515 19516 ---------------------- 19517 -- Set_Modular_Size -- 19518 ---------------------- 19519 19520 procedure Set_Modular_Size (Bits : Int) is 19521 begin 19522 Set_RM_Size (T, UI_From_Int (Bits)); 19523 19524 if Bits <= 8 then 19525 Init_Esize (T, 8); 19526 19527 elsif Bits <= 16 then 19528 Init_Esize (T, 16); 19529 19530 elsif Bits <= 32 then 19531 Init_Esize (T, 32); 19532 19533 else 19534 Init_Esize (T, System_Max_Binary_Modulus_Power); 19535 end if; 19536 19537 if not Non_Binary_Modulus (T) and then Esize (T) = RM_Size (T) then 19538 Set_Is_Known_Valid (T); 19539 end if; 19540 end Set_Modular_Size; 19541 19542 -- Start of processing for Modular_Type_Declaration 19543 19544 begin 19545 -- If the mod expression is (exactly) 2 * literal, where literal is 19546 -- 64 or less,then almost certainly the * was meant to be **. Warn. 19547 19548 if Warn_On_Suspicious_Modulus_Value 19549 and then Nkind (Mod_Expr) = N_Op_Multiply 19550 and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal 19551 and then Intval (Left_Opnd (Mod_Expr)) = Uint_2 19552 and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal 19553 and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64 19554 then 19555 Error_Msg_N 19556 ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr); 19557 end if; 19558 19559 -- Proceed with analysis of mod expression 19560 19561 Analyze_And_Resolve (Mod_Expr, Any_Integer); 19562 Set_Etype (T, T); 19563 Set_Ekind (T, E_Modular_Integer_Type); 19564 Init_Alignment (T); 19565 Set_Is_Constrained (T); 19566 19567 if not Is_OK_Static_Expression (Mod_Expr) then 19568 Flag_Non_Static_Expr 19569 ("non-static expression used for modular type bound!", Mod_Expr); 19570 M_Val := 2 ** System_Max_Binary_Modulus_Power; 19571 else 19572 M_Val := Expr_Value (Mod_Expr); 19573 end if; 19574 19575 if M_Val < 1 then 19576 Error_Msg_N ("modulus value must be positive", Mod_Expr); 19577 M_Val := 2 ** System_Max_Binary_Modulus_Power; 19578 end if; 19579 19580 if M_Val > 2 ** Standard_Long_Integer_Size then 19581 Check_Restriction (No_Long_Long_Integers, Mod_Expr); 19582 end if; 19583 19584 Set_Modulus (T, M_Val); 19585 19586 -- Create bounds for the modular type based on the modulus given in 19587 -- the type declaration and then analyze and resolve those bounds. 19588 19589 Set_Scalar_Range (T, 19590 Make_Range (Sloc (Mod_Expr), 19591 Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0), 19592 High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1))); 19593 19594 -- Properly analyze the literals for the range. We do this manually 19595 -- because we can't go calling Resolve, since we are resolving these 19596 -- bounds with the type, and this type is certainly not complete yet. 19597 19598 Set_Etype (Low_Bound (Scalar_Range (T)), T); 19599 Set_Etype (High_Bound (Scalar_Range (T)), T); 19600 Set_Is_Static_Expression (Low_Bound (Scalar_Range (T))); 19601 Set_Is_Static_Expression (High_Bound (Scalar_Range (T))); 19602 19603 -- Loop through powers of two to find number of bits required 19604 19605 for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop 19606 19607 -- Binary case 19608 19609 if M_Val = 2 ** Bits then 19610 Set_Modular_Size (Bits); 19611 return; 19612 19613 -- Nonbinary case 19614 19615 elsif M_Val < 2 ** Bits then 19616 Check_SPARK_05_Restriction ("modulus should be a power of 2", T); 19617 Set_Non_Binary_Modulus (T); 19618 19619 if Bits > System_Max_Nonbinary_Modulus_Power then 19620 Error_Msg_Uint_1 := 19621 UI_From_Int (System_Max_Nonbinary_Modulus_Power); 19622 Error_Msg_F 19623 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr); 19624 Set_Modular_Size (System_Max_Binary_Modulus_Power); 19625 return; 19626 19627 else 19628 -- In the nonbinary case, set size as per RM 13.3(55) 19629 19630 Set_Modular_Size (Bits); 19631 return; 19632 end if; 19633 end if; 19634 19635 end loop; 19636 19637 -- If we fall through, then the size exceed System.Max_Binary_Modulus 19638 -- so we just signal an error and set the maximum size. 19639 19640 Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power); 19641 Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr); 19642 19643 Set_Modular_Size (System_Max_Binary_Modulus_Power); 19644 Init_Alignment (T); 19645 19646 end Modular_Type_Declaration; 19647 19648 -------------------------- 19649 -- New_Concatenation_Op -- 19650 -------------------------- 19651 19652 procedure New_Concatenation_Op (Typ : Entity_Id) is 19653 Loc : constant Source_Ptr := Sloc (Typ); 19654 Op : Entity_Id; 19655 19656 function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id; 19657 -- Create abbreviated declaration for the formal of a predefined 19658 -- Operator 'Op' of type 'Typ' 19659 19660 -------------------- 19661 -- Make_Op_Formal -- 19662 -------------------- 19663 19664 function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is 19665 Formal : Entity_Id; 19666 begin 19667 Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P'); 19668 Set_Etype (Formal, Typ); 19669 Set_Mechanism (Formal, Default_Mechanism); 19670 return Formal; 19671 end Make_Op_Formal; 19672 19673 -- Start of processing for New_Concatenation_Op 19674 19675 begin 19676 Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); 19677 19678 Set_Ekind (Op, E_Operator); 19679 Set_Scope (Op, Current_Scope); 19680 Set_Etype (Op, Typ); 19681 Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); 19682 Set_Is_Immediately_Visible (Op); 19683 Set_Is_Intrinsic_Subprogram (Op); 19684 Set_Has_Completion (Op); 19685 Append_Entity (Op, Current_Scope); 19686 19687 Set_Name_Entity_Id (Name_Op_Concat, Op); 19688 19689 Append_Entity (Make_Op_Formal (Typ, Op), Op); 19690 Append_Entity (Make_Op_Formal (Typ, Op), Op); 19691 end New_Concatenation_Op; 19692 19693 ------------------------- 19694 -- OK_For_Limited_Init -- 19695 ------------------------- 19696 19697 -- ???Check all calls of this, and compare the conditions under which it's 19698 -- called. 19699 19700 function OK_For_Limited_Init 19701 (Typ : Entity_Id; 19702 Exp : Node_Id) return Boolean 19703 is 19704 begin 19705 return Is_CPP_Constructor_Call (Exp) 19706 or else (Ada_Version >= Ada_2005 19707 and then not Debug_Flag_Dot_L 19708 and then OK_For_Limited_Init_In_05 (Typ, Exp)); 19709 end OK_For_Limited_Init; 19710 19711 ------------------------------- 19712 -- OK_For_Limited_Init_In_05 -- 19713 ------------------------------- 19714 19715 function OK_For_Limited_Init_In_05 19716 (Typ : Entity_Id; 19717 Exp : Node_Id) return Boolean 19718 is 19719 begin 19720 -- An object of a limited interface type can be initialized with any 19721 -- expression of a nonlimited descendant type. However this does not 19722 -- apply if this is a view conversion of some other expression. This 19723 -- is checked below. 19724 19725 if Is_Class_Wide_Type (Typ) 19726 and then Is_Limited_Interface (Typ) 19727 and then not Is_Limited_Type (Etype (Exp)) 19728 and then Nkind (Exp) /= N_Type_Conversion 19729 then 19730 return True; 19731 end if; 19732 19733 -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in 19734 -- case of limited aggregates (including extension aggregates), and 19735 -- function calls. The function call may have been given in prefixed 19736 -- notation, in which case the original node is an indexed component. 19737 -- If the function is parameterless, the original node was an explicit 19738 -- dereference. The function may also be parameterless, in which case 19739 -- the source node is just an identifier. 19740 19741 -- A branch of a conditional expression may have been removed if the 19742 -- condition is statically known. This happens during expansion, and 19743 -- thus will not happen if previous errors were encountered. The check 19744 -- will have been performed on the chosen branch, which replaces the 19745 -- original conditional expression. 19746 19747 if No (Exp) then 19748 return True; 19749 end if; 19750 19751 case Nkind (Original_Node (Exp)) is 19752 when N_Aggregate 19753 | N_Extension_Aggregate 19754 | N_Function_Call 19755 | N_Op 19756 => 19757 return True; 19758 19759 when N_Identifier => 19760 return Present (Entity (Original_Node (Exp))) 19761 and then Ekind (Entity (Original_Node (Exp))) = E_Function; 19762 19763 when N_Qualified_Expression => 19764 return 19765 OK_For_Limited_Init_In_05 19766 (Typ, Expression (Original_Node (Exp))); 19767 19768 -- Ada 2005 (AI-251): If a class-wide interface object is initialized 19769 -- with a function call, the expander has rewritten the call into an 19770 -- N_Type_Conversion node to force displacement of the pointer to 19771 -- reference the component containing the secondary dispatch table. 19772 -- Otherwise a type conversion is not a legal context. 19773 -- A return statement for a build-in-place function returning a 19774 -- synchronized type also introduces an unchecked conversion. 19775 19776 when N_Type_Conversion 19777 | N_Unchecked_Type_Conversion 19778 => 19779 return not Comes_From_Source (Exp) 19780 and then 19781 -- If the conversion has been rewritten, check Original_Node 19782 19783 ((Original_Node (Exp) /= Exp 19784 and then 19785 OK_For_Limited_Init_In_05 (Typ, Original_Node (Exp))) 19786 19787 -- Otherwise, check the expression of the compiler-generated 19788 -- conversion (which is a conversion that we want to ignore 19789 -- for purposes of the limited-initialization restrictions). 19790 19791 or else 19792 (Original_Node (Exp) = Exp 19793 and then 19794 OK_For_Limited_Init_In_05 (Typ, Expression (Exp)))); 19795 19796 when N_Explicit_Dereference 19797 | N_Indexed_Component 19798 | N_Selected_Component 19799 => 19800 return Nkind (Exp) = N_Function_Call; 19801 19802 -- A use of 'Input is a function call, hence allowed. Normally the 19803 -- attribute will be changed to a call, but the attribute by itself 19804 -- can occur with -gnatc. 19805 19806 when N_Attribute_Reference => 19807 return Attribute_Name (Original_Node (Exp)) = Name_Input; 19808 19809 -- "return raise ..." is OK 19810 19811 when N_Raise_Expression => 19812 return True; 19813 19814 -- For a case expression, all dependent expressions must be legal 19815 19816 when N_Case_Expression => 19817 declare 19818 Alt : Node_Id; 19819 19820 begin 19821 Alt := First (Alternatives (Original_Node (Exp))); 19822 while Present (Alt) loop 19823 if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then 19824 return False; 19825 end if; 19826 19827 Next (Alt); 19828 end loop; 19829 19830 return True; 19831 end; 19832 19833 -- For an if expression, all dependent expressions must be legal 19834 19835 when N_If_Expression => 19836 declare 19837 Then_Expr : constant Node_Id := 19838 Next (First (Expressions (Original_Node (Exp)))); 19839 Else_Expr : constant Node_Id := Next (Then_Expr); 19840 begin 19841 return OK_For_Limited_Init_In_05 (Typ, Then_Expr) 19842 and then 19843 OK_For_Limited_Init_In_05 (Typ, Else_Expr); 19844 end; 19845 19846 when others => 19847 return False; 19848 end case; 19849 end OK_For_Limited_Init_In_05; 19850 19851 ------------------------------------------- 19852 -- Ordinary_Fixed_Point_Type_Declaration -- 19853 ------------------------------------------- 19854 19855 procedure Ordinary_Fixed_Point_Type_Declaration 19856 (T : Entity_Id; 19857 Def : Node_Id) 19858 is 19859 Loc : constant Source_Ptr := Sloc (Def); 19860 Delta_Expr : constant Node_Id := Delta_Expression (Def); 19861 RRS : constant Node_Id := Real_Range_Specification (Def); 19862 Implicit_Base : Entity_Id; 19863 Delta_Val : Ureal; 19864 Small_Val : Ureal; 19865 Low_Val : Ureal; 19866 High_Val : Ureal; 19867 19868 begin 19869 Check_Restriction (No_Fixed_Point, Def); 19870 19871 -- Create implicit base type 19872 19873 Implicit_Base := 19874 Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B'); 19875 Set_Etype (Implicit_Base, Implicit_Base); 19876 19877 -- Analyze and process delta expression 19878 19879 Analyze_And_Resolve (Delta_Expr, Any_Real); 19880 19881 Check_Delta_Expression (Delta_Expr); 19882 Delta_Val := Expr_Value_R (Delta_Expr); 19883 19884 Set_Delta_Value (Implicit_Base, Delta_Val); 19885 19886 -- Compute default small from given delta, which is the largest power 19887 -- of two that does not exceed the given delta value. 19888 19889 declare 19890 Tmp : Ureal; 19891 Scale : Int; 19892 19893 begin 19894 Tmp := Ureal_1; 19895 Scale := 0; 19896 19897 if Delta_Val < Ureal_1 then 19898 while Delta_Val < Tmp loop 19899 Tmp := Tmp / Ureal_2; 19900 Scale := Scale + 1; 19901 end loop; 19902 19903 else 19904 loop 19905 Tmp := Tmp * Ureal_2; 19906 exit when Tmp > Delta_Val; 19907 Scale := Scale - 1; 19908 end loop; 19909 end if; 19910 19911 Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2); 19912 end; 19913 19914 Set_Small_Value (Implicit_Base, Small_Val); 19915 19916 -- If no range was given, set a dummy range 19917 19918 if RRS <= Empty_Or_Error then 19919 Low_Val := -Small_Val; 19920 High_Val := Small_Val; 19921 19922 -- Otherwise analyze and process given range 19923 19924 else 19925 declare 19926 Low : constant Node_Id := Low_Bound (RRS); 19927 High : constant Node_Id := High_Bound (RRS); 19928 19929 begin 19930 Analyze_And_Resolve (Low, Any_Real); 19931 Analyze_And_Resolve (High, Any_Real); 19932 Check_Real_Bound (Low); 19933 Check_Real_Bound (High); 19934 19935 -- Obtain and set the range 19936 19937 Low_Val := Expr_Value_R (Low); 19938 High_Val := Expr_Value_R (High); 19939 19940 if Low_Val > High_Val then 19941 Error_Msg_NE ("??fixed point type& has null range", Def, T); 19942 end if; 19943 end; 19944 end if; 19945 19946 -- The range for both the implicit base and the declared first subtype 19947 -- cannot be set yet, so we use the special routine Set_Fixed_Range to 19948 -- set a temporary range in place. Note that the bounds of the base 19949 -- type will be widened to be symmetrical and to fill the available 19950 -- bits when the type is frozen. 19951 19952 -- We could do this with all discrete types, and probably should, but 19953 -- we absolutely have to do it for fixed-point, since the end-points 19954 -- of the range and the size are determined by the small value, which 19955 -- could be reset before the freeze point. 19956 19957 Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); 19958 Set_Fixed_Range (T, Loc, Low_Val, High_Val); 19959 19960 -- Complete definition of first subtype. The inheritance of the rep item 19961 -- chain ensures that SPARK-related pragmas are not clobbered when the 19962 -- ordinary fixed point type acts as a full view of a private type. 19963 19964 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); 19965 Set_Etype (T, Implicit_Base); 19966 Init_Size_Align (T); 19967 Inherit_Rep_Item_Chain (T, Implicit_Base); 19968 Set_Small_Value (T, Small_Val); 19969 Set_Delta_Value (T, Delta_Val); 19970 Set_Is_Constrained (T); 19971 end Ordinary_Fixed_Point_Type_Declaration; 19972 19973 ---------------------------------- 19974 -- Preanalyze_Assert_Expression -- 19975 ---------------------------------- 19976 19977 procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is 19978 begin 19979 In_Assertion_Expr := In_Assertion_Expr + 1; 19980 Preanalyze_Spec_Expression (N, T); 19981 In_Assertion_Expr := In_Assertion_Expr - 1; 19982 end Preanalyze_Assert_Expression; 19983 19984 ----------------------------------- 19985 -- Preanalyze_Default_Expression -- 19986 ----------------------------------- 19987 19988 procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is 19989 Save_In_Default_Expr : constant Boolean := In_Default_Expr; 19990 Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; 19991 19992 begin 19993 In_Default_Expr := True; 19994 In_Spec_Expression := True; 19995 19996 Preanalyze_With_Freezing_And_Resolve (N, T); 19997 19998 In_Default_Expr := Save_In_Default_Expr; 19999 In_Spec_Expression := Save_In_Spec_Expression; 20000 end Preanalyze_Default_Expression; 20001 20002 -------------------------------- 20003 -- Preanalyze_Spec_Expression -- 20004 -------------------------------- 20005 20006 procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is 20007 Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; 20008 begin 20009 In_Spec_Expression := True; 20010 Preanalyze_And_Resolve (N, T); 20011 In_Spec_Expression := Save_In_Spec_Expression; 20012 end Preanalyze_Spec_Expression; 20013 20014 ---------------------------------------- 20015 -- Prepare_Private_Subtype_Completion -- 20016 ---------------------------------------- 20017 20018 procedure Prepare_Private_Subtype_Completion 20019 (Id : Entity_Id; 20020 Related_Nod : Node_Id) 20021 is 20022 Id_B : constant Entity_Id := Base_Type (Id); 20023 Full_B : constant Entity_Id := Full_View (Id_B); 20024 Full : Entity_Id; 20025 20026 begin 20027 if Present (Full_B) then 20028 20029 -- The Base_Type is already completed, we can complete the subtype 20030 -- now. We have to create a new entity with the same name, Thus we 20031 -- can't use Create_Itype. 20032 20033 Full := Make_Defining_Identifier (Sloc (Id), Chars (Id)); 20034 Set_Is_Itype (Full); 20035 Set_Associated_Node_For_Itype (Full, Related_Nod); 20036 Complete_Private_Subtype (Id, Full, Full_B, Related_Nod); 20037 Set_Full_View (Id, Full); 20038 end if; 20039 20040 -- The parent subtype may be private, but the base might not, in some 20041 -- nested instances. In that case, the subtype does not need to be 20042 -- exchanged. It would still be nice to make private subtypes and their 20043 -- bases consistent at all times ??? 20044 20045 if Is_Private_Type (Id_B) then 20046 Append_Elmt (Id, Private_Dependents (Id_B)); 20047 end if; 20048 end Prepare_Private_Subtype_Completion; 20049 20050 --------------------------- 20051 -- Process_Discriminants -- 20052 --------------------------- 20053 20054 procedure Process_Discriminants 20055 (N : Node_Id; 20056 Prev : Entity_Id := Empty) 20057 is 20058 Elist : constant Elist_Id := New_Elmt_List; 20059 Id : Node_Id; 20060 Discr : Node_Id; 20061 Discr_Number : Uint; 20062 Discr_Type : Entity_Id; 20063 Default_Present : Boolean := False; 20064 Default_Not_Present : Boolean := False; 20065 20066 begin 20067 -- A composite type other than an array type can have discriminants. 20068 -- On entry, the current scope is the composite type. 20069 20070 -- The discriminants are initially entered into the scope of the type 20071 -- via Enter_Name with the default Ekind of E_Void to prevent premature 20072 -- use, as explained at the end of this procedure. 20073 20074 Discr := First (Discriminant_Specifications (N)); 20075 while Present (Discr) loop 20076 Enter_Name (Defining_Identifier (Discr)); 20077 20078 -- For navigation purposes we add a reference to the discriminant 20079 -- in the entity for the type. If the current declaration is a 20080 -- completion, place references on the partial view. Otherwise the 20081 -- type is the current scope. 20082 20083 if Present (Prev) then 20084 20085 -- The references go on the partial view, if present. If the 20086 -- partial view has discriminants, the references have been 20087 -- generated already. 20088 20089 if not Has_Discriminants (Prev) then 20090 Generate_Reference (Prev, Defining_Identifier (Discr), 'd'); 20091 end if; 20092 else 20093 Generate_Reference 20094 (Current_Scope, Defining_Identifier (Discr), 'd'); 20095 end if; 20096 20097 if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then 20098 Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr)); 20099 20100 -- Ada 2005 (AI-254) 20101 20102 if Present (Access_To_Subprogram_Definition 20103 (Discriminant_Type (Discr))) 20104 and then Protected_Present (Access_To_Subprogram_Definition 20105 (Discriminant_Type (Discr))) 20106 then 20107 Discr_Type := 20108 Replace_Anonymous_Access_To_Protected_Subprogram (Discr); 20109 end if; 20110 20111 else 20112 Find_Type (Discriminant_Type (Discr)); 20113 Discr_Type := Etype (Discriminant_Type (Discr)); 20114 20115 if Error_Posted (Discriminant_Type (Discr)) then 20116 Discr_Type := Any_Type; 20117 end if; 20118 end if; 20119 20120 -- Handling of discriminants that are access types 20121 20122 if Is_Access_Type (Discr_Type) then 20123 20124 -- Ada 2005 (AI-230): Access discriminant allowed in non- 20125 -- limited record types 20126 20127 if Ada_Version < Ada_2005 then 20128 Check_Access_Discriminant_Requires_Limited 20129 (Discr, Discriminant_Type (Discr)); 20130 end if; 20131 20132 if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then 20133 Error_Msg_N 20134 ("(Ada 83) access discriminant not allowed", Discr); 20135 end if; 20136 20137 -- If not access type, must be a discrete type 20138 20139 elsif not Is_Discrete_Type (Discr_Type) then 20140 Error_Msg_N 20141 ("discriminants must have a discrete or access type", 20142 Discriminant_Type (Discr)); 20143 end if; 20144 20145 Set_Etype (Defining_Identifier (Discr), Discr_Type); 20146 20147 -- If a discriminant specification includes the assignment compound 20148 -- delimiter followed by an expression, the expression is the default 20149 -- expression of the discriminant; the default expression must be of 20150 -- the type of the discriminant. (RM 3.7.1) Since this expression is 20151 -- a default expression, we do the special preanalysis, since this 20152 -- expression does not freeze (see section "Handling of Default and 20153 -- Per-Object Expressions" in spec of package Sem). 20154 20155 if Present (Expression (Discr)) then 20156 Preanalyze_Spec_Expression (Expression (Discr), Discr_Type); 20157 20158 -- Legaity checks 20159 20160 if Nkind (N) = N_Formal_Type_Declaration then 20161 Error_Msg_N 20162 ("discriminant defaults not allowed for formal type", 20163 Expression (Discr)); 20164 20165 -- Flag an error for a tagged type with defaulted discriminants, 20166 -- excluding limited tagged types when compiling for Ada 2012 20167 -- (see AI05-0214). 20168 20169 elsif Is_Tagged_Type (Current_Scope) 20170 and then (not Is_Limited_Type (Current_Scope) 20171 or else Ada_Version < Ada_2012) 20172 and then Comes_From_Source (N) 20173 then 20174 -- Note: see similar test in Check_Or_Process_Discriminants, to 20175 -- handle the (illegal) case of the completion of an untagged 20176 -- view with discriminants with defaults by a tagged full view. 20177 -- We skip the check if Discr does not come from source, to 20178 -- account for the case of an untagged derived type providing 20179 -- defaults for a renamed discriminant from a private untagged 20180 -- ancestor with a tagged full view (ACATS B460006). 20181 20182 if Ada_Version >= Ada_2012 then 20183 Error_Msg_N 20184 ("discriminants of nonlimited tagged type cannot have" 20185 & " defaults", 20186 Expression (Discr)); 20187 else 20188 Error_Msg_N 20189 ("discriminants of tagged type cannot have defaults", 20190 Expression (Discr)); 20191 end if; 20192 20193 else 20194 Default_Present := True; 20195 Append_Elmt (Expression (Discr), Elist); 20196 20197 -- Tag the defining identifiers for the discriminants with 20198 -- their corresponding default expressions from the tree. 20199 20200 Set_Discriminant_Default_Value 20201 (Defining_Identifier (Discr), Expression (Discr)); 20202 end if; 20203 20204 -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag 20205 -- gets set unless we can be sure that no range check is required. 20206 20207 if (GNATprove_Mode or not Expander_Active) 20208 and then not 20209 Is_In_Range 20210 (Expression (Discr), Discr_Type, Assume_Valid => True) 20211 then 20212 Set_Do_Range_Check (Expression (Discr)); 20213 end if; 20214 20215 -- No default discriminant value given 20216 20217 else 20218 Default_Not_Present := True; 20219 end if; 20220 20221 -- Ada 2005 (AI-231): Create an Itype that is a duplicate of 20222 -- Discr_Type but with the null-exclusion attribute 20223 20224 if Ada_Version >= Ada_2005 then 20225 20226 -- Ada 2005 (AI-231): Static checks 20227 20228 if Can_Never_Be_Null (Discr_Type) then 20229 Null_Exclusion_Static_Checks (Discr); 20230 20231 elsif Is_Access_Type (Discr_Type) 20232 and then Null_Exclusion_Present (Discr) 20233 20234 -- No need to check itypes because in their case this check 20235 -- was done at their point of creation 20236 20237 and then not Is_Itype (Discr_Type) 20238 then 20239 if Can_Never_Be_Null (Discr_Type) then 20240 Error_Msg_NE 20241 ("`NOT NULL` not allowed (& already excludes null)", 20242 Discr, 20243 Discr_Type); 20244 end if; 20245 20246 Set_Etype (Defining_Identifier (Discr), 20247 Create_Null_Excluding_Itype 20248 (T => Discr_Type, 20249 Related_Nod => Discr)); 20250 20251 -- Check for improper null exclusion if the type is otherwise 20252 -- legal for a discriminant. 20253 20254 elsif Null_Exclusion_Present (Discr) 20255 and then Is_Discrete_Type (Discr_Type) 20256 then 20257 Error_Msg_N 20258 ("null exclusion can only apply to an access type", Discr); 20259 end if; 20260 20261 -- Ada 2005 (AI-402): access discriminants of nonlimited types 20262 -- can't have defaults. Synchronized types, or types that are 20263 -- explicitly limited are fine, but special tests apply to derived 20264 -- types in generics: in a generic body we have to assume the 20265 -- worst, and therefore defaults are not allowed if the parent is 20266 -- a generic formal private type (see ACATS B370001). 20267 20268 if Is_Access_Type (Discr_Type) and then Default_Present then 20269 if Ekind (Discr_Type) /= E_Anonymous_Access_Type 20270 or else Is_Limited_Record (Current_Scope) 20271 or else Is_Concurrent_Type (Current_Scope) 20272 or else Is_Concurrent_Record_Type (Current_Scope) 20273 or else Ekind (Current_Scope) = E_Limited_Private_Type 20274 then 20275 if not Is_Derived_Type (Current_Scope) 20276 or else not Is_Generic_Type (Etype (Current_Scope)) 20277 or else not In_Package_Body (Scope (Etype (Current_Scope))) 20278 or else Limited_Present 20279 (Type_Definition (Parent (Current_Scope))) 20280 then 20281 null; 20282 20283 else 20284 Error_Msg_N 20285 ("access discriminants of nonlimited types cannot " 20286 & "have defaults", Expression (Discr)); 20287 end if; 20288 20289 elsif Present (Expression (Discr)) then 20290 Error_Msg_N 20291 ("(Ada 2005) access discriminants of nonlimited types " 20292 & "cannot have defaults", Expression (Discr)); 20293 end if; 20294 end if; 20295 end if; 20296 20297 -- A discriminant cannot be effectively volatile (SPARK RM 7.1.3(4)). 20298 -- This check is relevant only when SPARK_Mode is on as it is not a 20299 -- standard Ada legality rule. 20300 20301 if SPARK_Mode = On 20302 and then Is_Effectively_Volatile (Defining_Identifier (Discr)) 20303 then 20304 Error_Msg_N ("discriminant cannot be volatile", Discr); 20305 end if; 20306 20307 Next (Discr); 20308 end loop; 20309 20310 -- An element list consisting of the default expressions of the 20311 -- discriminants is constructed in the above loop and used to set 20312 -- the Discriminant_Constraint attribute for the type. If an object 20313 -- is declared of this (record or task) type without any explicit 20314 -- discriminant constraint given, this element list will form the 20315 -- actual parameters for the corresponding initialization procedure 20316 -- for the type. 20317 20318 Set_Discriminant_Constraint (Current_Scope, Elist); 20319 Set_Stored_Constraint (Current_Scope, No_Elist); 20320 20321 -- Default expressions must be provided either for all or for none 20322 -- of the discriminants of a discriminant part. (RM 3.7.1) 20323 20324 if Default_Present and then Default_Not_Present then 20325 Error_Msg_N 20326 ("incomplete specification of defaults for discriminants", N); 20327 end if; 20328 20329 -- The use of the name of a discriminant is not allowed in default 20330 -- expressions of a discriminant part if the specification of the 20331 -- discriminant is itself given in the discriminant part. (RM 3.7.1) 20332 20333 -- To detect this, the discriminant names are entered initially with an 20334 -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any 20335 -- attempt to use a void entity (for example in an expression that is 20336 -- type-checked) produces the error message: premature usage. Now after 20337 -- completing the semantic analysis of the discriminant part, we can set 20338 -- the Ekind of all the discriminants appropriately. 20339 20340 Discr := First (Discriminant_Specifications (N)); 20341 Discr_Number := Uint_1; 20342 while Present (Discr) loop 20343 Id := Defining_Identifier (Discr); 20344 Set_Ekind (Id, E_Discriminant); 20345 Init_Component_Location (Id); 20346 Init_Esize (Id); 20347 Set_Discriminant_Number (Id, Discr_Number); 20348 20349 -- Make sure this is always set, even in illegal programs 20350 20351 Set_Corresponding_Discriminant (Id, Empty); 20352 20353 -- Initialize the Original_Record_Component to the entity itself. 20354 -- Inherit_Components will propagate the right value to 20355 -- discriminants in derived record types. 20356 20357 Set_Original_Record_Component (Id, Id); 20358 20359 -- Create the discriminal for the discriminant 20360 20361 Build_Discriminal (Id); 20362 20363 Next (Discr); 20364 Discr_Number := Discr_Number + 1; 20365 end loop; 20366 20367 Set_Has_Discriminants (Current_Scope); 20368 end Process_Discriminants; 20369 20370 ----------------------- 20371 -- Process_Full_View -- 20372 ----------------------- 20373 20374 -- WARNING: This routine manages Ghost regions. Return statements must be 20375 -- replaced by gotos which jump to the end of the routine and restore the 20376 -- Ghost mode. 20377 20378 procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is 20379 procedure Collect_Implemented_Interfaces 20380 (Typ : Entity_Id; 20381 Ifaces : Elist_Id); 20382 -- Ada 2005: Gather all the interfaces that Typ directly or 20383 -- inherently implements. Duplicate entries are not added to 20384 -- the list Ifaces. 20385 20386 ------------------------------------ 20387 -- Collect_Implemented_Interfaces -- 20388 ------------------------------------ 20389 20390 procedure Collect_Implemented_Interfaces 20391 (Typ : Entity_Id; 20392 Ifaces : Elist_Id) 20393 is 20394 Iface : Entity_Id; 20395 Iface_Elmt : Elmt_Id; 20396 20397 begin 20398 -- Abstract interfaces are only associated with tagged record types 20399 20400 if not Is_Tagged_Type (Typ) or else not Is_Record_Type (Typ) then 20401 return; 20402 end if; 20403 20404 -- Recursively climb to the ancestors 20405 20406 if Etype (Typ) /= Typ 20407 20408 -- Protect the frontend against wrong cyclic declarations like: 20409 20410 -- type B is new A with private; 20411 -- type C is new A with private; 20412 -- private 20413 -- type B is new C with null record; 20414 -- type C is new B with null record; 20415 20416 and then Etype (Typ) /= Priv_T 20417 and then Etype (Typ) /= Full_T 20418 then 20419 -- Keep separate the management of private type declarations 20420 20421 if Ekind (Typ) = E_Record_Type_With_Private then 20422 20423 -- Handle the following illegal usage: 20424 -- type Private_Type is tagged private; 20425 -- private 20426 -- type Private_Type is new Type_Implementing_Iface; 20427 20428 if Present (Full_View (Typ)) 20429 and then Etype (Typ) /= Full_View (Typ) 20430 then 20431 if Is_Interface (Etype (Typ)) then 20432 Append_Unique_Elmt (Etype (Typ), Ifaces); 20433 end if; 20434 20435 Collect_Implemented_Interfaces (Etype (Typ), Ifaces); 20436 end if; 20437 20438 -- Non-private types 20439 20440 else 20441 if Is_Interface (Etype (Typ)) then 20442 Append_Unique_Elmt (Etype (Typ), Ifaces); 20443 end if; 20444 20445 Collect_Implemented_Interfaces (Etype (Typ), Ifaces); 20446 end if; 20447 end if; 20448 20449 -- Handle entities in the list of abstract interfaces 20450 20451 if Present (Interfaces (Typ)) then 20452 Iface_Elmt := First_Elmt (Interfaces (Typ)); 20453 while Present (Iface_Elmt) loop 20454 Iface := Node (Iface_Elmt); 20455 20456 pragma Assert (Is_Interface (Iface)); 20457 20458 if not Contain_Interface (Iface, Ifaces) then 20459 Append_Elmt (Iface, Ifaces); 20460 Collect_Implemented_Interfaces (Iface, Ifaces); 20461 end if; 20462 20463 Next_Elmt (Iface_Elmt); 20464 end loop; 20465 end if; 20466 end Collect_Implemented_Interfaces; 20467 20468 -- Local variables 20469 20470 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 20471 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 20472 -- Save the Ghost-related attributes to restore on exit 20473 20474 Full_Indic : Node_Id; 20475 Full_Parent : Entity_Id; 20476 Priv_Parent : Entity_Id; 20477 20478 -- Start of processing for Process_Full_View 20479 20480 begin 20481 Mark_And_Set_Ghost_Completion (N, Priv_T); 20482 20483 -- First some sanity checks that must be done after semantic 20484 -- decoration of the full view and thus cannot be placed with other 20485 -- similar checks in Find_Type_Name 20486 20487 if not Is_Limited_Type (Priv_T) 20488 and then (Is_Limited_Type (Full_T) 20489 or else Is_Limited_Composite (Full_T)) 20490 then 20491 if In_Instance then 20492 null; 20493 else 20494 Error_Msg_N 20495 ("completion of nonlimited type cannot be limited", Full_T); 20496 Explain_Limited_Type (Full_T, Full_T); 20497 end if; 20498 20499 elsif Is_Abstract_Type (Full_T) 20500 and then not Is_Abstract_Type (Priv_T) 20501 then 20502 Error_Msg_N 20503 ("completion of nonabstract type cannot be abstract", Full_T); 20504 20505 elsif Is_Tagged_Type (Priv_T) 20506 and then Is_Limited_Type (Priv_T) 20507 and then not Is_Limited_Type (Full_T) 20508 then 20509 -- If pragma CPP_Class was applied to the private declaration 20510 -- propagate the limitedness to the full-view 20511 20512 if Is_CPP_Class (Priv_T) then 20513 Set_Is_Limited_Record (Full_T); 20514 20515 -- GNAT allow its own definition of Limited_Controlled to disobey 20516 -- this rule in order in ease the implementation. This test is safe 20517 -- because Root_Controlled is defined in a child of System that 20518 -- normal programs are not supposed to use. 20519 20520 elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then 20521 Set_Is_Limited_Composite (Full_T); 20522 else 20523 Error_Msg_N 20524 ("completion of limited tagged type must be limited", Full_T); 20525 end if; 20526 20527 elsif Is_Generic_Type (Priv_T) then 20528 Error_Msg_N ("generic type cannot have a completion", Full_T); 20529 end if; 20530 20531 -- Check that ancestor interfaces of private and full views are 20532 -- consistent. We omit this check for synchronized types because 20533 -- they are performed on the corresponding record type when frozen. 20534 20535 if Ada_Version >= Ada_2005 20536 and then Is_Tagged_Type (Priv_T) 20537 and then Is_Tagged_Type (Full_T) 20538 and then not Is_Concurrent_Type (Full_T) 20539 then 20540 declare 20541 Iface : Entity_Id; 20542 Priv_T_Ifaces : constant Elist_Id := New_Elmt_List; 20543 Full_T_Ifaces : constant Elist_Id := New_Elmt_List; 20544 20545 begin 20546 Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces); 20547 Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces); 20548 20549 -- Ada 2005 (AI-251): The partial view shall be a descendant of 20550 -- an interface type if and only if the full type is descendant 20551 -- of the interface type (AARM 7.3 (7.3/2)). 20552 20553 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); 20554 20555 if Present (Iface) then 20556 Error_Msg_NE 20557 ("interface in partial view& not implemented by full type " 20558 & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); 20559 end if; 20560 20561 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); 20562 20563 if Present (Iface) then 20564 Error_Msg_NE 20565 ("interface & not implemented by partial view " 20566 & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); 20567 end if; 20568 end; 20569 end if; 20570 20571 if Is_Tagged_Type (Priv_T) 20572 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 20573 and then Is_Derived_Type (Full_T) 20574 then 20575 Priv_Parent := Etype (Priv_T); 20576 20577 -- The full view of a private extension may have been transformed 20578 -- into an unconstrained derived type declaration and a subtype 20579 -- declaration (see build_derived_record_type for details). 20580 20581 if Nkind (N) = N_Subtype_Declaration then 20582 Full_Indic := Subtype_Indication (N); 20583 Full_Parent := Etype (Base_Type (Full_T)); 20584 else 20585 Full_Indic := Subtype_Indication (Type_Definition (N)); 20586 Full_Parent := Etype (Full_T); 20587 end if; 20588 20589 -- Check that the parent type of the full type is a descendant of 20590 -- the ancestor subtype given in the private extension. If either 20591 -- entity has an Etype equal to Any_Type then we had some previous 20592 -- error situation [7.3(8)]. 20593 20594 if Priv_Parent = Any_Type or else Full_Parent = Any_Type then 20595 goto Leave; 20596 20597 -- Ada 2005 (AI-251): Interfaces in the full type can be given in 20598 -- any order. Therefore we don't have to check that its parent must 20599 -- be a descendant of the parent of the private type declaration. 20600 20601 elsif Is_Interface (Priv_Parent) 20602 and then Is_Interface (Full_Parent) 20603 then 20604 null; 20605 20606 -- Ada 2005 (AI-251): If the parent of the private type declaration 20607 -- is an interface there is no need to check that it is an ancestor 20608 -- of the associated full type declaration. The required tests for 20609 -- this case are performed by Build_Derived_Record_Type. 20610 20611 elsif not Is_Interface (Base_Type (Priv_Parent)) 20612 and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) 20613 then 20614 Error_Msg_N 20615 ("parent of full type must descend from parent of private " 20616 & "extension", Full_Indic); 20617 20618 -- First check a formal restriction, and then proceed with checking 20619 -- Ada rules. Since the formal restriction is not a serious error, we 20620 -- don't prevent further error detection for this check, hence the 20621 -- ELSE. 20622 20623 else 20624 -- In formal mode, when completing a private extension the type 20625 -- named in the private part must be exactly the same as that 20626 -- named in the visible part. 20627 20628 if Priv_Parent /= Full_Parent then 20629 Error_Msg_Name_1 := Chars (Priv_Parent); 20630 Check_SPARK_05_Restriction ("% expected", Full_Indic); 20631 end if; 20632 20633 -- Check the rules of 7.3(10): if the private extension inherits 20634 -- known discriminants, then the full type must also inherit those 20635 -- discriminants from the same (ancestor) type, and the parent 20636 -- subtype of the full type must be constrained if and only if 20637 -- the ancestor subtype of the private extension is constrained. 20638 20639 if No (Discriminant_Specifications (Parent (Priv_T))) 20640 and then not Has_Unknown_Discriminants (Priv_T) 20641 and then Has_Discriminants (Base_Type (Priv_Parent)) 20642 then 20643 declare 20644 Priv_Indic : constant Node_Id := 20645 Subtype_Indication (Parent (Priv_T)); 20646 20647 Priv_Constr : constant Boolean := 20648 Is_Constrained (Priv_Parent) 20649 or else 20650 Nkind (Priv_Indic) = N_Subtype_Indication 20651 or else 20652 Is_Constrained (Entity (Priv_Indic)); 20653 20654 Full_Constr : constant Boolean := 20655 Is_Constrained (Full_Parent) 20656 or else 20657 Nkind (Full_Indic) = N_Subtype_Indication 20658 or else 20659 Is_Constrained (Entity (Full_Indic)); 20660 20661 Priv_Discr : Entity_Id; 20662 Full_Discr : Entity_Id; 20663 20664 begin 20665 Priv_Discr := First_Discriminant (Priv_Parent); 20666 Full_Discr := First_Discriminant (Full_Parent); 20667 while Present (Priv_Discr) and then Present (Full_Discr) loop 20668 if Original_Record_Component (Priv_Discr) = 20669 Original_Record_Component (Full_Discr) 20670 or else 20671 Corresponding_Discriminant (Priv_Discr) = 20672 Corresponding_Discriminant (Full_Discr) 20673 then 20674 null; 20675 else 20676 exit; 20677 end if; 20678 20679 Next_Discriminant (Priv_Discr); 20680 Next_Discriminant (Full_Discr); 20681 end loop; 20682 20683 if Present (Priv_Discr) or else Present (Full_Discr) then 20684 Error_Msg_N 20685 ("full view must inherit discriminants of the parent " 20686 & "type used in the private extension", Full_Indic); 20687 20688 elsif Priv_Constr and then not Full_Constr then 20689 Error_Msg_N 20690 ("parent subtype of full type must be constrained", 20691 Full_Indic); 20692 20693 elsif Full_Constr and then not Priv_Constr then 20694 Error_Msg_N 20695 ("parent subtype of full type must be unconstrained", 20696 Full_Indic); 20697 end if; 20698 end; 20699 20700 -- Check the rules of 7.3(12): if a partial view has neither 20701 -- known or unknown discriminants, then the full type 20702 -- declaration shall define a definite subtype. 20703 20704 elsif not Has_Unknown_Discriminants (Priv_T) 20705 and then not Has_Discriminants (Priv_T) 20706 and then not Is_Constrained (Full_T) 20707 then 20708 Error_Msg_N 20709 ("full view must define a constrained type if partial view " 20710 & "has no discriminants", Full_T); 20711 end if; 20712 20713 -- ??????? Do we implement the following properly ????? 20714 -- If the ancestor subtype of a private extension has constrained 20715 -- discriminants, then the parent subtype of the full view shall 20716 -- impose a statically matching constraint on those discriminants 20717 -- [7.3(13)]. 20718 end if; 20719 20720 else 20721 -- For untagged types, verify that a type without discriminants is 20722 -- not completed with an unconstrained type. A separate error message 20723 -- is produced if the full type has defaulted discriminants. 20724 20725 if Is_Definite_Subtype (Priv_T) 20726 and then not Is_Definite_Subtype (Full_T) 20727 then 20728 Error_Msg_Sloc := Sloc (Parent (Priv_T)); 20729 Error_Msg_NE 20730 ("full view of& not compatible with declaration#", 20731 Full_T, Priv_T); 20732 20733 if not Is_Tagged_Type (Full_T) then 20734 Error_Msg_N 20735 ("\one is constrained, the other unconstrained", Full_T); 20736 end if; 20737 end if; 20738 end if; 20739 20740 -- AI-419: verify that the use of "limited" is consistent 20741 20742 declare 20743 Orig_Decl : constant Node_Id := Original_Node (N); 20744 20745 begin 20746 if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 20747 and then Nkind (Orig_Decl) = N_Full_Type_Declaration 20748 and then Nkind 20749 (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition 20750 then 20751 if not Limited_Present (Parent (Priv_T)) 20752 and then not Synchronized_Present (Parent (Priv_T)) 20753 and then Limited_Present (Type_Definition (Orig_Decl)) 20754 then 20755 Error_Msg_N 20756 ("full view of non-limited extension cannot be limited", N); 20757 20758 -- Conversely, if the partial view carries the limited keyword, 20759 -- the full view must as well, even if it may be redundant. 20760 20761 elsif Limited_Present (Parent (Priv_T)) 20762 and then not Limited_Present (Type_Definition (Orig_Decl)) 20763 then 20764 Error_Msg_N 20765 ("full view of limited extension must be explicitly limited", 20766 N); 20767 end if; 20768 end if; 20769 end; 20770 20771 -- Ada 2005 (AI-443): A synchronized private extension must be 20772 -- completed by a task or protected type. 20773 20774 if Ada_Version >= Ada_2005 20775 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 20776 and then Synchronized_Present (Parent (Priv_T)) 20777 and then not Is_Concurrent_Type (Full_T) 20778 then 20779 Error_Msg_N ("full view of synchronized extension must " & 20780 "be synchronized type", N); 20781 end if; 20782 20783 -- Ada 2005 AI-363: if the full view has discriminants with 20784 -- defaults, it is illegal to declare constrained access subtypes 20785 -- whose designated type is the current type. This allows objects 20786 -- of the type that are declared in the heap to be unconstrained. 20787 20788 if not Has_Unknown_Discriminants (Priv_T) 20789 and then not Has_Discriminants (Priv_T) 20790 and then Has_Discriminants (Full_T) 20791 and then 20792 Present (Discriminant_Default_Value (First_Discriminant (Full_T))) 20793 then 20794 Set_Has_Constrained_Partial_View (Full_T); 20795 Set_Has_Constrained_Partial_View (Priv_T); 20796 end if; 20797 20798 -- Create a full declaration for all its subtypes recorded in 20799 -- Private_Dependents and swap them similarly to the base type. These 20800 -- are subtypes that have been define before the full declaration of 20801 -- the private type. We also swap the entry in Private_Dependents list 20802 -- so we can properly restore the private view on exit from the scope. 20803 20804 declare 20805 Priv_Elmt : Elmt_Id; 20806 Priv_Scop : Entity_Id; 20807 Priv : Entity_Id; 20808 Full : Entity_Id; 20809 20810 begin 20811 Priv_Elmt := First_Elmt (Private_Dependents (Priv_T)); 20812 while Present (Priv_Elmt) loop 20813 Priv := Node (Priv_Elmt); 20814 Priv_Scop := Scope (Priv); 20815 20816 if Ekind_In (Priv, E_Private_Subtype, 20817 E_Limited_Private_Subtype, 20818 E_Record_Subtype_With_Private) 20819 then 20820 Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); 20821 Set_Is_Itype (Full); 20822 Set_Parent (Full, Parent (Priv)); 20823 Set_Associated_Node_For_Itype (Full, N); 20824 20825 -- Now we need to complete the private subtype, but since the 20826 -- base type has already been swapped, we must also swap the 20827 -- subtypes (and thus, reverse the arguments in the call to 20828 -- Complete_Private_Subtype). Also note that we may need to 20829 -- re-establish the scope of the private subtype. 20830 20831 Copy_And_Swap (Priv, Full); 20832 20833 if not In_Open_Scopes (Priv_Scop) then 20834 Push_Scope (Priv_Scop); 20835 20836 else 20837 -- Reset Priv_Scop to Empty to indicate no scope was pushed 20838 20839 Priv_Scop := Empty; 20840 end if; 20841 20842 Complete_Private_Subtype (Full, Priv, Full_T, N); 20843 Set_Full_View (Full, Priv); 20844 20845 if Present (Priv_Scop) then 20846 Pop_Scope; 20847 end if; 20848 20849 Replace_Elmt (Priv_Elmt, Full); 20850 end if; 20851 20852 Next_Elmt (Priv_Elmt); 20853 end loop; 20854 end; 20855 20856 -- If the private view was tagged, copy the new primitive operations 20857 -- from the private view to the full view. 20858 20859 if Is_Tagged_Type (Full_T) then 20860 declare 20861 Disp_Typ : Entity_Id; 20862 Full_List : Elist_Id; 20863 Prim : Entity_Id; 20864 Prim_Elmt : Elmt_Id; 20865 Priv_List : Elist_Id; 20866 20867 function Contains 20868 (E : Entity_Id; 20869 L : Elist_Id) return Boolean; 20870 -- Determine whether list L contains element E 20871 20872 -------------- 20873 -- Contains -- 20874 -------------- 20875 20876 function Contains 20877 (E : Entity_Id; 20878 L : Elist_Id) return Boolean 20879 is 20880 List_Elmt : Elmt_Id; 20881 20882 begin 20883 List_Elmt := First_Elmt (L); 20884 while Present (List_Elmt) loop 20885 if Node (List_Elmt) = E then 20886 return True; 20887 end if; 20888 20889 Next_Elmt (List_Elmt); 20890 end loop; 20891 20892 return False; 20893 end Contains; 20894 20895 -- Start of processing 20896 20897 begin 20898 if Is_Tagged_Type (Priv_T) then 20899 Priv_List := Primitive_Operations (Priv_T); 20900 Prim_Elmt := First_Elmt (Priv_List); 20901 20902 -- In the case of a concurrent type completing a private tagged 20903 -- type, primitives may have been declared in between the two 20904 -- views. These subprograms need to be wrapped the same way 20905 -- entries and protected procedures are handled because they 20906 -- cannot be directly shared by the two views. 20907 20908 if Is_Concurrent_Type (Full_T) then 20909 declare 20910 Conc_Typ : constant Entity_Id := 20911 Corresponding_Record_Type (Full_T); 20912 Curr_Nod : Node_Id := Parent (Conc_Typ); 20913 Wrap_Spec : Node_Id; 20914 20915 begin 20916 while Present (Prim_Elmt) loop 20917 Prim := Node (Prim_Elmt); 20918 20919 if Comes_From_Source (Prim) 20920 and then not Is_Abstract_Subprogram (Prim) 20921 then 20922 Wrap_Spec := 20923 Make_Subprogram_Declaration (Sloc (Prim), 20924 Specification => 20925 Build_Wrapper_Spec 20926 (Subp_Id => Prim, 20927 Obj_Typ => Conc_Typ, 20928 Formals => 20929 Parameter_Specifications 20930 (Parent (Prim)))); 20931 20932 Insert_After (Curr_Nod, Wrap_Spec); 20933 Curr_Nod := Wrap_Spec; 20934 20935 Analyze (Wrap_Spec); 20936 20937 -- Remove the wrapper from visibility to avoid 20938 -- spurious conflict with the wrapped entity. 20939 20940 Set_Is_Immediately_Visible 20941 (Defining_Entity (Specification (Wrap_Spec)), 20942 False); 20943 end if; 20944 20945 Next_Elmt (Prim_Elmt); 20946 end loop; 20947 20948 goto Leave; 20949 end; 20950 20951 -- For non-concurrent types, transfer explicit primitives, but 20952 -- omit those inherited from the parent of the private view 20953 -- since they will be re-inherited later on. 20954 20955 else 20956 Full_List := Primitive_Operations (Full_T); 20957 while Present (Prim_Elmt) loop 20958 Prim := Node (Prim_Elmt); 20959 20960 if Comes_From_Source (Prim) 20961 and then not Contains (Prim, Full_List) 20962 then 20963 Append_Elmt (Prim, Full_List); 20964 end if; 20965 20966 Next_Elmt (Prim_Elmt); 20967 end loop; 20968 end if; 20969 20970 -- Untagged private view 20971 20972 else 20973 Full_List := Primitive_Operations (Full_T); 20974 20975 -- In this case the partial view is untagged, so here we locate 20976 -- all of the earlier primitives that need to be treated as 20977 -- dispatching (those that appear between the two views). Note 20978 -- that these additional operations must all be new operations 20979 -- (any earlier operations that override inherited operations 20980 -- of the full view will already have been inserted in the 20981 -- primitives list, marked by Check_Operation_From_Private_View 20982 -- as dispatching. Note that implicit "/=" operators are 20983 -- excluded from being added to the primitives list since they 20984 -- shouldn't be treated as dispatching (tagged "/=" is handled 20985 -- specially). 20986 20987 Prim := Next_Entity (Full_T); 20988 while Present (Prim) and then Prim /= Priv_T loop 20989 if Ekind_In (Prim, E_Procedure, E_Function) then 20990 Disp_Typ := Find_Dispatching_Type (Prim); 20991 20992 if Disp_Typ = Full_T 20993 and then (Chars (Prim) /= Name_Op_Ne 20994 or else Comes_From_Source (Prim)) 20995 then 20996 Check_Controlling_Formals (Full_T, Prim); 20997 20998 if Is_Suitable_Primitive (Prim) 20999 and then not Is_Dispatching_Operation (Prim) 21000 then 21001 Append_Elmt (Prim, Full_List); 21002 Set_Is_Dispatching_Operation (Prim); 21003 Set_DT_Position_Value (Prim, No_Uint); 21004 end if; 21005 21006 elsif Is_Dispatching_Operation (Prim) 21007 and then Disp_Typ /= Full_T 21008 then 21009 -- Verify that it is not otherwise controlled by a 21010 -- formal or a return value of type T. 21011 21012 Check_Controlling_Formals (Disp_Typ, Prim); 21013 end if; 21014 end if; 21015 21016 Next_Entity (Prim); 21017 end loop; 21018 end if; 21019 21020 -- For the tagged case, the two views can share the same primitive 21021 -- operations list and the same class-wide type. Update attributes 21022 -- of the class-wide type which depend on the full declaration. 21023 21024 if Is_Tagged_Type (Priv_T) then 21025 Set_Direct_Primitive_Operations (Priv_T, Full_List); 21026 Set_Class_Wide_Type 21027 (Base_Type (Full_T), Class_Wide_Type (Priv_T)); 21028 21029 Propagate_Concurrent_Flags (Class_Wide_Type (Priv_T), Full_T); 21030 end if; 21031 end; 21032 end if; 21033 21034 -- Ada 2005 AI 161: Check preelaborable initialization consistency 21035 21036 if Known_To_Have_Preelab_Init (Priv_T) then 21037 21038 -- Case where there is a pragma Preelaborable_Initialization. We 21039 -- always allow this in predefined units, which is cheating a bit, 21040 -- but it means we don't have to struggle to meet the requirements in 21041 -- the RM for having Preelaborable Initialization. Otherwise we 21042 -- require that the type meets the RM rules. But we can't check that 21043 -- yet, because of the rule about overriding Initialize, so we simply 21044 -- set a flag that will be checked at freeze time. 21045 21046 if not In_Predefined_Unit (Full_T) then 21047 Set_Must_Have_Preelab_Init (Full_T); 21048 end if; 21049 end if; 21050 21051 -- If pragma CPP_Class was applied to the private type declaration, 21052 -- propagate it now to the full type declaration. 21053 21054 if Is_CPP_Class (Priv_T) then 21055 Set_Is_CPP_Class (Full_T); 21056 Set_Convention (Full_T, Convention_CPP); 21057 21058 -- Check that components of imported CPP types do not have default 21059 -- expressions. 21060 21061 Check_CPP_Type_Has_No_Defaults (Full_T); 21062 end if; 21063 21064 -- If the private view has user specified stream attributes, then so has 21065 -- the full view. 21066 21067 -- Why the test, how could these flags be already set in Full_T ??? 21068 21069 if Has_Specified_Stream_Read (Priv_T) then 21070 Set_Has_Specified_Stream_Read (Full_T); 21071 end if; 21072 21073 if Has_Specified_Stream_Write (Priv_T) then 21074 Set_Has_Specified_Stream_Write (Full_T); 21075 end if; 21076 21077 if Has_Specified_Stream_Input (Priv_T) then 21078 Set_Has_Specified_Stream_Input (Full_T); 21079 end if; 21080 21081 if Has_Specified_Stream_Output (Priv_T) then 21082 Set_Has_Specified_Stream_Output (Full_T); 21083 end if; 21084 21085 -- Propagate Default_Initial_Condition-related attributes from the 21086 -- partial view to the full view and its base type. 21087 21088 Propagate_DIC_Attributes (Full_T, From_Typ => Priv_T); 21089 Propagate_DIC_Attributes (Base_Type (Full_T), From_Typ => Priv_T); 21090 21091 -- Propagate invariant-related attributes from the partial view to the 21092 -- full view and its base type. 21093 21094 Propagate_Invariant_Attributes (Full_T, From_Typ => Priv_T); 21095 Propagate_Invariant_Attributes (Base_Type (Full_T), From_Typ => Priv_T); 21096 21097 -- AI12-0041: Detect an attempt to inherit a class-wide type invariant 21098 -- in the full view without advertising the inheritance in the partial 21099 -- view. This can only occur when the partial view has no parent type 21100 -- and the full view has an interface as a parent. Any other scenarios 21101 -- are illegal because implemented interfaces must match between the 21102 -- two views. 21103 21104 if Is_Tagged_Type (Priv_T) and then Is_Tagged_Type (Full_T) then 21105 declare 21106 Full_Par : constant Entity_Id := Etype (Full_T); 21107 Priv_Par : constant Entity_Id := Etype (Priv_T); 21108 21109 begin 21110 if not Is_Interface (Priv_Par) 21111 and then Is_Interface (Full_Par) 21112 and then Has_Inheritable_Invariants (Full_Par) 21113 then 21114 Error_Msg_N 21115 ("hidden inheritance of class-wide type invariants not " 21116 & "allowed", N); 21117 end if; 21118 end; 21119 end if; 21120 21121 -- Propagate predicates to full type, and predicate function if already 21122 -- defined. It is not clear that this can actually happen? the partial 21123 -- view cannot be frozen yet, and the predicate function has not been 21124 -- built. Still it is a cheap check and seems safer to make it. 21125 21126 if Has_Predicates (Priv_T) then 21127 Set_Has_Predicates (Full_T); 21128 21129 if Present (Predicate_Function (Priv_T)) then 21130 Set_Predicate_Function (Full_T, Predicate_Function (Priv_T)); 21131 end if; 21132 end if; 21133 21134 <<Leave>> 21135 Restore_Ghost_Region (Saved_GM, Saved_IGR); 21136 end Process_Full_View; 21137 21138 ----------------------------------- 21139 -- Process_Incomplete_Dependents -- 21140 ----------------------------------- 21141 21142 procedure Process_Incomplete_Dependents 21143 (N : Node_Id; 21144 Full_T : Entity_Id; 21145 Inc_T : Entity_Id) 21146 is 21147 Inc_Elmt : Elmt_Id; 21148 Priv_Dep : Entity_Id; 21149 New_Subt : Entity_Id; 21150 21151 Disc_Constraint : Elist_Id; 21152 21153 begin 21154 if No (Private_Dependents (Inc_T)) then 21155 return; 21156 end if; 21157 21158 -- Itypes that may be generated by the completion of an incomplete 21159 -- subtype are not used by the back-end and not attached to the tree. 21160 -- They are created only for constraint-checking purposes. 21161 21162 Inc_Elmt := First_Elmt (Private_Dependents (Inc_T)); 21163 while Present (Inc_Elmt) loop 21164 Priv_Dep := Node (Inc_Elmt); 21165 21166 if Ekind (Priv_Dep) = E_Subprogram_Type then 21167 21168 -- An Access_To_Subprogram type may have a return type or a 21169 -- parameter type that is incomplete. Replace with the full view. 21170 21171 if Etype (Priv_Dep) = Inc_T then 21172 Set_Etype (Priv_Dep, Full_T); 21173 end if; 21174 21175 declare 21176 Formal : Entity_Id; 21177 21178 begin 21179 Formal := First_Formal (Priv_Dep); 21180 while Present (Formal) loop 21181 if Etype (Formal) = Inc_T then 21182 Set_Etype (Formal, Full_T); 21183 end if; 21184 21185 Next_Formal (Formal); 21186 end loop; 21187 end; 21188 21189 elsif Is_Overloadable (Priv_Dep) then 21190 21191 -- If a subprogram in the incomplete dependents list is primitive 21192 -- for a tagged full type then mark it as a dispatching operation, 21193 -- check whether it overrides an inherited subprogram, and check 21194 -- restrictions on its controlling formals. Note that a protected 21195 -- operation is never dispatching: only its wrapper operation 21196 -- (which has convention Ada) is. 21197 21198 if Is_Tagged_Type (Full_T) 21199 and then Is_Primitive (Priv_Dep) 21200 and then Convention (Priv_Dep) /= Convention_Protected 21201 then 21202 Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T); 21203 Set_Is_Dispatching_Operation (Priv_Dep); 21204 Check_Controlling_Formals (Full_T, Priv_Dep); 21205 end if; 21206 21207 elsif Ekind (Priv_Dep) = E_Subprogram_Body then 21208 21209 -- Can happen during processing of a body before the completion 21210 -- of a TA type. Ignore, because spec is also on dependent list. 21211 21212 return; 21213 21214 -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a 21215 -- corresponding subtype of the full view. 21216 21217 elsif Ekind (Priv_Dep) = E_Incomplete_Subtype 21218 and then Comes_From_Source (Priv_Dep) 21219 then 21220 Set_Subtype_Indication 21221 (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep))); 21222 Set_Etype (Priv_Dep, Full_T); 21223 Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); 21224 Set_Analyzed (Parent (Priv_Dep), False); 21225 21226 -- Reanalyze the declaration, suppressing the call to Enter_Name 21227 -- to avoid duplicate names. 21228 21229 Analyze_Subtype_Declaration 21230 (N => Parent (Priv_Dep), 21231 Skip => True); 21232 21233 -- Dependent is a subtype 21234 21235 else 21236 -- We build a new subtype indication using the full view of the 21237 -- incomplete parent. The discriminant constraints have been 21238 -- elaborated already at the point of the subtype declaration. 21239 21240 New_Subt := Create_Itype (E_Void, N); 21241 21242 if Has_Discriminants (Full_T) then 21243 Disc_Constraint := Discriminant_Constraint (Priv_Dep); 21244 else 21245 Disc_Constraint := No_Elist; 21246 end if; 21247 21248 Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N); 21249 Set_Full_View (Priv_Dep, New_Subt); 21250 end if; 21251 21252 Next_Elmt (Inc_Elmt); 21253 end loop; 21254 end Process_Incomplete_Dependents; 21255 21256 -------------------------------- 21257 -- Process_Range_Expr_In_Decl -- 21258 -------------------------------- 21259 21260 procedure Process_Range_Expr_In_Decl 21261 (R : Node_Id; 21262 T : Entity_Id; 21263 Subtyp : Entity_Id := Empty; 21264 Check_List : List_Id := Empty_List; 21265 R_Check_Off : Boolean := False; 21266 In_Iter_Schm : Boolean := False) 21267 is 21268 Lo, Hi : Node_Id; 21269 R_Checks : Check_Result; 21270 Insert_Node : Node_Id; 21271 Def_Id : Entity_Id; 21272 21273 begin 21274 Analyze_And_Resolve (R, Base_Type (T)); 21275 21276 if Nkind (R) = N_Range then 21277 21278 -- In SPARK, all ranges should be static, with the exception of the 21279 -- discrete type definition of a loop parameter specification. 21280 21281 if not In_Iter_Schm 21282 and then not Is_OK_Static_Range (R) 21283 then 21284 Check_SPARK_05_Restriction ("range should be static", R); 21285 end if; 21286 21287 Lo := Low_Bound (R); 21288 Hi := High_Bound (R); 21289 21290 -- Validity checks on the range of a quantified expression are 21291 -- delayed until the construct is transformed into a loop. 21292 21293 if Nkind (Parent (R)) = N_Loop_Parameter_Specification 21294 and then Nkind (Parent (Parent (R))) = N_Quantified_Expression 21295 then 21296 null; 21297 21298 -- We need to ensure validity of the bounds here, because if we 21299 -- go ahead and do the expansion, then the expanded code will get 21300 -- analyzed with range checks suppressed and we miss the check. 21301 21302 -- WARNING: The capture of the range bounds with xxx_FIRST/_LAST and 21303 -- the temporaries generated by routine Remove_Side_Effects by means 21304 -- of validity checks must use the same names. When a range appears 21305 -- in the parent of a generic, the range is processed with checks 21306 -- disabled as part of the generic context and with checks enabled 21307 -- for code generation purposes. This leads to link issues as the 21308 -- generic contains references to xxx_FIRST/_LAST, but the inlined 21309 -- template sees the temporaries generated by Remove_Side_Effects. 21310 21311 else 21312 Validity_Check_Range (R, Subtyp); 21313 end if; 21314 21315 -- If there were errors in the declaration, try and patch up some 21316 -- common mistakes in the bounds. The cases handled are literals 21317 -- which are Integer where the expected type is Real and vice versa. 21318 -- These corrections allow the compilation process to proceed further 21319 -- along since some basic assumptions of the format of the bounds 21320 -- are guaranteed. 21321 21322 if Etype (R) = Any_Type then 21323 if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then 21324 Rewrite (Lo, 21325 Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo)))); 21326 21327 elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then 21328 Rewrite (Hi, 21329 Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi)))); 21330 21331 elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then 21332 Rewrite (Lo, 21333 Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo)))); 21334 21335 elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then 21336 Rewrite (Hi, 21337 Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi)))); 21338 end if; 21339 21340 Set_Etype (Lo, T); 21341 Set_Etype (Hi, T); 21342 end if; 21343 21344 -- If the bounds of the range have been mistakenly given as string 21345 -- literals (perhaps in place of character literals), then an error 21346 -- has already been reported, but we rewrite the string literal as a 21347 -- bound of the range's type to avoid blowups in later processing 21348 -- that looks at static values. 21349 21350 if Nkind (Lo) = N_String_Literal then 21351 Rewrite (Lo, 21352 Make_Attribute_Reference (Sloc (Lo), 21353 Prefix => New_Occurrence_Of (T, Sloc (Lo)), 21354 Attribute_Name => Name_First)); 21355 Analyze_And_Resolve (Lo); 21356 end if; 21357 21358 if Nkind (Hi) = N_String_Literal then 21359 Rewrite (Hi, 21360 Make_Attribute_Reference (Sloc (Hi), 21361 Prefix => New_Occurrence_Of (T, Sloc (Hi)), 21362 Attribute_Name => Name_First)); 21363 Analyze_And_Resolve (Hi); 21364 end if; 21365 21366 -- If bounds aren't scalar at this point then exit, avoiding 21367 -- problems with further processing of the range in this procedure. 21368 21369 if not Is_Scalar_Type (Etype (Lo)) then 21370 return; 21371 end if; 21372 21373 -- Resolve (actually Sem_Eval) has checked that the bounds are in 21374 -- then range of the base type. Here we check whether the bounds 21375 -- are in the range of the subtype itself. Note that if the bounds 21376 -- represent the null range the Constraint_Error exception should 21377 -- not be raised. 21378 21379 -- ??? The following code should be cleaned up as follows 21380 21381 -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it 21382 -- is done in the call to Range_Check (R, T); below 21383 21384 -- 2. The use of R_Check_Off should be investigated and possibly 21385 -- removed, this would clean up things a bit. 21386 21387 if Is_Null_Range (Lo, Hi) then 21388 null; 21389 21390 else 21391 -- Capture values of bounds and generate temporaries for them 21392 -- if needed, before applying checks, since checks may cause 21393 -- duplication of the expression without forcing evaluation. 21394 21395 -- The forced evaluation removes side effects from expressions, 21396 -- which should occur also in GNATprove mode. Otherwise, we end up 21397 -- with unexpected insertions of actions at places where this is 21398 -- not supposed to occur, e.g. on default parameters of a call. 21399 21400 if Expander_Active or GNATprove_Mode then 21401 21402 -- Call Force_Evaluation to create declarations as needed to 21403 -- deal with side effects, and also create typ_FIRST/LAST 21404 -- entities for bounds if we have a subtype name. 21405 21406 -- Note: we do this transformation even if expansion is not 21407 -- active if we are in GNATprove_Mode since the transformation 21408 -- is in general required to ensure that the resulting tree has 21409 -- proper Ada semantics. 21410 21411 Force_Evaluation 21412 (Lo, Related_Id => Subtyp, Is_Low_Bound => True); 21413 Force_Evaluation 21414 (Hi, Related_Id => Subtyp, Is_High_Bound => True); 21415 end if; 21416 21417 -- We use a flag here instead of suppressing checks on the type 21418 -- because the type we check against isn't necessarily the place 21419 -- where we put the check. 21420 21421 if not R_Check_Off then 21422 R_Checks := Get_Range_Checks (R, T); 21423 21424 -- Look up tree to find an appropriate insertion point. We 21425 -- can't just use insert_actions because later processing 21426 -- depends on the insertion node. Prior to Ada 2012 the 21427 -- insertion point could only be a declaration or a loop, but 21428 -- quantified expressions can appear within any context in an 21429 -- expression, and the insertion point can be any statement, 21430 -- pragma, or declaration. 21431 21432 Insert_Node := Parent (R); 21433 while Present (Insert_Node) loop 21434 exit when 21435 Nkind (Insert_Node) in N_Declaration 21436 and then 21437 not Nkind_In 21438 (Insert_Node, N_Component_Declaration, 21439 N_Loop_Parameter_Specification, 21440 N_Function_Specification, 21441 N_Procedure_Specification); 21442 21443 exit when Nkind (Insert_Node) in N_Later_Decl_Item 21444 or else Nkind (Insert_Node) in 21445 N_Statement_Other_Than_Procedure_Call 21446 or else Nkind_In (Insert_Node, N_Procedure_Call_Statement, 21447 N_Pragma); 21448 21449 Insert_Node := Parent (Insert_Node); 21450 end loop; 21451 21452 -- Why would Type_Decl not be present??? Without this test, 21453 -- short regression tests fail. 21454 21455 if Present (Insert_Node) then 21456 21457 -- Case of loop statement. Verify that the range is part 21458 -- of the subtype indication of the iteration scheme. 21459 21460 if Nkind (Insert_Node) = N_Loop_Statement then 21461 declare 21462 Indic : Node_Id; 21463 21464 begin 21465 Indic := Parent (R); 21466 while Present (Indic) 21467 and then Nkind (Indic) /= N_Subtype_Indication 21468 loop 21469 Indic := Parent (Indic); 21470 end loop; 21471 21472 if Present (Indic) then 21473 Def_Id := Etype (Subtype_Mark (Indic)); 21474 21475 Insert_Range_Checks 21476 (R_Checks, 21477 Insert_Node, 21478 Def_Id, 21479 Sloc (Insert_Node), 21480 R, 21481 Do_Before => True); 21482 end if; 21483 end; 21484 21485 -- Insertion before a declaration. If the declaration 21486 -- includes discriminants, the list of applicable checks 21487 -- is given by the caller. 21488 21489 elsif Nkind (Insert_Node) in N_Declaration then 21490 Def_Id := Defining_Identifier (Insert_Node); 21491 21492 if (Ekind (Def_Id) = E_Record_Type 21493 and then Depends_On_Discriminant (R)) 21494 or else 21495 (Ekind (Def_Id) = E_Protected_Type 21496 and then Has_Discriminants (Def_Id)) 21497 then 21498 Append_Range_Checks 21499 (R_Checks, 21500 Check_List, Def_Id, Sloc (Insert_Node), R); 21501 21502 else 21503 Insert_Range_Checks 21504 (R_Checks, 21505 Insert_Node, Def_Id, Sloc (Insert_Node), R); 21506 21507 end if; 21508 21509 -- Insertion before a statement. Range appears in the 21510 -- context of a quantified expression. Insertion will 21511 -- take place when expression is expanded. 21512 21513 else 21514 null; 21515 end if; 21516 end if; 21517 end if; 21518 end if; 21519 21520 -- Case of other than an explicit N_Range node 21521 21522 -- The forced evaluation removes side effects from expressions, which 21523 -- should occur also in GNATprove mode. Otherwise, we end up with 21524 -- unexpected insertions of actions at places where this is not 21525 -- supposed to occur, e.g. on default parameters of a call. 21526 21527 elsif Expander_Active or GNATprove_Mode then 21528 Get_Index_Bounds (R, Lo, Hi); 21529 Force_Evaluation (Lo); 21530 Force_Evaluation (Hi); 21531 end if; 21532 end Process_Range_Expr_In_Decl; 21533 21534 -------------------------------------- 21535 -- Process_Real_Range_Specification -- 21536 -------------------------------------- 21537 21538 procedure Process_Real_Range_Specification (Def : Node_Id) is 21539 Spec : constant Node_Id := Real_Range_Specification (Def); 21540 Lo : Node_Id; 21541 Hi : Node_Id; 21542 Err : Boolean := False; 21543 21544 procedure Analyze_Bound (N : Node_Id); 21545 -- Analyze and check one bound 21546 21547 ------------------- 21548 -- Analyze_Bound -- 21549 ------------------- 21550 21551 procedure Analyze_Bound (N : Node_Id) is 21552 begin 21553 Analyze_And_Resolve (N, Any_Real); 21554 21555 if not Is_OK_Static_Expression (N) then 21556 Flag_Non_Static_Expr 21557 ("bound in real type definition is not static!", N); 21558 Err := True; 21559 end if; 21560 end Analyze_Bound; 21561 21562 -- Start of processing for Process_Real_Range_Specification 21563 21564 begin 21565 if Present (Spec) then 21566 Lo := Low_Bound (Spec); 21567 Hi := High_Bound (Spec); 21568 Analyze_Bound (Lo); 21569 Analyze_Bound (Hi); 21570 21571 -- If error, clear away junk range specification 21572 21573 if Err then 21574 Set_Real_Range_Specification (Def, Empty); 21575 end if; 21576 end if; 21577 end Process_Real_Range_Specification; 21578 21579 --------------------- 21580 -- Process_Subtype -- 21581 --------------------- 21582 21583 function Process_Subtype 21584 (S : Node_Id; 21585 Related_Nod : Node_Id; 21586 Related_Id : Entity_Id := Empty; 21587 Suffix : Character := ' ') return Entity_Id 21588 is 21589 P : Node_Id; 21590 Def_Id : Entity_Id; 21591 Error_Node : Node_Id; 21592 Full_View_Id : Entity_Id; 21593 Subtype_Mark_Id : Entity_Id; 21594 21595 May_Have_Null_Exclusion : Boolean; 21596 21597 procedure Check_Incomplete (T : Node_Id); 21598 -- Called to verify that an incomplete type is not used prematurely 21599 21600 ---------------------- 21601 -- Check_Incomplete -- 21602 ---------------------- 21603 21604 procedure Check_Incomplete (T : Node_Id) is 21605 begin 21606 -- Ada 2005 (AI-412): Incomplete subtypes are legal 21607 21608 if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type 21609 and then 21610 not (Ada_Version >= Ada_2005 21611 and then 21612 (Nkind (Parent (T)) = N_Subtype_Declaration 21613 or else (Nkind (Parent (T)) = N_Subtype_Indication 21614 and then Nkind (Parent (Parent (T))) = 21615 N_Subtype_Declaration))) 21616 then 21617 Error_Msg_N ("invalid use of type before its full declaration", T); 21618 end if; 21619 end Check_Incomplete; 21620 21621 -- Start of processing for Process_Subtype 21622 21623 begin 21624 -- Case of no constraints present 21625 21626 if Nkind (S) /= N_Subtype_Indication then 21627 Find_Type (S); 21628 21629 -- No way to proceed if the subtype indication is malformed. This 21630 -- will happen for example when the subtype indication in an object 21631 -- declaration is missing altogether and the expression is analyzed 21632 -- as if it were that indication. 21633 21634 if not Is_Entity_Name (S) then 21635 return Any_Type; 21636 end if; 21637 21638 Check_Incomplete (S); 21639 P := Parent (S); 21640 21641 -- Ada 2005 (AI-231): Static check 21642 21643 if Ada_Version >= Ada_2005 21644 and then Present (P) 21645 and then Null_Exclusion_Present (P) 21646 and then Nkind (P) /= N_Access_To_Object_Definition 21647 and then not Is_Access_Type (Entity (S)) 21648 then 21649 Error_Msg_N ("`NOT NULL` only allowed for an access type", S); 21650 end if; 21651 21652 -- The following is ugly, can't we have a range or even a flag??? 21653 21654 May_Have_Null_Exclusion := 21655 Nkind_In (P, N_Access_Definition, 21656 N_Access_Function_Definition, 21657 N_Access_Procedure_Definition, 21658 N_Access_To_Object_Definition, 21659 N_Allocator, 21660 N_Component_Definition) 21661 or else 21662 Nkind_In (P, N_Derived_Type_Definition, 21663 N_Discriminant_Specification, 21664 N_Formal_Object_Declaration, 21665 N_Object_Declaration, 21666 N_Object_Renaming_Declaration, 21667 N_Parameter_Specification, 21668 N_Subtype_Declaration); 21669 21670 -- Create an Itype that is a duplicate of Entity (S) but with the 21671 -- null-exclusion attribute. 21672 21673 if May_Have_Null_Exclusion 21674 and then Is_Access_Type (Entity (S)) 21675 and then Null_Exclusion_Present (P) 21676 21677 -- No need to check the case of an access to object definition. 21678 -- It is correct to define double not-null pointers. 21679 21680 -- Example: 21681 -- type Not_Null_Int_Ptr is not null access Integer; 21682 -- type Acc is not null access Not_Null_Int_Ptr; 21683 21684 and then Nkind (P) /= N_Access_To_Object_Definition 21685 then 21686 if Can_Never_Be_Null (Entity (S)) then 21687 case Nkind (Related_Nod) is 21688 when N_Full_Type_Declaration => 21689 if Nkind (Type_Definition (Related_Nod)) 21690 in N_Array_Type_Definition 21691 then 21692 Error_Node := 21693 Subtype_Indication 21694 (Component_Definition 21695 (Type_Definition (Related_Nod))); 21696 else 21697 Error_Node := 21698 Subtype_Indication (Type_Definition (Related_Nod)); 21699 end if; 21700 21701 when N_Subtype_Declaration => 21702 Error_Node := Subtype_Indication (Related_Nod); 21703 21704 when N_Object_Declaration => 21705 Error_Node := Object_Definition (Related_Nod); 21706 21707 when N_Component_Declaration => 21708 Error_Node := 21709 Subtype_Indication (Component_Definition (Related_Nod)); 21710 21711 when N_Allocator => 21712 Error_Node := Expression (Related_Nod); 21713 21714 when others => 21715 pragma Assert (False); 21716 Error_Node := Related_Nod; 21717 end case; 21718 21719 Error_Msg_NE 21720 ("`NOT NULL` not allowed (& already excludes null)", 21721 Error_Node, 21722 Entity (S)); 21723 end if; 21724 21725 Set_Etype (S, 21726 Create_Null_Excluding_Itype 21727 (T => Entity (S), 21728 Related_Nod => P)); 21729 Set_Entity (S, Etype (S)); 21730 end if; 21731 21732 return Entity (S); 21733 21734 -- Case of constraint present, so that we have an N_Subtype_Indication 21735 -- node (this node is created only if constraints are present). 21736 21737 else 21738 Find_Type (Subtype_Mark (S)); 21739 21740 if Nkind (Parent (S)) /= N_Access_To_Object_Definition 21741 and then not 21742 (Nkind (Parent (S)) = N_Subtype_Declaration 21743 and then Is_Itype (Defining_Identifier (Parent (S)))) 21744 then 21745 Check_Incomplete (Subtype_Mark (S)); 21746 end if; 21747 21748 P := Parent (S); 21749 Subtype_Mark_Id := Entity (Subtype_Mark (S)); 21750 21751 -- Explicit subtype declaration case 21752 21753 if Nkind (P) = N_Subtype_Declaration then 21754 Def_Id := Defining_Identifier (P); 21755 21756 -- Explicit derived type definition case 21757 21758 elsif Nkind (P) = N_Derived_Type_Definition then 21759 Def_Id := Defining_Identifier (Parent (P)); 21760 21761 -- Implicit case, the Def_Id must be created as an implicit type. 21762 -- The one exception arises in the case of concurrent types, array 21763 -- and access types, where other subsidiary implicit types may be 21764 -- created and must appear before the main implicit type. In these 21765 -- cases we leave Def_Id set to Empty as a signal that Create_Itype 21766 -- has not yet been called to create Def_Id. 21767 21768 else 21769 if Is_Array_Type (Subtype_Mark_Id) 21770 or else Is_Concurrent_Type (Subtype_Mark_Id) 21771 or else Is_Access_Type (Subtype_Mark_Id) 21772 then 21773 Def_Id := Empty; 21774 21775 -- For the other cases, we create a new unattached Itype, 21776 -- and set the indication to ensure it gets attached later. 21777 21778 else 21779 Def_Id := 21780 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 21781 end if; 21782 end if; 21783 21784 -- If the kind of constraint is invalid for this kind of type, 21785 -- then give an error, and then pretend no constraint was given. 21786 21787 if not Is_Valid_Constraint_Kind 21788 (Ekind (Subtype_Mark_Id), Nkind (Constraint (S))) 21789 then 21790 Error_Msg_N 21791 ("incorrect constraint for this kind of type", Constraint (S)); 21792 21793 Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); 21794 21795 -- Set Ekind of orphan itype, to prevent cascaded errors 21796 21797 if Present (Def_Id) then 21798 Set_Ekind (Def_Id, Ekind (Any_Type)); 21799 end if; 21800 21801 -- Make recursive call, having got rid of the bogus constraint 21802 21803 return Process_Subtype (S, Related_Nod, Related_Id, Suffix); 21804 end if; 21805 21806 -- Remaining processing depends on type. Select on Base_Type kind to 21807 -- ensure getting to the concrete type kind in the case of a private 21808 -- subtype (needed when only doing semantic analysis). 21809 21810 case Ekind (Base_Type (Subtype_Mark_Id)) is 21811 when Access_Kind => 21812 21813 -- If this is a constraint on a class-wide type, discard it. 21814 -- There is currently no way to express a partial discriminant 21815 -- constraint on a type with unknown discriminants. This is 21816 -- a pathology that the ACATS wisely decides not to test. 21817 21818 if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then 21819 if Comes_From_Source (S) then 21820 Error_Msg_N 21821 ("constraint on class-wide type ignored??", 21822 Constraint (S)); 21823 end if; 21824 21825 if Nkind (P) = N_Subtype_Declaration then 21826 Set_Subtype_Indication (P, 21827 New_Occurrence_Of (Subtype_Mark_Id, Sloc (S))); 21828 end if; 21829 21830 return Subtype_Mark_Id; 21831 end if; 21832 21833 Constrain_Access (Def_Id, S, Related_Nod); 21834 21835 if Expander_Active 21836 and then Is_Itype (Designated_Type (Def_Id)) 21837 and then Nkind (Related_Nod) = N_Subtype_Declaration 21838 and then not Is_Incomplete_Type (Designated_Type (Def_Id)) 21839 then 21840 Build_Itype_Reference 21841 (Designated_Type (Def_Id), Related_Nod); 21842 end if; 21843 21844 when Array_Kind => 21845 Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); 21846 21847 when Decimal_Fixed_Point_Kind => 21848 Constrain_Decimal (Def_Id, S); 21849 21850 when Enumeration_Kind => 21851 Constrain_Enumeration (Def_Id, S); 21852 21853 when Ordinary_Fixed_Point_Kind => 21854 Constrain_Ordinary_Fixed (Def_Id, S); 21855 21856 when Float_Kind => 21857 Constrain_Float (Def_Id, S); 21858 21859 when Integer_Kind => 21860 Constrain_Integer (Def_Id, S); 21861 21862 when Class_Wide_Kind 21863 | E_Incomplete_Type 21864 | E_Record_Subtype 21865 | E_Record_Type 21866 => 21867 Constrain_Discriminated_Type (Def_Id, S, Related_Nod); 21868 21869 if Ekind (Def_Id) = E_Incomplete_Type then 21870 Set_Private_Dependents (Def_Id, New_Elmt_List); 21871 end if; 21872 21873 when Private_Kind => 21874 21875 -- A private type with unknown discriminants may be completed 21876 -- by an unconstrained array type. 21877 21878 if Has_Unknown_Discriminants (Subtype_Mark_Id) 21879 and then Present (Full_View (Subtype_Mark_Id)) 21880 and then Is_Array_Type (Full_View (Subtype_Mark_Id)) 21881 then 21882 Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); 21883 21884 -- ... but more commonly is completed by a discriminated record 21885 -- type. 21886 21887 else 21888 Constrain_Discriminated_Type (Def_Id, S, Related_Nod); 21889 end if; 21890 21891 -- The base type may be private but Def_Id may be a full view 21892 -- in an instance. 21893 21894 if Is_Private_Type (Def_Id) then 21895 Set_Private_Dependents (Def_Id, New_Elmt_List); 21896 end if; 21897 21898 -- In case of an invalid constraint prevent further processing 21899 -- since the type constructed is missing expected fields. 21900 21901 if Etype (Def_Id) = Any_Type then 21902 return Def_Id; 21903 end if; 21904 21905 -- If the full view is that of a task with discriminants, 21906 -- we must constrain both the concurrent type and its 21907 -- corresponding record type. Otherwise we will just propagate 21908 -- the constraint to the full view, if available. 21909 21910 if Present (Full_View (Subtype_Mark_Id)) 21911 and then Has_Discriminants (Subtype_Mark_Id) 21912 and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id)) 21913 then 21914 Full_View_Id := 21915 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 21916 21917 Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id)); 21918 Constrain_Concurrent (Full_View_Id, S, 21919 Related_Nod, Related_Id, Suffix); 21920 Set_Entity (Subtype_Mark (S), Subtype_Mark_Id); 21921 Set_Full_View (Def_Id, Full_View_Id); 21922 21923 -- Introduce an explicit reference to the private subtype, 21924 -- to prevent scope anomalies in gigi if first use appears 21925 -- in a nested context, e.g. a later function body. 21926 -- Should this be generated in other contexts than a full 21927 -- type declaration? 21928 21929 if Is_Itype (Def_Id) 21930 and then 21931 Nkind (Parent (P)) = N_Full_Type_Declaration 21932 then 21933 Build_Itype_Reference (Def_Id, Parent (P)); 21934 end if; 21935 21936 else 21937 Prepare_Private_Subtype_Completion (Def_Id, Related_Nod); 21938 end if; 21939 21940 when Concurrent_Kind => 21941 Constrain_Concurrent (Def_Id, S, 21942 Related_Nod, Related_Id, Suffix); 21943 21944 when others => 21945 Error_Msg_N ("invalid subtype mark in subtype indication", S); 21946 end case; 21947 21948 -- Size, Alignment, Representation aspects and Convention are always 21949 -- inherited from the base type. 21950 21951 Set_Size_Info (Def_Id, (Subtype_Mark_Id)); 21952 Set_Rep_Info (Def_Id, (Subtype_Mark_Id)); 21953 Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); 21954 21955 -- The anonymous subtype created for the subtype indication 21956 -- inherits the predicates of the parent. 21957 21958 if Has_Predicates (Subtype_Mark_Id) then 21959 Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); 21960 21961 -- Indicate where the predicate function may be found 21962 21963 if No (Predicate_Function (Def_Id)) and then Is_Itype (Def_Id) then 21964 Set_Predicated_Parent (Def_Id, Subtype_Mark_Id); 21965 end if; 21966 end if; 21967 21968 return Def_Id; 21969 end if; 21970 end Process_Subtype; 21971 21972 ----------------------------- 21973 -- Record_Type_Declaration -- 21974 ----------------------------- 21975 21976 procedure Record_Type_Declaration 21977 (T : Entity_Id; 21978 N : Node_Id; 21979 Prev : Entity_Id) 21980 is 21981 Def : constant Node_Id := Type_Definition (N); 21982 Is_Tagged : Boolean; 21983 Tag_Comp : Entity_Id; 21984 21985 begin 21986 -- These flags must be initialized before calling Process_Discriminants 21987 -- because this routine makes use of them. 21988 21989 Set_Ekind (T, E_Record_Type); 21990 Set_Etype (T, T); 21991 Init_Size_Align (T); 21992 Set_Interfaces (T, No_Elist); 21993 Set_Stored_Constraint (T, No_Elist); 21994 Set_Default_SSO (T); 21995 Set_No_Reordering (T, No_Component_Reordering); 21996 21997 -- Normal case 21998 21999 if Ada_Version < Ada_2005 or else not Interface_Present (Def) then 22000 if Limited_Present (Def) then 22001 Check_SPARK_05_Restriction ("limited is not allowed", N); 22002 end if; 22003 22004 if Abstract_Present (Def) then 22005 Check_SPARK_05_Restriction ("abstract is not allowed", N); 22006 end if; 22007 22008 -- The flag Is_Tagged_Type might have already been set by 22009 -- Find_Type_Name if it detected an error for declaration T. This 22010 -- arises in the case of private tagged types where the full view 22011 -- omits the word tagged. 22012 22013 Is_Tagged := 22014 Tagged_Present (Def) 22015 or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T)); 22016 22017 Set_Is_Limited_Record (T, Limited_Present (Def)); 22018 22019 if Is_Tagged then 22020 Set_Is_Tagged_Type (T, True); 22021 Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); 22022 end if; 22023 22024 -- Type is abstract if full declaration carries keyword, or if 22025 -- previous partial view did. 22026 22027 Set_Is_Abstract_Type (T, Is_Abstract_Type (T) 22028 or else Abstract_Present (Def)); 22029 22030 else 22031 Check_SPARK_05_Restriction ("interface is not allowed", N); 22032 22033 Is_Tagged := True; 22034 Analyze_Interface_Declaration (T, Def); 22035 22036 if Present (Discriminant_Specifications (N)) then 22037 Error_Msg_N 22038 ("interface types cannot have discriminants", 22039 Defining_Identifier 22040 (First (Discriminant_Specifications (N)))); 22041 end if; 22042 end if; 22043 22044 -- First pass: if there are self-referential access components, 22045 -- create the required anonymous access type declarations, and if 22046 -- need be an incomplete type declaration for T itself. 22047 22048 Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def)); 22049 22050 if Ada_Version >= Ada_2005 22051 and then Present (Interface_List (Def)) 22052 then 22053 Check_Interfaces (N, Def); 22054 22055 declare 22056 Ifaces_List : Elist_Id; 22057 22058 begin 22059 -- Ada 2005 (AI-251): Collect the list of progenitors that are not 22060 -- already in the parents. 22061 22062 Collect_Interfaces 22063 (T => T, 22064 Ifaces_List => Ifaces_List, 22065 Exclude_Parents => True); 22066 22067 Set_Interfaces (T, Ifaces_List); 22068 end; 22069 end if; 22070 22071 -- Records constitute a scope for the component declarations within. 22072 -- The scope is created prior to the processing of these declarations. 22073 -- Discriminants are processed first, so that they are visible when 22074 -- processing the other components. The Ekind of the record type itself 22075 -- is set to E_Record_Type (subtypes appear as E_Record_Subtype). 22076 22077 -- Enter record scope 22078 22079 Push_Scope (T); 22080 22081 -- If an incomplete or private type declaration was already given for 22082 -- the type, then this scope already exists, and the discriminants have 22083 -- been declared within. We must verify that the full declaration 22084 -- matches the incomplete one. 22085 22086 Check_Or_Process_Discriminants (N, T, Prev); 22087 22088 Set_Is_Constrained (T, not Has_Discriminants (T)); 22089 Set_Has_Delayed_Freeze (T, True); 22090 22091 -- For tagged types add a manually analyzed component corresponding 22092 -- to the component _tag, the corresponding piece of tree will be 22093 -- expanded as part of the freezing actions if it is not a CPP_Class. 22094 22095 if Is_Tagged then 22096 22097 -- Do not add the tag unless we are in expansion mode 22098 22099 if Expander_Active then 22100 Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag); 22101 Enter_Name (Tag_Comp); 22102 22103 Set_Ekind (Tag_Comp, E_Component); 22104 Set_Is_Tag (Tag_Comp); 22105 Set_Is_Aliased (Tag_Comp); 22106 Set_Is_Independent (Tag_Comp); 22107 Set_Etype (Tag_Comp, RTE (RE_Tag)); 22108 Set_DT_Entry_Count (Tag_Comp, No_Uint); 22109 Set_Original_Record_Component (Tag_Comp, Tag_Comp); 22110 Init_Component_Location (Tag_Comp); 22111 22112 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the 22113 -- implemented interfaces. 22114 22115 if Has_Interfaces (T) then 22116 Add_Interface_Tag_Components (N, T); 22117 end if; 22118 end if; 22119 22120 Make_Class_Wide_Type (T); 22121 Set_Direct_Primitive_Operations (T, New_Elmt_List); 22122 end if; 22123 22124 -- We must suppress range checks when processing record components in 22125 -- the presence of discriminants, since we don't want spurious checks to 22126 -- be generated during their analysis, but Suppress_Range_Checks flags 22127 -- must be reset the after processing the record definition. 22128 22129 -- Note: this is the only use of Kill_Range_Checks, and is a bit odd, 22130 -- couldn't we just use the normal range check suppression method here. 22131 -- That would seem cleaner ??? 22132 22133 if Has_Discriminants (T) and then not Range_Checks_Suppressed (T) then 22134 Set_Kill_Range_Checks (T, True); 22135 Record_Type_Definition (Def, Prev); 22136 Set_Kill_Range_Checks (T, False); 22137 else 22138 Record_Type_Definition (Def, Prev); 22139 end if; 22140 22141 -- Exit from record scope 22142 22143 End_Scope; 22144 22145 -- Ada 2005 (AI-251 and AI-345): Derive the interface subprograms of all 22146 -- the implemented interfaces and associate them an aliased entity. 22147 22148 if Is_Tagged 22149 and then not Is_Empty_List (Interface_List (Def)) 22150 then 22151 Derive_Progenitor_Subprograms (T, T); 22152 end if; 22153 22154 Check_Function_Writable_Actuals (N); 22155 end Record_Type_Declaration; 22156 22157 ---------------------------- 22158 -- Record_Type_Definition -- 22159 ---------------------------- 22160 22161 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is 22162 Component : Entity_Id; 22163 Ctrl_Components : Boolean := False; 22164 Final_Storage_Only : Boolean; 22165 T : Entity_Id; 22166 22167 begin 22168 if Ekind (Prev_T) = E_Incomplete_Type then 22169 T := Full_View (Prev_T); 22170 else 22171 T := Prev_T; 22172 end if; 22173 22174 -- In SPARK, tagged types and type extensions may only be declared in 22175 -- the specification of library unit packages. 22176 22177 if Present (Def) and then Is_Tagged_Type (T) then 22178 declare 22179 Typ : Node_Id; 22180 Ctxt : Node_Id; 22181 22182 begin 22183 if Nkind (Parent (Def)) = N_Full_Type_Declaration then 22184 Typ := Parent (Def); 22185 else 22186 pragma Assert 22187 (Nkind (Parent (Def)) = N_Derived_Type_Definition); 22188 Typ := Parent (Parent (Def)); 22189 end if; 22190 22191 Ctxt := Parent (Typ); 22192 22193 if Nkind (Ctxt) = N_Package_Body 22194 and then Nkind (Parent (Ctxt)) = N_Compilation_Unit 22195 then 22196 Check_SPARK_05_Restriction 22197 ("type should be defined in package specification", Typ); 22198 22199 elsif Nkind (Ctxt) /= N_Package_Specification 22200 or else Nkind (Parent (Parent (Ctxt))) /= N_Compilation_Unit 22201 then 22202 Check_SPARK_05_Restriction 22203 ("type should be defined in library unit package", Typ); 22204 end if; 22205 end; 22206 end if; 22207 22208 Final_Storage_Only := not Is_Controlled (T); 22209 22210 -- Ada 2005: Check whether an explicit Limited is present in a derived 22211 -- type declaration. 22212 22213 if Nkind (Parent (Def)) = N_Derived_Type_Definition 22214 and then Limited_Present (Parent (Def)) 22215 then 22216 Set_Is_Limited_Record (T); 22217 end if; 22218 22219 -- If the component list of a record type is defined by the reserved 22220 -- word null and there is no discriminant part, then the record type has 22221 -- no components and all records of the type are null records (RM 3.7) 22222 -- This procedure is also called to process the extension part of a 22223 -- record extension, in which case the current scope may have inherited 22224 -- components. 22225 22226 if No (Def) 22227 or else No (Component_List (Def)) 22228 or else Null_Present (Component_List (Def)) 22229 then 22230 if not Is_Tagged_Type (T) then 22231 Check_SPARK_05_Restriction ("untagged record cannot be null", Def); 22232 end if; 22233 22234 else 22235 Analyze_Declarations (Component_Items (Component_List (Def))); 22236 22237 if Present (Variant_Part (Component_List (Def))) then 22238 Check_SPARK_05_Restriction ("variant part is not allowed", Def); 22239 Analyze (Variant_Part (Component_List (Def))); 22240 end if; 22241 end if; 22242 22243 -- After completing the semantic analysis of the record definition, 22244 -- record components, both new and inherited, are accessible. Set their 22245 -- kind accordingly. Exclude malformed itypes from illegal declarations, 22246 -- whose Ekind may be void. 22247 22248 Component := First_Entity (Current_Scope); 22249 while Present (Component) loop 22250 if Ekind (Component) = E_Void 22251 and then not Is_Itype (Component) 22252 then 22253 Set_Ekind (Component, E_Component); 22254 Init_Component_Location (Component); 22255 end if; 22256 22257 Propagate_Concurrent_Flags (T, Etype (Component)); 22258 22259 if Ekind (Component) /= E_Component then 22260 null; 22261 22262 -- Do not set Has_Controlled_Component on a class-wide equivalent 22263 -- type. See Make_CW_Equivalent_Type. 22264 22265 elsif not Is_Class_Wide_Equivalent_Type (T) 22266 and then (Has_Controlled_Component (Etype (Component)) 22267 or else (Chars (Component) /= Name_uParent 22268 and then Is_Controlled (Etype (Component)))) 22269 then 22270 Set_Has_Controlled_Component (T, True); 22271 Final_Storage_Only := 22272 Final_Storage_Only 22273 and then Finalize_Storage_Only (Etype (Component)); 22274 Ctrl_Components := True; 22275 end if; 22276 22277 Next_Entity (Component); 22278 end loop; 22279 22280 -- A Type is Finalize_Storage_Only only if all its controlled components 22281 -- are also. 22282 22283 if Ctrl_Components then 22284 Set_Finalize_Storage_Only (T, Final_Storage_Only); 22285 end if; 22286 22287 -- Place reference to end record on the proper entity, which may 22288 -- be a partial view. 22289 22290 if Present (Def) then 22291 Process_End_Label (Def, 'e', Prev_T); 22292 end if; 22293 end Record_Type_Definition; 22294 22295 ------------------------ 22296 -- Replace_Components -- 22297 ------------------------ 22298 22299 procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id) is 22300 function Process (N : Node_Id) return Traverse_Result; 22301 22302 ------------- 22303 -- Process -- 22304 ------------- 22305 22306 function Process (N : Node_Id) return Traverse_Result is 22307 Comp : Entity_Id; 22308 22309 begin 22310 if Nkind (N) = N_Discriminant_Specification then 22311 Comp := First_Discriminant (Typ); 22312 while Present (Comp) loop 22313 if Chars (Comp) = Chars (Defining_Identifier (N)) then 22314 Set_Defining_Identifier (N, Comp); 22315 exit; 22316 end if; 22317 22318 Next_Discriminant (Comp); 22319 end loop; 22320 22321 elsif Nkind (N) = N_Variant_Part then 22322 Comp := First_Discriminant (Typ); 22323 while Present (Comp) loop 22324 if Chars (Comp) = Chars (Name (N)) then 22325 Set_Entity (Name (N), Comp); 22326 exit; 22327 end if; 22328 22329 Next_Discriminant (Comp); 22330 end loop; 22331 22332 elsif Nkind (N) = N_Component_Declaration then 22333 Comp := First_Component (Typ); 22334 while Present (Comp) loop 22335 if Chars (Comp) = Chars (Defining_Identifier (N)) then 22336 Set_Defining_Identifier (N, Comp); 22337 exit; 22338 end if; 22339 22340 Next_Component (Comp); 22341 end loop; 22342 end if; 22343 22344 return OK; 22345 end Process; 22346 22347 procedure Replace is new Traverse_Proc (Process); 22348 22349 -- Start of processing for Replace_Components 22350 22351 begin 22352 Replace (Decl); 22353 end Replace_Components; 22354 22355 ------------------------------- 22356 -- Set_Completion_Referenced -- 22357 ------------------------------- 22358 22359 procedure Set_Completion_Referenced (E : Entity_Id) is 22360 begin 22361 -- If in main unit, mark entity that is a completion as referenced, 22362 -- warnings go on the partial view when needed. 22363 22364 if In_Extended_Main_Source_Unit (E) then 22365 Set_Referenced (E); 22366 end if; 22367 end Set_Completion_Referenced; 22368 22369 --------------------- 22370 -- Set_Default_SSO -- 22371 --------------------- 22372 22373 procedure Set_Default_SSO (T : Entity_Id) is 22374 begin 22375 case Opt.Default_SSO is 22376 when ' ' => 22377 null; 22378 when 'L' => 22379 Set_SSO_Set_Low_By_Default (T, True); 22380 when 'H' => 22381 Set_SSO_Set_High_By_Default (T, True); 22382 when others => 22383 raise Program_Error; 22384 end case; 22385 end Set_Default_SSO; 22386 22387 --------------------- 22388 -- Set_Fixed_Range -- 22389 --------------------- 22390 22391 -- The range for fixed-point types is complicated by the fact that we 22392 -- do not know the exact end points at the time of the declaration. This 22393 -- is true for three reasons: 22394 22395 -- A size clause may affect the fudging of the end-points. 22396 -- A small clause may affect the values of the end-points. 22397 -- We try to include the end-points if it does not affect the size. 22398 22399 -- This means that the actual end-points must be established at the 22400 -- point when the type is frozen. Meanwhile, we first narrow the range 22401 -- as permitted (so that it will fit if necessary in a small specified 22402 -- size), and then build a range subtree with these narrowed bounds. 22403 -- Set_Fixed_Range constructs the range from real literal values, and 22404 -- sets the range as the Scalar_Range of the given fixed-point type entity. 22405 22406 -- The parent of this range is set to point to the entity so that it is 22407 -- properly hooked into the tree (unlike normal Scalar_Range entries for 22408 -- other scalar types, which are just pointers to the range in the 22409 -- original tree, this would otherwise be an orphan). 22410 22411 -- The tree is left unanalyzed. When the type is frozen, the processing 22412 -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not 22413 -- analyzed, and uses this as an indication that it should complete 22414 -- work on the range (it will know the final small and size values). 22415 22416 procedure Set_Fixed_Range 22417 (E : Entity_Id; 22418 Loc : Source_Ptr; 22419 Lo : Ureal; 22420 Hi : Ureal) 22421 is 22422 S : constant Node_Id := 22423 Make_Range (Loc, 22424 Low_Bound => Make_Real_Literal (Loc, Lo), 22425 High_Bound => Make_Real_Literal (Loc, Hi)); 22426 begin 22427 Set_Scalar_Range (E, S); 22428 Set_Parent (S, E); 22429 22430 -- Before the freeze point, the bounds of a fixed point are universal 22431 -- and carry the corresponding type. 22432 22433 Set_Etype (Low_Bound (S), Universal_Real); 22434 Set_Etype (High_Bound (S), Universal_Real); 22435 end Set_Fixed_Range; 22436 22437 ---------------------------------- 22438 -- Set_Scalar_Range_For_Subtype -- 22439 ---------------------------------- 22440 22441 procedure Set_Scalar_Range_For_Subtype 22442 (Def_Id : Entity_Id; 22443 R : Node_Id; 22444 Subt : Entity_Id) 22445 is 22446 Kind : constant Entity_Kind := Ekind (Def_Id); 22447 22448 begin 22449 -- Defend against previous error 22450 22451 if Nkind (R) = N_Error then 22452 return; 22453 end if; 22454 22455 Set_Scalar_Range (Def_Id, R); 22456 22457 -- We need to link the range into the tree before resolving it so 22458 -- that types that are referenced, including importantly the subtype 22459 -- itself, are properly frozen (Freeze_Expression requires that the 22460 -- expression be properly linked into the tree). Of course if it is 22461 -- already linked in, then we do not disturb the current link. 22462 22463 if No (Parent (R)) then 22464 Set_Parent (R, Def_Id); 22465 end if; 22466 22467 -- Reset the kind of the subtype during analysis of the range, to 22468 -- catch possible premature use in the bounds themselves. 22469 22470 Set_Ekind (Def_Id, E_Void); 22471 Process_Range_Expr_In_Decl (R, Subt, Subtyp => Def_Id); 22472 Set_Ekind (Def_Id, Kind); 22473 end Set_Scalar_Range_For_Subtype; 22474 22475 -------------------------------------------------------- 22476 -- Set_Stored_Constraint_From_Discriminant_Constraint -- 22477 -------------------------------------------------------- 22478 22479 procedure Set_Stored_Constraint_From_Discriminant_Constraint 22480 (E : Entity_Id) 22481 is 22482 begin 22483 -- Make sure set if encountered during Expand_To_Stored_Constraint 22484 22485 Set_Stored_Constraint (E, No_Elist); 22486 22487 -- Give it the right value 22488 22489 if Is_Constrained (E) and then Has_Discriminants (E) then 22490 Set_Stored_Constraint (E, 22491 Expand_To_Stored_Constraint (E, Discriminant_Constraint (E))); 22492 end if; 22493 end Set_Stored_Constraint_From_Discriminant_Constraint; 22494 22495 ------------------------------------- 22496 -- Signed_Integer_Type_Declaration -- 22497 ------------------------------------- 22498 22499 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is 22500 Implicit_Base : Entity_Id; 22501 Base_Typ : Entity_Id; 22502 Lo_Val : Uint; 22503 Hi_Val : Uint; 22504 Errs : Boolean := False; 22505 Lo : Node_Id; 22506 Hi : Node_Id; 22507 22508 function Can_Derive_From (E : Entity_Id) return Boolean; 22509 -- Determine whether given bounds allow derivation from specified type 22510 22511 procedure Check_Bound (Expr : Node_Id); 22512 -- Check bound to make sure it is integral and static. If not, post 22513 -- appropriate error message and set Errs flag 22514 22515 --------------------- 22516 -- Can_Derive_From -- 22517 --------------------- 22518 22519 -- Note we check both bounds against both end values, to deal with 22520 -- strange types like ones with a range of 0 .. -12341234. 22521 22522 function Can_Derive_From (E : Entity_Id) return Boolean is 22523 Lo : constant Uint := Expr_Value (Type_Low_Bound (E)); 22524 Hi : constant Uint := Expr_Value (Type_High_Bound (E)); 22525 begin 22526 return Lo <= Lo_Val and then Lo_Val <= Hi 22527 and then 22528 Lo <= Hi_Val and then Hi_Val <= Hi; 22529 end Can_Derive_From; 22530 22531 ----------------- 22532 -- Check_Bound -- 22533 ----------------- 22534 22535 procedure Check_Bound (Expr : Node_Id) is 22536 begin 22537 -- If a range constraint is used as an integer type definition, each 22538 -- bound of the range must be defined by a static expression of some 22539 -- integer type, but the two bounds need not have the same integer 22540 -- type (Negative bounds are allowed.) (RM 3.5.4) 22541 22542 if not Is_Integer_Type (Etype (Expr)) then 22543 Error_Msg_N 22544 ("integer type definition bounds must be of integer type", Expr); 22545 Errs := True; 22546 22547 elsif not Is_OK_Static_Expression (Expr) then 22548 Flag_Non_Static_Expr 22549 ("non-static expression used for integer type bound!", Expr); 22550 Errs := True; 22551 22552 -- The bounds are folded into literals, and we set their type to be 22553 -- universal, to avoid typing difficulties: we cannot set the type 22554 -- of the literal to the new type, because this would be a forward 22555 -- reference for the back end, and if the original type is user- 22556 -- defined this can lead to spurious semantic errors (e.g. 2928-003). 22557 22558 else 22559 if Is_Entity_Name (Expr) then 22560 Fold_Uint (Expr, Expr_Value (Expr), True); 22561 end if; 22562 22563 Set_Etype (Expr, Universal_Integer); 22564 end if; 22565 end Check_Bound; 22566 22567 -- Start of processing for Signed_Integer_Type_Declaration 22568 22569 begin 22570 -- Create an anonymous base type 22571 22572 Implicit_Base := 22573 Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B'); 22574 22575 -- Analyze and check the bounds, they can be of any integer type 22576 22577 Lo := Low_Bound (Def); 22578 Hi := High_Bound (Def); 22579 22580 -- Arbitrarily use Integer as the type if either bound had an error 22581 22582 if Hi = Error or else Lo = Error then 22583 Base_Typ := Any_Integer; 22584 Set_Error_Posted (T, True); 22585 22586 -- Here both bounds are OK expressions 22587 22588 else 22589 Analyze_And_Resolve (Lo, Any_Integer); 22590 Analyze_And_Resolve (Hi, Any_Integer); 22591 22592 Check_Bound (Lo); 22593 Check_Bound (Hi); 22594 22595 if Errs then 22596 Hi := Type_High_Bound (Standard_Long_Long_Integer); 22597 Lo := Type_Low_Bound (Standard_Long_Long_Integer); 22598 end if; 22599 22600 -- Find type to derive from 22601 22602 Lo_Val := Expr_Value (Lo); 22603 Hi_Val := Expr_Value (Hi); 22604 22605 if Can_Derive_From (Standard_Short_Short_Integer) then 22606 Base_Typ := Base_Type (Standard_Short_Short_Integer); 22607 22608 elsif Can_Derive_From (Standard_Short_Integer) then 22609 Base_Typ := Base_Type (Standard_Short_Integer); 22610 22611 elsif Can_Derive_From (Standard_Integer) then 22612 Base_Typ := Base_Type (Standard_Integer); 22613 22614 elsif Can_Derive_From (Standard_Long_Integer) then 22615 Base_Typ := Base_Type (Standard_Long_Integer); 22616 22617 elsif Can_Derive_From (Standard_Long_Long_Integer) then 22618 Check_Restriction (No_Long_Long_Integers, Def); 22619 Base_Typ := Base_Type (Standard_Long_Long_Integer); 22620 22621 else 22622 Base_Typ := Base_Type (Standard_Long_Long_Integer); 22623 Error_Msg_N ("integer type definition bounds out of range", Def); 22624 Hi := Type_High_Bound (Standard_Long_Long_Integer); 22625 Lo := Type_Low_Bound (Standard_Long_Long_Integer); 22626 end if; 22627 end if; 22628 22629 -- Complete both implicit base and declared first subtype entities. The 22630 -- inheritance of the rep item chain ensures that SPARK-related pragmas 22631 -- are not clobbered when the signed integer type acts as a full view of 22632 -- a private type. 22633 22634 Set_Etype (Implicit_Base, Base_Typ); 22635 Set_Size_Info (Implicit_Base, Base_Typ); 22636 Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); 22637 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); 22638 Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); 22639 22640 Set_Ekind (T, E_Signed_Integer_Subtype); 22641 Set_Etype (T, Implicit_Base); 22642 Set_Size_Info (T, Implicit_Base); 22643 Inherit_Rep_Item_Chain (T, Implicit_Base); 22644 Set_Scalar_Range (T, Def); 22645 Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); 22646 Set_Is_Constrained (T); 22647 end Signed_Integer_Type_Declaration; 22648 22649end Sem_Ch3; 22650