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-2020, 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 Nlists; use Nlists; 49with Nmake; use Nmake; 50with Opt; use Opt; 51with Restrict; use Restrict; 52with Rident; use Rident; 53with Rtsfind; use Rtsfind; 54with Sem; use Sem; 55with Sem_Aux; use Sem_Aux; 56with Sem_Case; use Sem_Case; 57with Sem_Cat; use Sem_Cat; 58with Sem_Ch6; use Sem_Ch6; 59with Sem_Ch7; use Sem_Ch7; 60with Sem_Ch8; use Sem_Ch8; 61with Sem_Ch13; use Sem_Ch13; 62with Sem_Dim; use Sem_Dim; 63with Sem_Disp; use Sem_Disp; 64with Sem_Dist; use Sem_Dist; 65with Sem_Elab; use Sem_Elab; 66with Sem_Elim; use Sem_Elim; 67with Sem_Eval; use Sem_Eval; 68with Sem_Mech; use Sem_Mech; 69with Sem_Res; use Sem_Res; 70with Sem_Smem; use Sem_Smem; 71with Sem_Type; use Sem_Type; 72with Sem_Util; use Sem_Util; 73with Sem_Warn; use Sem_Warn; 74with Stand; use Stand; 75with Sinfo; use Sinfo; 76with Sinput; use Sinput; 77with Snames; use Snames; 78with Targparm; use Targparm; 79with Tbuild; use Tbuild; 80with Ttypes; use Ttypes; 81with Uintp; use Uintp; 82with Urealp; use Urealp; 83 84package body Sem_Ch3 is 85 86 ----------------------- 87 -- Local Subprograms -- 88 ----------------------- 89 90 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id); 91 -- Ada 2005 (AI-251): Add the tag components corresponding to all the 92 -- abstract interface types implemented by a record type or a derived 93 -- record type. 94 95 procedure Build_Access_Subprogram_Wrapper (Decl : Node_Id); 96 -- When an access-to-subprogram type has pre/postconditions, we build a 97 -- subprogram that includes these contracts and is invoked by an indirect 98 -- call through the corresponding access type. 99 100 procedure Build_Derived_Type 101 (N : Node_Id; 102 Parent_Type : Entity_Id; 103 Derived_Type : Entity_Id; 104 Is_Completion : Boolean; 105 Derive_Subps : Boolean := True); 106 -- Create and decorate a Derived_Type given the Parent_Type entity. N is 107 -- the N_Full_Type_Declaration node containing the derived type definition. 108 -- Parent_Type is the entity for the parent type in the derived type 109 -- definition and Derived_Type the actual derived type. Is_Completion must 110 -- be set to False if Derived_Type is the N_Defining_Identifier node in N 111 -- (i.e. Derived_Type = Defining_Identifier (N)). In this case N is not the 112 -- completion of a private type declaration. If Is_Completion is set to 113 -- True, N is the completion of a private type declaration and Derived_Type 114 -- is different from the defining identifier inside N (i.e. Derived_Type /= 115 -- Defining_Identifier (N)). Derive_Subps indicates whether the parent 116 -- subprograms should be derived. The only case where this parameter is 117 -- False is when Build_Derived_Type is recursively called to process an 118 -- implicit derived full type for a type derived from a private type (in 119 -- that case the subprograms must only be derived for the private view of 120 -- the type). 121 -- 122 -- ??? These flags need a bit of re-examination and re-documentation: 123 -- ??? are they both necessary (both seem related to the recursion)? 124 125 procedure Build_Derived_Access_Type 126 (N : Node_Id; 127 Parent_Type : Entity_Id; 128 Derived_Type : Entity_Id); 129 -- Subsidiary procedure to Build_Derived_Type. For a derived access type, 130 -- create an implicit base if the parent type is constrained or if the 131 -- subtype indication has a constraint. 132 133 procedure Build_Derived_Array_Type 134 (N : Node_Id; 135 Parent_Type : Entity_Id; 136 Derived_Type : Entity_Id); 137 -- Subsidiary procedure to Build_Derived_Type. For a derived array type, 138 -- create an implicit base if the parent type is constrained or if the 139 -- subtype indication has a constraint. 140 141 procedure Build_Derived_Concurrent_Type 142 (N : Node_Id; 143 Parent_Type : Entity_Id; 144 Derived_Type : Entity_Id); 145 -- Subsidiary procedure to Build_Derived_Type. For a derived task or 146 -- protected type, inherit entries and protected subprograms, check 147 -- legality of discriminant constraints if any. 148 149 procedure Build_Derived_Enumeration_Type 150 (N : Node_Id; 151 Parent_Type : Entity_Id; 152 Derived_Type : Entity_Id); 153 -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration 154 -- type, we must create a new list of literals. Types derived from 155 -- Character and [Wide_]Wide_Character are special-cased. 156 157 procedure Build_Derived_Numeric_Type 158 (N : Node_Id; 159 Parent_Type : Entity_Id; 160 Derived_Type : Entity_Id); 161 -- Subsidiary procedure to Build_Derived_Type. For numeric types, create 162 -- an anonymous base type, and propagate constraint to subtype if needed. 163 164 procedure Build_Derived_Private_Type 165 (N : Node_Id; 166 Parent_Type : Entity_Id; 167 Derived_Type : Entity_Id; 168 Is_Completion : Boolean; 169 Derive_Subps : Boolean := True); 170 -- Subsidiary procedure to Build_Derived_Type. This procedure is complex 171 -- because the parent may or may not have a completion, and the derivation 172 -- may itself be a completion. 173 174 procedure Build_Derived_Record_Type 175 (N : Node_Id; 176 Parent_Type : Entity_Id; 177 Derived_Type : Entity_Id; 178 Derive_Subps : Boolean := True); 179 -- Subsidiary procedure used for tagged and untagged record types 180 -- by Build_Derived_Type and Analyze_Private_Extension_Declaration. 181 -- All parameters are as in Build_Derived_Type except that N, in 182 -- addition to being an N_Full_Type_Declaration node, can also be an 183 -- N_Private_Extension_Declaration node. See the definition of this routine 184 -- for much more info. Derive_Subps indicates whether subprograms should be 185 -- derived from the parent type. The only case where Derive_Subps is False 186 -- is for an implicit derived full type for a type derived from a private 187 -- type (see Build_Derived_Type). 188 189 procedure Build_Discriminal (Discrim : Entity_Id); 190 -- Create the discriminal corresponding to discriminant Discrim, that is 191 -- the parameter corresponding to Discrim to be used in initialization 192 -- procedures for the type where Discrim is a discriminant. Discriminals 193 -- are not used during semantic analysis, and are not fully defined 194 -- entities until expansion. Thus they are not given a scope until 195 -- initialization procedures are built. 196 197 function Build_Discriminant_Constraints 198 (T : Entity_Id; 199 Def : Node_Id; 200 Derived_Def : Boolean := False) return Elist_Id; 201 -- Validate discriminant constraints and return the list of the constraints 202 -- in order of discriminant declarations, where T is the discriminated 203 -- unconstrained type. Def is the N_Subtype_Indication node where the 204 -- discriminants constraints for T are specified. Derived_Def is True 205 -- when building the discriminant constraints in a derived type definition 206 -- of the form "type D (...) is new T (xxx)". In this case T is the parent 207 -- type and Def is the constraint "(xxx)" on T and this routine sets the 208 -- Corresponding_Discriminant field of the discriminants in the derived 209 -- type D to point to the corresponding discriminants in the parent type T. 210 211 procedure Build_Discriminated_Subtype 212 (T : Entity_Id; 213 Def_Id : Entity_Id; 214 Elist : Elist_Id; 215 Related_Nod : Node_Id; 216 For_Access : Boolean := False); 217 -- Subsidiary procedure to Constrain_Discriminated_Type and to 218 -- Process_Incomplete_Dependents. Given 219 -- 220 -- T (a possibly discriminated base type) 221 -- Def_Id (a very partially built subtype for T), 222 -- 223 -- the call completes Def_Id to be the appropriate E_*_Subtype. 224 -- 225 -- The Elist is the list of discriminant constraints if any (it is set 226 -- to No_Elist if T is not a discriminated type, and to an empty list if 227 -- T has discriminants but there are no discriminant constraints). The 228 -- Related_Nod is the same as Decl_Node in Create_Constrained_Components. 229 -- The For_Access says whether or not this subtype is really constraining 230 -- an access type. 231 232 function Build_Scalar_Bound 233 (Bound : Node_Id; 234 Par_T : Entity_Id; 235 Der_T : Entity_Id) return Node_Id; 236 -- The bounds of a derived scalar type are conversions of the bounds of 237 -- the parent type. Optimize the representation if the bounds are literals. 238 -- Needs a more complete spec--what are the parameters exactly, and what 239 -- exactly is the returned value, and how is Bound affected??? 240 241 procedure Check_Access_Discriminant_Requires_Limited 242 (D : Node_Id; 243 Loc : Node_Id); 244 -- Check the restriction that the type to which an access discriminant 245 -- belongs must be a concurrent type or a descendant of a type with 246 -- the reserved word 'limited' in its declaration. 247 248 procedure Check_Anonymous_Access_Components 249 (Typ_Decl : Node_Id; 250 Typ : Entity_Id; 251 Prev : Entity_Id; 252 Comp_List : Node_Id); 253 -- Ada 2005 AI-382: an access component in a record definition can refer to 254 -- the enclosing record, in which case it denotes the type itself, and not 255 -- the current instance of the type. We create an anonymous access type for 256 -- the component, and flag it as an access to a component, so accessibility 257 -- checks are properly performed on it. The declaration of the access type 258 -- is placed ahead of that of the record to prevent order-of-elaboration 259 -- circularity issues in Gigi. We create an incomplete type for the record 260 -- declaration, which is the designated type of the anonymous access. 261 262 procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id); 263 -- Check that, if a new discriminant is used in a constraint defining the 264 -- parent subtype of a derivation, its subtype is statically compatible 265 -- with the subtype of the corresponding parent discriminant (RM 3.7(15)). 266 267 procedure Check_Delta_Expression (E : Node_Id); 268 -- Check that the expression represented by E is suitable for use as a 269 -- delta expression, i.e. it is of real type and is static. 270 271 procedure Check_Digits_Expression (E : Node_Id); 272 -- Check that the expression represented by E is suitable for use as a 273 -- digits expression, i.e. it is of integer type, positive and static. 274 275 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id); 276 -- Validate the initialization of an object declaration. T is the required 277 -- type, and Exp is the initialization expression. 278 279 procedure Check_Interfaces (N : Node_Id; Def : Node_Id); 280 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) 281 282 procedure Check_Or_Process_Discriminants 283 (N : Node_Id; 284 T : Entity_Id; 285 Prev : Entity_Id := Empty); 286 -- If N is the full declaration of the completion T of an incomplete or 287 -- private type, check its discriminants (which are already known to be 288 -- conformant with those of the partial view, see Find_Type_Name), 289 -- otherwise process them. Prev is the entity of the partial declaration, 290 -- if any. 291 292 procedure Check_Real_Bound (Bound : Node_Id); 293 -- Check given bound for being of real type and static. If not, post an 294 -- appropriate message, and rewrite the bound with the real literal zero. 295 296 procedure Constant_Redeclaration 297 (Id : Entity_Id; 298 N : Node_Id; 299 T : out Entity_Id); 300 -- Various checks on legality of full declaration of deferred constant. 301 -- Id is the entity for the redeclaration, N is the N_Object_Declaration, 302 -- node. The caller has not yet set any attributes of this entity. 303 304 function Contain_Interface 305 (Iface : Entity_Id; 306 Ifaces : Elist_Id) return Boolean; 307 -- Ada 2005: Determine whether Iface is present in the list Ifaces 308 309 procedure Convert_Scalar_Bounds 310 (N : Node_Id; 311 Parent_Type : Entity_Id; 312 Derived_Type : Entity_Id; 313 Loc : Source_Ptr); 314 -- For derived scalar types, convert the bounds in the type definition to 315 -- the derived type, and complete their analysis. Given a constraint of the 316 -- form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with 317 -- T'Base, the parent_type. The bounds of the derived type (the anonymous 318 -- base) are copies of Lo and Hi. Finally, the bounds of the derived 319 -- subtype are conversions of those bounds to the derived_type, so that 320 -- their typing is consistent. 321 322 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id); 323 -- Copies attributes from array base type T2 to array base type T1. Copies 324 -- only attributes that apply to base types, but not subtypes. 325 326 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id); 327 -- Copies attributes from array subtype T2 to array subtype T1. Copies 328 -- attributes that apply to both subtypes and base types. 329 330 procedure Create_Constrained_Components 331 (Subt : Entity_Id; 332 Decl_Node : Node_Id; 333 Typ : Entity_Id; 334 Constraints : Elist_Id); 335 -- Build the list of entities for a constrained discriminated record 336 -- subtype. If a component depends on a discriminant, replace its subtype 337 -- using the discriminant values in the discriminant constraint. Subt 338 -- is the defining identifier for the subtype whose list of constrained 339 -- entities we will create. Decl_Node is the type declaration node where 340 -- we will attach all the itypes created. Typ is the base discriminated 341 -- type for the subtype Subt. Constraints is the list of discriminant 342 -- constraints for Typ. 343 344 function Constrain_Component_Type 345 (Comp : Entity_Id; 346 Constrained_Typ : Entity_Id; 347 Related_Node : Node_Id; 348 Typ : Entity_Id; 349 Constraints : Elist_Id) return Entity_Id; 350 -- Given a discriminated base type Typ, a list of discriminant constraints, 351 -- Constraints, for Typ and a component Comp of Typ, create and return the 352 -- type corresponding to Etype (Comp) where all discriminant references 353 -- are replaced with the corresponding constraint. If Etype (Comp) contains 354 -- no discriminant references then it is returned as-is. Constrained_Typ 355 -- is the final constrained subtype to which the constrained component 356 -- belongs. Related_Node is the node where we attach all created itypes. 357 358 procedure Constrain_Access 359 (Def_Id : in out Entity_Id; 360 S : Node_Id; 361 Related_Nod : Node_Id); 362 -- Apply a list of constraints to an access type. If Def_Id is empty, it is 363 -- an anonymous type created for a subtype indication. In that case it is 364 -- created in the procedure and attached to Related_Nod. 365 366 procedure Constrain_Array 367 (Def_Id : in out Entity_Id; 368 SI : Node_Id; 369 Related_Nod : Node_Id; 370 Related_Id : Entity_Id; 371 Suffix : Character); 372 -- Apply a list of index constraints to an unconstrained array type. The 373 -- first parameter is the entity for the resulting subtype. A value of 374 -- Empty for Def_Id indicates that an implicit type must be created, but 375 -- creation is delayed (and must be done by this procedure) because other 376 -- subsidiary implicit types must be created first (which is why Def_Id 377 -- is an in/out parameter). The second parameter is a subtype indication 378 -- node for the constrained array to be created (e.g. something of the 379 -- form string (1 .. 10)). Related_Nod gives the place where this type 380 -- has to be inserted in the tree. The Related_Id and Suffix parameters 381 -- are used to build the associated Implicit type name. 382 383 procedure Constrain_Concurrent 384 (Def_Id : in out Entity_Id; 385 SI : Node_Id; 386 Related_Nod : Node_Id; 387 Related_Id : Entity_Id; 388 Suffix : Character); 389 -- Apply list of discriminant constraints to an unconstrained concurrent 390 -- type. 391 -- 392 -- SI is the N_Subtype_Indication node containing the constraint and 393 -- the unconstrained type to constrain. 394 -- 395 -- Def_Id is the entity for the resulting constrained subtype. A value 396 -- of Empty for Def_Id indicates that an implicit type must be created, 397 -- but creation is delayed (and must be done by this procedure) because 398 -- other subsidiary implicit types must be created first (which is why 399 -- Def_Id is an in/out parameter). 400 -- 401 -- Related_Nod gives the place where this type has to be inserted 402 -- in the tree. 403 -- 404 -- The last two arguments are used to create its external name if needed. 405 406 function Constrain_Corresponding_Record 407 (Prot_Subt : Entity_Id; 408 Corr_Rec : Entity_Id; 409 Related_Nod : Node_Id) return Entity_Id; 410 -- When constraining a protected type or task type with discriminants, 411 -- constrain the corresponding record with the same discriminant values. 412 413 procedure Constrain_Decimal (Def_Id : Entity_Id; S : Node_Id); 414 -- Constrain a decimal fixed point type with a digits constraint and/or a 415 -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity. 416 417 procedure Constrain_Discriminated_Type 418 (Def_Id : Entity_Id; 419 S : Node_Id; 420 Related_Nod : Node_Id; 421 For_Access : Boolean := False); 422 -- Process discriminant constraints of composite type. Verify that values 423 -- have been provided for all discriminants, that the original type is 424 -- unconstrained, and that the types of the supplied expressions match 425 -- the discriminant types. The first three parameters are like in routine 426 -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation 427 -- of For_Access. 428 429 procedure Constrain_Enumeration (Def_Id : Entity_Id; S : Node_Id); 430 -- Constrain an enumeration type with a range constraint. This is identical 431 -- to Constrain_Integer, but for the Ekind of the resulting subtype. 432 433 procedure Constrain_Float (Def_Id : Entity_Id; S : Node_Id); 434 -- Constrain a floating point type with either a digits constraint 435 -- and/or a range constraint, building a E_Floating_Point_Subtype. 436 437 procedure Constrain_Index 438 (Index : Node_Id; 439 S : Node_Id; 440 Related_Nod : Node_Id; 441 Related_Id : Entity_Id; 442 Suffix : Character; 443 Suffix_Index : Pos); 444 -- Process an index constraint S in a constrained array declaration. The 445 -- constraint can be a subtype name, or a range with or without an explicit 446 -- subtype mark. The index is the corresponding index of the unconstrained 447 -- array. The Related_Id and Suffix parameters are used to build the 448 -- associated Implicit type name. 449 450 procedure Constrain_Integer (Def_Id : Entity_Id; S : Node_Id); 451 -- Build subtype of a signed or modular integer type 452 453 procedure Constrain_Ordinary_Fixed (Def_Id : Entity_Id; S : Node_Id); 454 -- Constrain an ordinary fixed point type with a range constraint, and 455 -- build an E_Ordinary_Fixed_Point_Subtype entity. 456 457 procedure Copy_And_Swap (Priv, Full : Entity_Id); 458 -- Copy the Priv entity into the entity of its full declaration then swap 459 -- the two entities in such a manner that the former private type is now 460 -- seen as a full type. 461 462 procedure Decimal_Fixed_Point_Type_Declaration 463 (T : Entity_Id; 464 Def : Node_Id); 465 -- Create a new decimal fixed point type, and apply the constraint to 466 -- obtain a subtype of this new type. 467 468 procedure Complete_Private_Subtype 469 (Priv : Entity_Id; 470 Full : Entity_Id; 471 Full_Base : Entity_Id; 472 Related_Nod : Node_Id); 473 -- Complete the implicit full view of a private subtype by setting the 474 -- appropriate semantic fields. If the full view of the parent is a record 475 -- type, build constrained components of subtype. 476 477 procedure Derive_Progenitor_Subprograms 478 (Parent_Type : Entity_Id; 479 Tagged_Type : Entity_Id); 480 -- Ada 2005 (AI-251): To complete type derivation, collect the primitive 481 -- operations of progenitors of Tagged_Type, and replace the subsidiary 482 -- subtypes with Tagged_Type, to build the specs of the inherited interface 483 -- primitives. The derived primitives are aliased to those of the 484 -- interface. This routine takes care also of transferring to the full view 485 -- subprograms associated with the partial view of Tagged_Type that cover 486 -- interface primitives. 487 488 procedure Derived_Standard_Character 489 (N : Node_Id; 490 Parent_Type : Entity_Id; 491 Derived_Type : Entity_Id); 492 -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles 493 -- derivations from types Standard.Character and Standard.Wide_Character. 494 495 procedure Derived_Type_Declaration 496 (T : Entity_Id; 497 N : Node_Id; 498 Is_Completion : Boolean); 499 -- Process a derived type declaration. Build_Derived_Type is invoked 500 -- to process the actual derived type definition. Parameters N and 501 -- Is_Completion have the same meaning as in Build_Derived_Type. 502 -- T is the N_Defining_Identifier for the entity defined in the 503 -- N_Full_Type_Declaration node N, that is T is the derived type. 504 505 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id); 506 -- Insert each literal in symbol table, as an overloadable identifier. Each 507 -- enumeration type is mapped into a sequence of integers, and each literal 508 -- is defined as a constant with integer value. If any of the literals are 509 -- character literals, the type is a character type, which means that 510 -- strings are legal aggregates for arrays of components of the type. 511 512 function Expand_To_Stored_Constraint 513 (Typ : Entity_Id; 514 Constraint : Elist_Id) return Elist_Id; 515 -- Given a constraint (i.e. a list of expressions) on the discriminants of 516 -- Typ, expand it into a constraint on the stored discriminants and return 517 -- the new list of expressions constraining the stored discriminants. 518 519 function Find_Type_Of_Object 520 (Obj_Def : Node_Id; 521 Related_Nod : Node_Id) return Entity_Id; 522 -- Get type entity for object referenced by Obj_Def, attaching the implicit 523 -- types generated to Related_Nod. 524 525 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id); 526 -- Create a new float and apply the constraint to obtain subtype of it 527 528 function Has_Range_Constraint (N : Node_Id) return Boolean; 529 -- Given an N_Subtype_Indication node N, return True if a range constraint 530 -- is present, either directly, or as part of a digits or delta constraint. 531 -- In addition, a digits constraint in the decimal case returns True, since 532 -- it establishes a default range if no explicit range is present. 533 534 function Inherit_Components 535 (N : Node_Id; 536 Parent_Base : Entity_Id; 537 Derived_Base : Entity_Id; 538 Is_Tagged : Boolean; 539 Inherit_Discr : Boolean; 540 Discs : Elist_Id) return Elist_Id; 541 -- Called from Build_Derived_Record_Type to inherit the components of 542 -- Parent_Base (a base type) into the Derived_Base (the derived base type). 543 -- For more information on derived types and component inheritance please 544 -- consult the comment above the body of Build_Derived_Record_Type. 545 -- 546 -- N is the original derived type declaration 547 -- 548 -- Is_Tagged is set if we are dealing with tagged types 549 -- 550 -- If Inherit_Discr is set, Derived_Base inherits its discriminants from 551 -- Parent_Base, otherwise no discriminants are inherited. 552 -- 553 -- Discs gives the list of constraints that apply to Parent_Base in the 554 -- derived type declaration. If Discs is set to No_Elist, then we have 555 -- the following situation: 556 -- 557 -- type Parent (D1..Dn : ..) is [tagged] record ...; 558 -- type Derived is new Parent [with ...]; 559 -- 560 -- which gets treated as 561 -- 562 -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...]; 563 -- 564 -- For untagged types the returned value is an association list. The list 565 -- starts from the association (Parent_Base => Derived_Base), and then it 566 -- contains a sequence of the associations of the form 567 -- 568 -- (Old_Component => New_Component), 569 -- 570 -- where Old_Component is the Entity_Id of a component in Parent_Base and 571 -- New_Component is the Entity_Id of the corresponding component in 572 -- Derived_Base. For untagged records, this association list is needed when 573 -- copying the record declaration for the derived base. In the tagged case 574 -- the value returned is irrelevant. 575 576 function Is_EVF_Procedure (Subp : Entity_Id) return Boolean; 577 -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram. 578 -- Determine whether subprogram Subp is a procedure subject to pragma 579 -- Extensions_Visible with value False and has at least one controlling 580 -- parameter of mode OUT. 581 582 function Is_Private_Primitive (Prim : Entity_Id) return Boolean; 583 -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram. 584 -- When applied to a primitive subprogram Prim, returns True if Prim is 585 -- declared as a private operation within a package or generic package, 586 -- and returns False otherwise. 587 588 function Is_Valid_Constraint_Kind 589 (T_Kind : Type_Kind; 590 Constraint_Kind : Node_Kind) return Boolean; 591 -- Returns True if it is legal to apply the given kind of constraint to the 592 -- given kind of type (index constraint to an array type, for example). 593 594 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id); 595 -- Create new modular type. Verify that modulus is in bounds 596 597 procedure New_Concatenation_Op (Typ : Entity_Id); 598 -- Create an abbreviated declaration for an operator in order to 599 -- materialize concatenation on array types. 600 601 procedure Ordinary_Fixed_Point_Type_Declaration 602 (T : Entity_Id; 603 Def : Node_Id); 604 -- Create a new ordinary fixed point type, and apply the constraint to 605 -- obtain subtype of it. 606 607 procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id); 608 -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that 609 -- In_Default_Expr can be properly adjusted. 610 611 procedure Prepare_Private_Subtype_Completion 612 (Id : Entity_Id; 613 Related_Nod : Node_Id); 614 -- Id is a subtype of some private type. Creates the full declaration 615 -- associated with Id whenever possible, i.e. when the full declaration 616 -- of the base type is already known. Records each subtype into 617 -- Private_Dependents of the base type. 618 619 procedure Process_Incomplete_Dependents 620 (N : Node_Id; 621 Full_T : Entity_Id; 622 Inc_T : Entity_Id); 623 -- Process all entities that depend on an incomplete type. There include 624 -- subtypes, subprogram types that mention the incomplete type in their 625 -- profiles, and subprogram with access parameters that designate the 626 -- incomplete type. 627 628 -- Inc_T is the defining identifier of an incomplete type declaration, its 629 -- Ekind is E_Incomplete_Type. 630 -- 631 -- N is the corresponding N_Full_Type_Declaration for Inc_T. 632 -- 633 -- Full_T is N's defining identifier. 634 -- 635 -- Subtypes of incomplete types with discriminants are completed when the 636 -- parent type is. This is simpler than private subtypes, because they can 637 -- only appear in the same scope, and there is no need to exchange views. 638 -- Similarly, access_to_subprogram types may have a parameter or a return 639 -- type that is an incomplete type, and that must be replaced with the 640 -- full type. 641 -- 642 -- If the full type is tagged, subprogram with access parameters that 643 -- designated the incomplete may be primitive operations of the full type, 644 -- and have to be processed accordingly. 645 646 procedure Process_Real_Range_Specification (Def : Node_Id); 647 -- Given the type definition for a real type, this procedure processes and 648 -- checks the real range specification of this type definition if one is 649 -- present. If errors are found, error messages are posted, and the 650 -- Real_Range_Specification of Def is reset to Empty. 651 652 procedure Record_Type_Declaration 653 (T : Entity_Id; 654 N : Node_Id; 655 Prev : Entity_Id); 656 -- Process a record type declaration (for both untagged and tagged 657 -- records). Parameters T and N are exactly like in procedure 658 -- Derived_Type_Declaration, except that no flag Is_Completion is needed 659 -- for this routine. If this is the completion of an incomplete type 660 -- declaration, Prev is the entity of the incomplete declaration, used for 661 -- cross-referencing. Otherwise Prev = T. 662 663 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id); 664 -- This routine is used to process the actual record type definition (both 665 -- for untagged and tagged records). Def is a record type definition node. 666 -- This procedure analyzes the components in this record type definition. 667 -- Prev_T is the entity for the enclosing record type. It is provided so 668 -- that its Has_Task flag can be set if any of the component have Has_Task 669 -- set. If the declaration is the completion of an incomplete type 670 -- declaration, Prev_T is the original incomplete type, whose full view is 671 -- the record type. 672 673 procedure Replace_Discriminants (Typ : Entity_Id; Decl : Node_Id); 674 -- Subsidiary to Build_Derived_Record_Type. For untagged record types, we 675 -- first create the list of components for the derived type from that of 676 -- the parent by means of Inherit_Components and then build a copy of the 677 -- declaration tree of the parent with the help of the mapping returned by 678 -- Inherit_Components, which will for example be used to validate record 679 -- representation clauses given for the derived type. If the parent type 680 -- is private and has discriminants, the ancestor discriminants used in the 681 -- inheritance are that of the private declaration, whereas the ancestor 682 -- discriminants present in the declaration tree of the parent are that of 683 -- the full declaration; as a consequence, the remapping done during the 684 -- copy will leave the references to the ancestor discriminants unchanged 685 -- in the declaration tree and they need to be fixed up. If the derived 686 -- type has a known discriminant part, then the remapping done during the 687 -- copy will only create references to the girder discriminants and they 688 -- need to be replaced with references to the non-girder discriminants. 689 690 procedure Set_Fixed_Range 691 (E : Entity_Id; 692 Loc : Source_Ptr; 693 Lo : Ureal; 694 Hi : Ureal); 695 -- Build a range node with the given bounds and set it as the Scalar_Range 696 -- of the given fixed-point type entity. Loc is the source location used 697 -- for the constructed range. See body for further details. 698 699 procedure Set_Scalar_Range_For_Subtype 700 (Def_Id : Entity_Id; 701 R : Node_Id; 702 Subt : Entity_Id); 703 -- This routine is used to set the scalar range field for a subtype given 704 -- Def_Id, the entity for the subtype, and R, the range expression for the 705 -- scalar range. Subt provides the parent subtype to be used to analyze, 706 -- resolve, and check the given range. 707 708 procedure Set_Default_SSO (T : Entity_Id); 709 -- T is the entity for an array or record being declared. This procedure 710 -- sets the flags SSO_Set_Low_By_Default/SSO_Set_High_By_Default according 711 -- to the setting of Opt.Default_SSO. 712 713 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id); 714 -- Create a new signed integer entity, and apply the constraint to obtain 715 -- the required first named subtype of this type. 716 717 procedure Set_Stored_Constraint_From_Discriminant_Constraint 718 (E : Entity_Id); 719 -- E is some record type. This routine computes E's Stored_Constraint 720 -- from its Discriminant_Constraint. 721 722 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id); 723 -- Check that an entity in a list of progenitors is an interface, 724 -- emit error otherwise. 725 726 ----------------------- 727 -- Access_Definition -- 728 ----------------------- 729 730 function Access_Definition 731 (Related_Nod : Node_Id; 732 N : Node_Id) return Entity_Id 733 is 734 Anon_Type : Entity_Id; 735 Anon_Scope : Entity_Id; 736 Desig_Type : Entity_Id; 737 Enclosing_Prot_Type : Entity_Id := Empty; 738 739 begin 740 if Is_Entry (Current_Scope) 741 and then Is_Task_Type (Etype (Scope (Current_Scope))) 742 then 743 Error_Msg_N ("task entries cannot have access parameters", N); 744 return Empty; 745 end if; 746 747 -- Ada 2005: For an object declaration the corresponding anonymous 748 -- type is declared in the current scope. 749 750 -- If the access definition is the return type of another access to 751 -- function, scope is the current one, because it is the one of the 752 -- current type declaration, except for the pathological case below. 753 754 if Nkind (Related_Nod) in 755 N_Object_Declaration | N_Access_Function_Definition 756 then 757 Anon_Scope := Current_Scope; 758 759 -- A pathological case: function returning access functions that 760 -- return access functions, etc. Each anonymous access type created 761 -- is in the enclosing scope of the outermost function. 762 763 declare 764 Par : Node_Id; 765 766 begin 767 Par := Related_Nod; 768 while Nkind (Par) in 769 N_Access_Function_Definition | N_Access_Definition 770 loop 771 Par := Parent (Par); 772 end loop; 773 774 if Nkind (Par) = N_Function_Specification then 775 Anon_Scope := Scope (Defining_Entity (Par)); 776 end if; 777 end; 778 779 -- For the anonymous function result case, retrieve the scope of the 780 -- function specification's associated entity rather than using the 781 -- current scope. The current scope will be the function itself if the 782 -- formal part is currently being analyzed, but will be the parent scope 783 -- in the case of a parameterless function, and we always want to use 784 -- the function's parent scope. Finally, if the function is a child 785 -- unit, we must traverse the tree to retrieve the proper entity. 786 787 elsif Nkind (Related_Nod) = N_Function_Specification 788 and then Nkind (Parent (N)) /= N_Parameter_Specification 789 then 790 -- If the current scope is a protected type, the anonymous access 791 -- is associated with one of the protected operations, and must 792 -- be available in the scope that encloses the protected declaration. 793 -- Otherwise the type is in the scope enclosing the subprogram. 794 795 -- If the function has formals, the return type of a subprogram 796 -- declaration is analyzed in the scope of the subprogram (see 797 -- Process_Formals) and thus the protected type, if present, is 798 -- the scope of the current function scope. 799 800 if Ekind (Current_Scope) = E_Protected_Type then 801 Enclosing_Prot_Type := Current_Scope; 802 803 elsif Ekind (Current_Scope) = E_Function 804 and then Ekind (Scope (Current_Scope)) = E_Protected_Type 805 then 806 Enclosing_Prot_Type := Scope (Current_Scope); 807 end if; 808 809 if Present (Enclosing_Prot_Type) then 810 Anon_Scope := Scope (Enclosing_Prot_Type); 811 812 else 813 Anon_Scope := Scope (Defining_Entity (Related_Nod)); 814 end if; 815 816 -- For an access type definition, if the current scope is a child 817 -- unit it is the scope of the type. 818 819 elsif Is_Compilation_Unit (Current_Scope) then 820 Anon_Scope := Current_Scope; 821 822 -- For access formals, access components, and access discriminants, the 823 -- scope is that of the enclosing declaration, 824 825 else 826 Anon_Scope := Scope (Current_Scope); 827 end if; 828 829 Anon_Type := 830 Create_Itype 831 (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); 832 833 if All_Present (N) 834 and then Ada_Version >= Ada_2005 835 then 836 Error_Msg_N ("ALL not permitted for anonymous access types", N); 837 end if; 838 839 -- Ada 2005 (AI-254): In case of anonymous access to subprograms call 840 -- the corresponding semantic routine 841 842 if Present (Access_To_Subprogram_Definition (N)) then 843 844 -- Compiler runtime units are compiled in Ada 2005 mode when building 845 -- the runtime library but must also be compilable in Ada 95 mode 846 -- (when bootstrapping the compiler). 847 848 Check_Compiler_Unit ("anonymous access to subprogram", N); 849 850 Access_Subprogram_Declaration 851 (T_Name => Anon_Type, 852 T_Def => Access_To_Subprogram_Definition (N)); 853 854 if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then 855 Set_Ekind 856 (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type); 857 else 858 Set_Ekind (Anon_Type, E_Anonymous_Access_Subprogram_Type); 859 end if; 860 861 Set_Can_Use_Internal_Rep 862 (Anon_Type, not Always_Compatible_Rep_On_Target); 863 864 -- If the anonymous access is associated with a protected operation, 865 -- create a reference to it after the enclosing protected definition 866 -- because the itype will be used in the subsequent bodies. 867 868 -- If the anonymous access itself is protected, a full type 869 -- declaratiton will be created for it, so that the equivalent 870 -- record type can be constructed. For further details, see 871 -- Replace_Anonymous_Access_To_Protected-Subprogram. 872 873 if Ekind (Current_Scope) = E_Protected_Type 874 and then not Protected_Present (Access_To_Subprogram_Definition (N)) 875 then 876 Build_Itype_Reference (Anon_Type, Parent (Current_Scope)); 877 end if; 878 879 return Anon_Type; 880 end if; 881 882 Find_Type (Subtype_Mark (N)); 883 Desig_Type := Entity (Subtype_Mark (N)); 884 885 Set_Directly_Designated_Type (Anon_Type, Desig_Type); 886 Set_Etype (Anon_Type, Anon_Type); 887 888 -- Make sure the anonymous access type has size and alignment fields 889 -- set, as required by gigi. This is necessary in the case of the 890 -- Task_Body_Procedure. 891 892 if not Has_Private_Component (Desig_Type) then 893 Layout_Type (Anon_Type); 894 end if; 895 896 -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs 897 -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if 898 -- the null value is allowed. In Ada 95 the null value is never allowed. 899 900 if Ada_Version >= Ada_2005 then 901 Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N)); 902 else 903 Set_Can_Never_Be_Null (Anon_Type, True); 904 end if; 905 906 -- The anonymous access type is as public as the discriminated type or 907 -- subprogram that defines it. It is imported (for back-end purposes) 908 -- if the designated type is. 909 910 Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type))); 911 912 -- Ada 2005 (AI-231): Propagate the access-constant attribute 913 914 Set_Is_Access_Constant (Anon_Type, Constant_Present (N)); 915 916 -- The context is either a subprogram declaration, object declaration, 917 -- or an access discriminant, in a private or a full type declaration. 918 -- In the case of a subprogram, if the designated type is incomplete, 919 -- the operation will be a primitive operation of the full type, to be 920 -- updated subsequently. If the type is imported through a limited_with 921 -- clause, the subprogram is not a primitive operation of the type 922 -- (which is declared elsewhere in some other scope). 923 924 if Ekind (Desig_Type) = E_Incomplete_Type 925 and then not From_Limited_With (Desig_Type) 926 and then Is_Overloadable (Current_Scope) 927 then 928 Append_Elmt (Current_Scope, Private_Dependents (Desig_Type)); 929 Set_Has_Delayed_Freeze (Current_Scope); 930 end if; 931 932 -- If the designated type is limited and class-wide, the object might 933 -- contain tasks, so we create a Master entity for the declaration. This 934 -- must be done before expansion of the full declaration, because the 935 -- declaration may include an expression that is an allocator, whose 936 -- expansion needs the proper Master for the created tasks. 937 938 if Expander_Active 939 and then Nkind (Related_Nod) = N_Object_Declaration 940 then 941 if Is_Limited_Record (Desig_Type) 942 and then Is_Class_Wide_Type (Desig_Type) 943 then 944 Build_Class_Wide_Master (Anon_Type); 945 946 -- Similarly, if the type is an anonymous access that designates 947 -- tasks, create a master entity for it in the current context. 948 949 elsif Has_Task (Desig_Type) 950 and then Comes_From_Source (Related_Nod) 951 then 952 Build_Master_Entity (Defining_Identifier (Related_Nod)); 953 Build_Master_Renaming (Anon_Type); 954 end if; 955 end if; 956 957 -- For a private component of a protected type, it is imperative that 958 -- the back-end elaborate the type immediately after the protected 959 -- declaration, because this type will be used in the declarations 960 -- created for the component within each protected body, so we must 961 -- create an itype reference for it now. 962 963 if Nkind (Parent (Related_Nod)) = N_Protected_Definition then 964 Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod))); 965 966 -- Similarly, if the access definition is the return result of a 967 -- function, create an itype reference for it because it will be used 968 -- within the function body. For a regular function that is not a 969 -- compilation unit, insert reference after the declaration. For a 970 -- protected operation, insert it after the enclosing protected type 971 -- declaration. In either case, do not create a reference for a type 972 -- obtained through a limited_with clause, because this would introduce 973 -- semantic dependencies. 974 975 -- Similarly, do not create a reference if the designated type is a 976 -- generic formal, because no use of it will reach the backend. 977 978 elsif Nkind (Related_Nod) = N_Function_Specification 979 and then not From_Limited_With (Desig_Type) 980 and then not Is_Generic_Type (Desig_Type) 981 then 982 if Present (Enclosing_Prot_Type) then 983 Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type)); 984 985 elsif Is_List_Member (Parent (Related_Nod)) 986 and then Nkind (Parent (N)) /= N_Parameter_Specification 987 then 988 Build_Itype_Reference (Anon_Type, Parent (Related_Nod)); 989 end if; 990 991 -- Finally, create an itype reference for an object declaration of an 992 -- anonymous access type. This is strictly necessary only for deferred 993 -- constants, but in any case will avoid out-of-scope problems in the 994 -- back-end. 995 996 elsif Nkind (Related_Nod) = N_Object_Declaration then 997 Build_Itype_Reference (Anon_Type, Related_Nod); 998 end if; 999 1000 return Anon_Type; 1001 end Access_Definition; 1002 1003 ----------------------------------- 1004 -- Access_Subprogram_Declaration -- 1005 ----------------------------------- 1006 1007 procedure Access_Subprogram_Declaration 1008 (T_Name : Entity_Id; 1009 T_Def : Node_Id) 1010 is 1011 procedure Check_For_Premature_Usage (Def : Node_Id); 1012 -- Check that type T_Name is not used, directly or recursively, as a 1013 -- parameter or a return type in Def. Def is either a subtype, an 1014 -- access_definition, or an access_to_subprogram_definition. 1015 1016 ------------------------------- 1017 -- Check_For_Premature_Usage -- 1018 ------------------------------- 1019 1020 procedure Check_For_Premature_Usage (Def : Node_Id) is 1021 Param : Node_Id; 1022 1023 begin 1024 -- Check for a subtype mark 1025 1026 if Nkind (Def) in N_Has_Etype then 1027 if Etype (Def) = T_Name then 1028 Error_Msg_N 1029 ("type& cannot be used before the end of its declaration", 1030 Def); 1031 end if; 1032 1033 -- If this is not a subtype, then this is an access_definition 1034 1035 elsif Nkind (Def) = N_Access_Definition then 1036 if Present (Access_To_Subprogram_Definition (Def)) then 1037 Check_For_Premature_Usage 1038 (Access_To_Subprogram_Definition (Def)); 1039 else 1040 Check_For_Premature_Usage (Subtype_Mark (Def)); 1041 end if; 1042 1043 -- The only cases left are N_Access_Function_Definition and 1044 -- N_Access_Procedure_Definition. 1045 1046 else 1047 if Present (Parameter_Specifications (Def)) then 1048 Param := First (Parameter_Specifications (Def)); 1049 while Present (Param) loop 1050 Check_For_Premature_Usage (Parameter_Type (Param)); 1051 Next (Param); 1052 end loop; 1053 end if; 1054 1055 if Nkind (Def) = N_Access_Function_Definition then 1056 Check_For_Premature_Usage (Result_Definition (Def)); 1057 end if; 1058 end if; 1059 end Check_For_Premature_Usage; 1060 1061 -- Local variables 1062 1063 Formals : constant List_Id := Parameter_Specifications (T_Def); 1064 Formal : Entity_Id; 1065 D_Ityp : Node_Id; 1066 Desig_Type : constant Entity_Id := 1067 Create_Itype (E_Subprogram_Type, Parent (T_Def)); 1068 1069 -- Start of processing for Access_Subprogram_Declaration 1070 1071 begin 1072 -- Associate the Itype node with the inner full-type declaration or 1073 -- subprogram spec or entry body. This is required to handle nested 1074 -- anonymous declarations. For example: 1075 1076 -- procedure P 1077 -- (X : access procedure 1078 -- (Y : access procedure 1079 -- (Z : access T))) 1080 1081 D_Ityp := Associated_Node_For_Itype (Desig_Type); 1082 while Nkind (D_Ityp) not in N_Full_Type_Declaration 1083 | N_Private_Type_Declaration 1084 | N_Private_Extension_Declaration 1085 | N_Procedure_Specification 1086 | N_Function_Specification 1087 | N_Entry_Body 1088 | N_Object_Declaration 1089 | N_Object_Renaming_Declaration 1090 | N_Formal_Object_Declaration 1091 | N_Formal_Type_Declaration 1092 | N_Task_Type_Declaration 1093 | N_Protected_Type_Declaration 1094 loop 1095 D_Ityp := Parent (D_Ityp); 1096 pragma Assert (D_Ityp /= Empty); 1097 end loop; 1098 1099 Set_Associated_Node_For_Itype (Desig_Type, D_Ityp); 1100 1101 if Nkind (D_Ityp) in N_Procedure_Specification | N_Function_Specification 1102 then 1103 Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp))); 1104 1105 elsif Nkind (D_Ityp) in N_Full_Type_Declaration 1106 | N_Object_Declaration 1107 | N_Object_Renaming_Declaration 1108 | N_Formal_Type_Declaration 1109 then 1110 Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp))); 1111 end if; 1112 1113 if Nkind (T_Def) = N_Access_Function_Definition then 1114 if Nkind (Result_Definition (T_Def)) = N_Access_Definition then 1115 declare 1116 Acc : constant Node_Id := Result_Definition (T_Def); 1117 1118 begin 1119 if Present (Access_To_Subprogram_Definition (Acc)) 1120 and then 1121 Protected_Present (Access_To_Subprogram_Definition (Acc)) 1122 then 1123 Set_Etype 1124 (Desig_Type, 1125 Replace_Anonymous_Access_To_Protected_Subprogram 1126 (T_Def)); 1127 1128 else 1129 Set_Etype 1130 (Desig_Type, 1131 Access_Definition (T_Def, Result_Definition (T_Def))); 1132 end if; 1133 end; 1134 1135 else 1136 Analyze (Result_Definition (T_Def)); 1137 1138 declare 1139 Typ : constant Entity_Id := Entity (Result_Definition (T_Def)); 1140 1141 begin 1142 -- If a null exclusion is imposed on the result type, then 1143 -- create a null-excluding itype (an access subtype) and use 1144 -- it as the function's Etype. 1145 1146 if Is_Access_Type (Typ) 1147 and then Null_Exclusion_In_Return_Present (T_Def) 1148 then 1149 Set_Etype (Desig_Type, 1150 Create_Null_Excluding_Itype 1151 (T => Typ, 1152 Related_Nod => T_Def, 1153 Scope_Id => Current_Scope)); 1154 1155 else 1156 if From_Limited_With (Typ) then 1157 1158 -- AI05-151: Incomplete types are allowed in all basic 1159 -- declarations, including access to subprograms. 1160 1161 if Ada_Version >= Ada_2012 then 1162 null; 1163 1164 else 1165 Error_Msg_NE 1166 ("illegal use of incomplete type&", 1167 Result_Definition (T_Def), Typ); 1168 end if; 1169 1170 elsif Ekind (Current_Scope) = E_Package 1171 and then In_Private_Part (Current_Scope) 1172 then 1173 if Ekind (Typ) = E_Incomplete_Type then 1174 Append_Elmt (Desig_Type, Private_Dependents (Typ)); 1175 1176 elsif Is_Class_Wide_Type (Typ) 1177 and then Ekind (Etype (Typ)) = E_Incomplete_Type 1178 then 1179 Append_Elmt 1180 (Desig_Type, Private_Dependents (Etype (Typ))); 1181 end if; 1182 end if; 1183 1184 Set_Etype (Desig_Type, Typ); 1185 end if; 1186 end; 1187 end if; 1188 1189 if not Is_Type (Etype (Desig_Type)) then 1190 Error_Msg_N 1191 ("expect type in function specification", 1192 Result_Definition (T_Def)); 1193 end if; 1194 1195 else 1196 Set_Etype (Desig_Type, Standard_Void_Type); 1197 end if; 1198 1199 if Present (Formals) then 1200 Push_Scope (Desig_Type); 1201 1202 -- Some special tests here. These special tests can be removed 1203 -- if and when Itypes always have proper parent pointers to their 1204 -- declarations??? 1205 1206 -- Special test 1) Link defining_identifier of formals. Required by 1207 -- First_Formal to provide its functionality. 1208 1209 declare 1210 F : Node_Id; 1211 1212 begin 1213 F := First (Formals); 1214 1215 while Present (F) loop 1216 if No (Parent (Defining_Identifier (F))) then 1217 Set_Parent (Defining_Identifier (F), F); 1218 end if; 1219 1220 Next (F); 1221 end loop; 1222 end; 1223 1224 Process_Formals (Formals, Parent (T_Def)); 1225 1226 -- Special test 2) End_Scope requires that the parent pointer be set 1227 -- to something reasonable, but Itypes don't have parent pointers. So 1228 -- we set it and then unset it ??? 1229 1230 Set_Parent (Desig_Type, T_Name); 1231 End_Scope; 1232 Set_Parent (Desig_Type, Empty); 1233 end if; 1234 1235 -- Check for premature usage of the type being defined 1236 1237 Check_For_Premature_Usage (T_Def); 1238 1239 -- The return type and/or any parameter type may be incomplete. Mark the 1240 -- subprogram_type as depending on the incomplete type, so that it can 1241 -- be updated when the full type declaration is seen. This only applies 1242 -- to incomplete types declared in some enclosing scope, not to limited 1243 -- views from other packages. 1244 1245 -- Prior to Ada 2012, access to functions can only have in_parameters. 1246 1247 if Present (Formals) then 1248 Formal := First_Formal (Desig_Type); 1249 while Present (Formal) loop 1250 if Ekind (Formal) /= E_In_Parameter 1251 and then Nkind (T_Def) = N_Access_Function_Definition 1252 and then Ada_Version < Ada_2012 1253 then 1254 Error_Msg_N ("functions can only have IN parameters", Formal); 1255 end if; 1256 1257 if Ekind (Etype (Formal)) = E_Incomplete_Type 1258 and then In_Open_Scopes (Scope (Etype (Formal))) 1259 then 1260 Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal))); 1261 Set_Has_Delayed_Freeze (Desig_Type); 1262 end if; 1263 1264 Next_Formal (Formal); 1265 end loop; 1266 end if; 1267 1268 -- Check whether an indirect call without actuals may be possible. This 1269 -- is used when resolving calls whose result is then indexed. 1270 1271 May_Need_Actuals (Desig_Type); 1272 1273 -- If the return type is incomplete, this is legal as long as the type 1274 -- is declared in the current scope and will be completed in it (rather 1275 -- than being part of limited view). 1276 1277 if Ekind (Etype (Desig_Type)) = E_Incomplete_Type 1278 and then not Has_Delayed_Freeze (Desig_Type) 1279 and then In_Open_Scopes (Scope (Etype (Desig_Type))) 1280 then 1281 Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type))); 1282 Set_Has_Delayed_Freeze (Desig_Type); 1283 end if; 1284 1285 Check_Delayed_Subprogram (Desig_Type); 1286 1287 if Protected_Present (T_Def) then 1288 Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type); 1289 Set_Convention (Desig_Type, Convention_Protected); 1290 else 1291 Set_Ekind (T_Name, E_Access_Subprogram_Type); 1292 end if; 1293 1294 Set_Can_Use_Internal_Rep (T_Name, 1295 not Always_Compatible_Rep_On_Target); 1296 Set_Etype (T_Name, T_Name); 1297 Init_Size_Align (T_Name); 1298 Set_Directly_Designated_Type (T_Name, Desig_Type); 1299 1300 -- If the access_to_subprogram is not declared at the library level, 1301 -- it can only point to subprograms that are at the same or deeper 1302 -- accessibility level. The corresponding subprogram type might 1303 -- require an activation record when compiling for C. 1304 1305 Set_Needs_Activation_Record (Desig_Type, 1306 not Is_Library_Level_Entity (T_Name)); 1307 1308 Generate_Reference_To_Formals (T_Name); 1309 1310 -- Ada 2005 (AI-231): Propagate the null-excluding attribute 1311 1312 Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def)); 1313 1314 Check_Restriction (No_Access_Subprograms, T_Def); 1315 end Access_Subprogram_Declaration; 1316 1317 ---------------------------- 1318 -- Access_Type_Declaration -- 1319 ---------------------------- 1320 1321 procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is 1322 P : constant Node_Id := Parent (Def); 1323 S : constant Node_Id := Subtype_Indication (Def); 1324 1325 Full_Desig : Entity_Id; 1326 1327 begin 1328 -- Check for permissible use of incomplete type 1329 1330 if Nkind (S) /= N_Subtype_Indication then 1331 Analyze (S); 1332 1333 if Nkind (S) in N_Has_Entity 1334 and then Present (Entity (S)) 1335 and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type 1336 then 1337 Set_Directly_Designated_Type (T, Entity (S)); 1338 1339 -- If the designated type is a limited view, we cannot tell if 1340 -- the full view contains tasks, and there is no way to handle 1341 -- that full view in a client. We create a master entity for the 1342 -- scope, which will be used when a client determines that one 1343 -- is needed. 1344 1345 if From_Limited_With (Entity (S)) 1346 and then not Is_Class_Wide_Type (Entity (S)) 1347 then 1348 Set_Ekind (T, E_Access_Type); 1349 Build_Master_Entity (T); 1350 Build_Master_Renaming (T); 1351 end if; 1352 1353 else 1354 Set_Directly_Designated_Type (T, Process_Subtype (S, P, T, 'P')); 1355 end if; 1356 1357 -- If the access definition is of the form: ACCESS NOT NULL .. 1358 -- the subtype indication must be of an access type. Create 1359 -- a null-excluding subtype of it. 1360 1361 if Null_Excluding_Subtype (Def) then 1362 if not Is_Access_Type (Entity (S)) then 1363 Error_Msg_N ("null exclusion must apply to access type", Def); 1364 1365 else 1366 declare 1367 Loc : constant Source_Ptr := Sloc (S); 1368 Decl : Node_Id; 1369 Nam : constant Entity_Id := Make_Temporary (Loc, 'S'); 1370 1371 begin 1372 Decl := 1373 Make_Subtype_Declaration (Loc, 1374 Defining_Identifier => Nam, 1375 Subtype_Indication => 1376 New_Occurrence_Of (Entity (S), Loc)); 1377 Set_Null_Exclusion_Present (Decl); 1378 Insert_Before (Parent (Def), Decl); 1379 Analyze (Decl); 1380 Set_Entity (S, Nam); 1381 end; 1382 end if; 1383 end if; 1384 1385 else 1386 Set_Directly_Designated_Type (T, 1387 Process_Subtype (S, P, T, 'P')); 1388 end if; 1389 1390 if All_Present (Def) or Constant_Present (Def) then 1391 Set_Ekind (T, E_General_Access_Type); 1392 else 1393 Set_Ekind (T, E_Access_Type); 1394 end if; 1395 1396 Full_Desig := Designated_Type (T); 1397 1398 if Base_Type (Full_Desig) = T then 1399 Error_Msg_N ("access type cannot designate itself", S); 1400 1401 -- In Ada 2005, the type may have a limited view through some unit in 1402 -- its own context, allowing the following circularity that cannot be 1403 -- detected earlier. 1404 1405 elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T 1406 then 1407 Error_Msg_N 1408 ("access type cannot designate its own class-wide type", S); 1409 1410 -- Clean up indication of tagged status to prevent cascaded errors 1411 1412 Set_Is_Tagged_Type (T, False); 1413 end if; 1414 1415 Set_Etype (T, T); 1416 1417 -- For SPARK, check that the designated type is compatible with 1418 -- respect to volatility with the access type. 1419 1420 if SPARK_Mode /= Off 1421 and then Comes_From_Source (T) 1422 then 1423 -- ??? UNIMPLEMENTED 1424 -- In the case where the designated type is incomplete at this point, 1425 -- performing this check here is harmless but the check will need to 1426 -- be repeated when the designated type is complete. 1427 1428 -- The preceding call to Comes_From_Source is needed because the 1429 -- FE sometimes introduces implicitly declared access types. See, 1430 -- for example, the expansion of nested_po.ads in OA28-015. 1431 1432 Check_Volatility_Compatibility 1433 (Full_Desig, T, "designated type", "access type", 1434 Srcpos_Bearer => T); 1435 end if; 1436 1437 -- If the type has appeared already in a with_type clause, it is frozen 1438 -- and the pointer size is already set. Else, initialize. 1439 1440 if not From_Limited_With (T) then 1441 Init_Size_Align (T); 1442 end if; 1443 1444 -- Note that Has_Task is always false, since the access type itself 1445 -- is not a task type. See Einfo for more description on this point. 1446 -- Exactly the same consideration applies to Has_Controlled_Component 1447 -- and to Has_Protected. 1448 1449 Set_Has_Task (T, False); 1450 Set_Has_Protected (T, False); 1451 Set_Has_Timing_Event (T, False); 1452 Set_Has_Controlled_Component (T, False); 1453 1454 -- Initialize field Finalization_Master explicitly to Empty, to avoid 1455 -- problems where an incomplete view of this entity has been previously 1456 -- established by a limited with and an overlaid version of this field 1457 -- (Stored_Constraint) was initialized for the incomplete view. 1458 1459 -- This reset is performed in most cases except where the access type 1460 -- has been created for the purposes of allocating or deallocating a 1461 -- build-in-place object. Such access types have explicitly set pools 1462 -- and finalization masters. 1463 1464 if No (Associated_Storage_Pool (T)) then 1465 Set_Finalization_Master (T, Empty); 1466 end if; 1467 1468 -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant 1469 -- attributes 1470 1471 Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def)); 1472 Set_Is_Access_Constant (T, Constant_Present (Def)); 1473 end Access_Type_Declaration; 1474 1475 ---------------------------------- 1476 -- Add_Interface_Tag_Components -- 1477 ---------------------------------- 1478 1479 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is 1480 Loc : constant Source_Ptr := Sloc (N); 1481 L : List_Id; 1482 Last_Tag : Node_Id; 1483 1484 procedure Add_Tag (Iface : Entity_Id); 1485 -- Add tag for one of the progenitor interfaces 1486 1487 ------------- 1488 -- Add_Tag -- 1489 ------------- 1490 1491 procedure Add_Tag (Iface : Entity_Id) is 1492 Decl : Node_Id; 1493 Def : Node_Id; 1494 Tag : Entity_Id; 1495 Offset : Entity_Id; 1496 1497 begin 1498 pragma Assert (Is_Tagged_Type (Iface) and then Is_Interface (Iface)); 1499 1500 -- This is a reasonable place to propagate predicates 1501 1502 if Has_Predicates (Iface) then 1503 Set_Has_Predicates (Typ); 1504 end if; 1505 1506 Def := 1507 Make_Component_Definition (Loc, 1508 Aliased_Present => True, 1509 Subtype_Indication => 1510 New_Occurrence_Of (RTE (RE_Interface_Tag), Loc)); 1511 1512 Tag := Make_Temporary (Loc, 'V'); 1513 1514 Decl := 1515 Make_Component_Declaration (Loc, 1516 Defining_Identifier => Tag, 1517 Component_Definition => Def); 1518 1519 Analyze_Component_Declaration (Decl); 1520 1521 Set_Analyzed (Decl); 1522 Set_Ekind (Tag, E_Component); 1523 Set_Is_Tag (Tag); 1524 Set_Is_Aliased (Tag); 1525 Set_Is_Independent (Tag); 1526 Set_Related_Type (Tag, Iface); 1527 Init_Component_Location (Tag); 1528 1529 pragma Assert (Is_Frozen (Iface)); 1530 1531 Set_DT_Entry_Count (Tag, 1532 DT_Entry_Count (First_Entity (Iface))); 1533 1534 if No (Last_Tag) then 1535 Prepend (Decl, L); 1536 else 1537 Insert_After (Last_Tag, Decl); 1538 end if; 1539 1540 Last_Tag := Decl; 1541 1542 -- If the ancestor has discriminants we need to give special support 1543 -- to store the offset_to_top value of the secondary dispatch tables. 1544 -- For this purpose we add a supplementary component just after the 1545 -- field that contains the tag associated with each secondary DT. 1546 1547 if Typ /= Etype (Typ) and then Has_Discriminants (Etype (Typ)) then 1548 Def := 1549 Make_Component_Definition (Loc, 1550 Subtype_Indication => 1551 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); 1552 1553 Offset := Make_Temporary (Loc, 'V'); 1554 1555 Decl := 1556 Make_Component_Declaration (Loc, 1557 Defining_Identifier => Offset, 1558 Component_Definition => Def); 1559 1560 Analyze_Component_Declaration (Decl); 1561 1562 Set_Analyzed (Decl); 1563 Set_Ekind (Offset, E_Component); 1564 Set_Is_Aliased (Offset); 1565 Set_Is_Independent (Offset); 1566 Set_Related_Type (Offset, Iface); 1567 Init_Component_Location (Offset); 1568 Insert_After (Last_Tag, Decl); 1569 Last_Tag := Decl; 1570 end if; 1571 end Add_Tag; 1572 1573 -- Local variables 1574 1575 Elmt : Elmt_Id; 1576 Ext : Node_Id; 1577 Comp : Node_Id; 1578 1579 -- Start of processing for Add_Interface_Tag_Components 1580 1581 begin 1582 if not RTE_Available (RE_Interface_Tag) then 1583 Error_Msg 1584 ("(Ada 2005) interface types not supported by this run-time!", 1585 Sloc (N)); 1586 return; 1587 end if; 1588 1589 if Ekind (Typ) /= E_Record_Type 1590 or else (Is_Concurrent_Record_Type (Typ) 1591 and then Is_Empty_List (Abstract_Interface_List (Typ))) 1592 or else (not Is_Concurrent_Record_Type (Typ) 1593 and then No (Interfaces (Typ)) 1594 and then Is_Empty_Elmt_List (Interfaces (Typ))) 1595 then 1596 return; 1597 end if; 1598 1599 -- Find the current last tag 1600 1601 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 1602 Ext := Record_Extension_Part (Type_Definition (N)); 1603 else 1604 pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition); 1605 Ext := Type_Definition (N); 1606 end if; 1607 1608 Last_Tag := Empty; 1609 1610 if not (Present (Component_List (Ext))) then 1611 Set_Null_Present (Ext, False); 1612 L := New_List; 1613 Set_Component_List (Ext, 1614 Make_Component_List (Loc, 1615 Component_Items => L, 1616 Null_Present => False)); 1617 else 1618 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 1619 L := Component_Items 1620 (Component_List 1621 (Record_Extension_Part 1622 (Type_Definition (N)))); 1623 else 1624 L := Component_Items 1625 (Component_List 1626 (Type_Definition (N))); 1627 end if; 1628 1629 -- Find the last tag component 1630 1631 Comp := First (L); 1632 while Present (Comp) loop 1633 if Nkind (Comp) = N_Component_Declaration 1634 and then Is_Tag (Defining_Identifier (Comp)) 1635 then 1636 Last_Tag := Comp; 1637 end if; 1638 1639 Next (Comp); 1640 end loop; 1641 end if; 1642 1643 -- At this point L references the list of components and Last_Tag 1644 -- references the current last tag (if any). Now we add the tag 1645 -- corresponding with all the interfaces that are not implemented 1646 -- by the parent. 1647 1648 if Present (Interfaces (Typ)) then 1649 Elmt := First_Elmt (Interfaces (Typ)); 1650 while Present (Elmt) loop 1651 Add_Tag (Node (Elmt)); 1652 Next_Elmt (Elmt); 1653 end loop; 1654 end if; 1655 end Add_Interface_Tag_Components; 1656 1657 ------------------------------------- 1658 -- Add_Internal_Interface_Entities -- 1659 ------------------------------------- 1660 1661 procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is 1662 Elmt : Elmt_Id; 1663 Iface : Entity_Id; 1664 Iface_Elmt : Elmt_Id; 1665 Iface_Prim : Entity_Id; 1666 Ifaces_List : Elist_Id; 1667 New_Subp : Entity_Id := Empty; 1668 Prim : Entity_Id; 1669 Restore_Scope : Boolean := False; 1670 1671 begin 1672 pragma Assert (Ada_Version >= Ada_2005 1673 and then Is_Record_Type (Tagged_Type) 1674 and then Is_Tagged_Type (Tagged_Type) 1675 and then Has_Interfaces (Tagged_Type) 1676 and then not Is_Interface (Tagged_Type)); 1677 1678 -- Ensure that the internal entities are added to the scope of the type 1679 1680 if Scope (Tagged_Type) /= Current_Scope then 1681 Push_Scope (Scope (Tagged_Type)); 1682 Restore_Scope := True; 1683 end if; 1684 1685 Collect_Interfaces (Tagged_Type, Ifaces_List); 1686 1687 Iface_Elmt := First_Elmt (Ifaces_List); 1688 while Present (Iface_Elmt) loop 1689 Iface := Node (Iface_Elmt); 1690 1691 -- Originally we excluded here from this processing interfaces that 1692 -- are parents of Tagged_Type because their primitives are located 1693 -- in the primary dispatch table (and hence no auxiliary internal 1694 -- entities are required to handle secondary dispatch tables in such 1695 -- case). However, these auxiliary entities are also required to 1696 -- handle derivations of interfaces in formals of generics (see 1697 -- Derive_Subprograms). 1698 1699 Elmt := First_Elmt (Primitive_Operations (Iface)); 1700 while Present (Elmt) loop 1701 Iface_Prim := Node (Elmt); 1702 1703 if not Is_Predefined_Dispatching_Operation (Iface_Prim) then 1704 Prim := 1705 Find_Primitive_Covering_Interface 1706 (Tagged_Type => Tagged_Type, 1707 Iface_Prim => Iface_Prim); 1708 1709 if No (Prim) and then Serious_Errors_Detected > 0 then 1710 goto Continue; 1711 end if; 1712 1713 pragma Assert (Present (Prim)); 1714 1715 -- Ada 2012 (AI05-0197): If the name of the covering primitive 1716 -- differs from the name of the interface primitive then it is 1717 -- a private primitive inherited from a parent type. In such 1718 -- case, given that Tagged_Type covers the interface, the 1719 -- inherited private primitive becomes visible. For such 1720 -- purpose we add a new entity that renames the inherited 1721 -- private primitive. 1722 1723 if Chars (Prim) /= Chars (Iface_Prim) then 1724 pragma Assert (Has_Suffix (Prim, 'P')); 1725 Derive_Subprogram 1726 (New_Subp => New_Subp, 1727 Parent_Subp => Iface_Prim, 1728 Derived_Type => Tagged_Type, 1729 Parent_Type => Iface); 1730 Set_Alias (New_Subp, Prim); 1731 Set_Is_Abstract_Subprogram 1732 (New_Subp, Is_Abstract_Subprogram (Prim)); 1733 end if; 1734 1735 Derive_Subprogram 1736 (New_Subp => New_Subp, 1737 Parent_Subp => Iface_Prim, 1738 Derived_Type => Tagged_Type, 1739 Parent_Type => Iface); 1740 1741 declare 1742 Anc : Entity_Id; 1743 begin 1744 if Is_Inherited_Operation (Prim) 1745 and then Present (Alias (Prim)) 1746 then 1747 Anc := Alias (Prim); 1748 else 1749 Anc := Overridden_Operation (Prim); 1750 end if; 1751 1752 -- Apply legality checks in RM 6.1.1 (10-13) concerning 1753 -- nonconforming preconditions in both an ancestor and 1754 -- a progenitor operation. 1755 1756 -- If the operation is a primitive wrapper it is an explicit 1757 -- (overriding) operqtion and all is fine. 1758 1759 if Present (Anc) 1760 and then Has_Non_Trivial_Precondition (Anc) 1761 and then Has_Non_Trivial_Precondition (Iface_Prim) 1762 then 1763 if Is_Abstract_Subprogram (Prim) 1764 or else 1765 (Ekind (Prim) = E_Procedure 1766 and then Nkind (Parent (Prim)) = 1767 N_Procedure_Specification 1768 and then Null_Present (Parent (Prim))) 1769 or else Is_Primitive_Wrapper (Prim) 1770 then 1771 null; 1772 1773 -- The operation is inherited and must be overridden 1774 1775 elsif not Comes_From_Source (Prim) then 1776 Error_Msg_NE 1777 ("&inherits non-conforming preconditions and must " 1778 & "be overridden (RM 6.1.1 (10-16)", 1779 Parent (Tagged_Type), Prim); 1780 end if; 1781 end if; 1782 end; 1783 1784 -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp 1785 -- associated with interface types. These entities are 1786 -- only registered in the list of primitives of its 1787 -- corresponding tagged type because they are only used 1788 -- to fill the contents of the secondary dispatch tables. 1789 -- Therefore they are removed from the homonym chains. 1790 1791 Set_Is_Hidden (New_Subp); 1792 Set_Is_Internal (New_Subp); 1793 Set_Alias (New_Subp, Prim); 1794 Set_Is_Abstract_Subprogram 1795 (New_Subp, Is_Abstract_Subprogram (Prim)); 1796 Set_Interface_Alias (New_Subp, Iface_Prim); 1797 1798 -- If the returned type is an interface then propagate it to 1799 -- the returned type. Needed by the thunk to generate the code 1800 -- which displaces "this" to reference the corresponding 1801 -- secondary dispatch table in the returned object. 1802 1803 if Is_Interface (Etype (Iface_Prim)) then 1804 Set_Etype (New_Subp, Etype (Iface_Prim)); 1805 end if; 1806 1807 -- Internal entities associated with interface types are only 1808 -- registered in the list of primitives of the tagged type. 1809 -- They are only used to fill the contents of the secondary 1810 -- dispatch tables. Therefore they are not needed in the 1811 -- homonym chains. 1812 1813 Remove_Homonym (New_Subp); 1814 1815 -- Hidden entities associated with interfaces must have set 1816 -- the Has_Delay_Freeze attribute to ensure that, in case 1817 -- of locally defined tagged types (or compiling with static 1818 -- dispatch tables generation disabled) the corresponding 1819 -- entry of the secondary dispatch table is filled when such 1820 -- an entity is frozen. 1821 1822 Set_Has_Delayed_Freeze (New_Subp); 1823 end if; 1824 1825 <<Continue>> 1826 Next_Elmt (Elmt); 1827 end loop; 1828 1829 Next_Elmt (Iface_Elmt); 1830 end loop; 1831 1832 if Restore_Scope then 1833 Pop_Scope; 1834 end if; 1835 end Add_Internal_Interface_Entities; 1836 1837 ----------------------------------- 1838 -- Analyze_Component_Declaration -- 1839 ----------------------------------- 1840 1841 procedure Analyze_Component_Declaration (N : Node_Id) is 1842 Loc : constant Source_Ptr := Sloc (Component_Definition (N)); 1843 Id : constant Entity_Id := Defining_Identifier (N); 1844 E : constant Node_Id := Expression (N); 1845 Typ : constant Node_Id := 1846 Subtype_Indication (Component_Definition (N)); 1847 T : Entity_Id; 1848 P : Entity_Id; 1849 1850 function Contains_POC (Constr : Node_Id) return Boolean; 1851 -- Determines whether a constraint uses the discriminant of a record 1852 -- type thus becoming a per-object constraint (POC). 1853 1854 function Is_Known_Limited (Typ : Entity_Id) return Boolean; 1855 -- Typ is the type of the current component, check whether this type is 1856 -- a limited type. Used to validate declaration against that of 1857 -- enclosing record. 1858 1859 ------------------ 1860 -- Contains_POC -- 1861 ------------------ 1862 1863 function Contains_POC (Constr : Node_Id) return Boolean is 1864 begin 1865 -- Prevent cascaded errors 1866 1867 if Error_Posted (Constr) then 1868 return False; 1869 end if; 1870 1871 case Nkind (Constr) is 1872 when N_Attribute_Reference => 1873 return Attribute_Name (Constr) = Name_Access 1874 and then Prefix (Constr) = Scope (Entity (Prefix (Constr))); 1875 1876 when N_Discriminant_Association => 1877 return Denotes_Discriminant (Expression (Constr)); 1878 1879 when N_Identifier => 1880 return Denotes_Discriminant (Constr); 1881 1882 when N_Index_Or_Discriminant_Constraint => 1883 declare 1884 IDC : Node_Id; 1885 1886 begin 1887 IDC := First (Constraints (Constr)); 1888 while Present (IDC) loop 1889 1890 -- One per-object constraint is sufficient 1891 1892 if Contains_POC (IDC) then 1893 return True; 1894 end if; 1895 1896 Next (IDC); 1897 end loop; 1898 1899 return False; 1900 end; 1901 1902 when N_Range => 1903 return Denotes_Discriminant (Low_Bound (Constr)) 1904 or else 1905 Denotes_Discriminant (High_Bound (Constr)); 1906 1907 when N_Range_Constraint => 1908 return Denotes_Discriminant (Range_Expression (Constr)); 1909 1910 when others => 1911 return False; 1912 end case; 1913 end Contains_POC; 1914 1915 ---------------------- 1916 -- Is_Known_Limited -- 1917 ---------------------- 1918 1919 function Is_Known_Limited (Typ : Entity_Id) return Boolean is 1920 P : constant Entity_Id := Etype (Typ); 1921 R : constant Entity_Id := Root_Type (Typ); 1922 1923 begin 1924 if Is_Limited_Record (Typ) then 1925 return True; 1926 1927 -- If the root type is limited (and not a limited interface) so is 1928 -- the current type. 1929 1930 elsif Is_Limited_Record (R) 1931 and then (not Is_Interface (R) or else not Is_Limited_Interface (R)) 1932 then 1933 return True; 1934 1935 -- Else the type may have a limited interface progenitor, but a 1936 -- limited record parent that is not an interface. 1937 1938 elsif R /= P 1939 and then Is_Limited_Record (P) 1940 and then not Is_Interface (P) 1941 then 1942 return True; 1943 1944 else 1945 return False; 1946 end if; 1947 end Is_Known_Limited; 1948 1949 -- Start of processing for Analyze_Component_Declaration 1950 1951 begin 1952 Generate_Definition (Id); 1953 Enter_Name (Id); 1954 1955 if Present (Typ) then 1956 T := Find_Type_Of_Object 1957 (Subtype_Indication (Component_Definition (N)), N); 1958 1959 -- Ada 2005 (AI-230): Access Definition case 1960 1961 else 1962 pragma Assert (Present 1963 (Access_Definition (Component_Definition (N)))); 1964 1965 T := Access_Definition 1966 (Related_Nod => N, 1967 N => Access_Definition (Component_Definition (N))); 1968 Set_Is_Local_Anonymous_Access (T); 1969 1970 -- Ada 2005 (AI-254) 1971 1972 if Present (Access_To_Subprogram_Definition 1973 (Access_Definition (Component_Definition (N)))) 1974 and then Protected_Present (Access_To_Subprogram_Definition 1975 (Access_Definition 1976 (Component_Definition (N)))) 1977 then 1978 T := Replace_Anonymous_Access_To_Protected_Subprogram (N); 1979 end if; 1980 end if; 1981 1982 -- If the subtype is a constrained subtype of the enclosing record, 1983 -- (which must have a partial view) the back-end does not properly 1984 -- handle the recursion. Rewrite the component declaration with an 1985 -- explicit subtype indication, which is acceptable to Gigi. We can copy 1986 -- the tree directly because side effects have already been removed from 1987 -- discriminant constraints. 1988 1989 if Ekind (T) = E_Access_Subtype 1990 and then Is_Entity_Name (Subtype_Indication (Component_Definition (N))) 1991 and then Comes_From_Source (T) 1992 and then Nkind (Parent (T)) = N_Subtype_Declaration 1993 and then Etype (Directly_Designated_Type (T)) = Current_Scope 1994 then 1995 Rewrite 1996 (Subtype_Indication (Component_Definition (N)), 1997 New_Copy_Tree (Subtype_Indication (Parent (T)))); 1998 T := Find_Type_Of_Object 1999 (Subtype_Indication (Component_Definition (N)), N); 2000 end if; 2001 2002 -- If the component declaration includes a default expression, then we 2003 -- check that the component is not of a limited type (RM 3.7(5)), 2004 -- and do the special preanalysis of the expression (see section on 2005 -- "Handling of Default and Per-Object Expressions" in the spec of 2006 -- package Sem). 2007 2008 if Present (E) then 2009 Preanalyze_Default_Expression (E, T); 2010 Check_Initialization (T, E); 2011 2012 if Ada_Version >= Ada_2005 2013 and then Ekind (T) = E_Anonymous_Access_Type 2014 and then Etype (E) /= Any_Type 2015 then 2016 -- Check RM 3.9.2(9): "if the expected type for an expression is 2017 -- an anonymous access-to-specific tagged type, then the object 2018 -- designated by the expression shall not be dynamically tagged 2019 -- unless it is a controlling operand in a call on a dispatching 2020 -- operation" 2021 2022 if Is_Tagged_Type (Directly_Designated_Type (T)) 2023 and then 2024 Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type 2025 and then 2026 Ekind (Directly_Designated_Type (Etype (E))) = 2027 E_Class_Wide_Type 2028 then 2029 Error_Msg_N 2030 ("access to specific tagged type required (RM 3.9.2(9))", E); 2031 end if; 2032 2033 -- (Ada 2005: AI-230): Accessibility check for anonymous 2034 -- components 2035 2036 if Type_Access_Level (Etype (E)) > 2037 Deepest_Type_Access_Level (T) 2038 then 2039 Error_Msg_N 2040 ("expression has deeper access level than component " & 2041 "(RM 3.10.2 (12.2))", E); 2042 end if; 2043 2044 -- The initialization expression is a reference to an access 2045 -- discriminant. The type of the discriminant is always deeper 2046 -- than any access type. 2047 2048 if Ekind (Etype (E)) = E_Anonymous_Access_Type 2049 and then Is_Entity_Name (E) 2050 and then Ekind (Entity (E)) = E_In_Parameter 2051 and then Present (Discriminal_Link (Entity (E))) 2052 then 2053 Error_Msg_N 2054 ("discriminant has deeper accessibility level than target", 2055 E); 2056 end if; 2057 end if; 2058 end if; 2059 2060 -- Avoid reporting spurious errors if the component is initialized with 2061 -- a raise expression (which is legal in any expression context) 2062 2063 if Present (E) 2064 and then 2065 (Nkind (E) = N_Raise_Expression 2066 or else (Nkind (E) = N_Qualified_Expression 2067 and then Nkind (Expression (E)) = N_Raise_Expression)) 2068 then 2069 null; 2070 2071 -- The parent type may be a private view with unknown discriminants, 2072 -- and thus unconstrained. Regular components must be constrained. 2073 2074 elsif not Is_Definite_Subtype (T) 2075 and then Chars (Id) /= Name_uParent 2076 then 2077 if Is_Class_Wide_Type (T) then 2078 Error_Msg_N 2079 ("class-wide subtype with unknown discriminants" & 2080 " in component declaration", 2081 Subtype_Indication (Component_Definition (N))); 2082 else 2083 Error_Msg_N 2084 ("unconstrained subtype in component declaration", 2085 Subtype_Indication (Component_Definition (N))); 2086 end if; 2087 2088 -- Components cannot be abstract, except for the special case of 2089 -- the _Parent field (case of extending an abstract tagged type) 2090 2091 elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then 2092 Error_Msg_N ("type of a component cannot be abstract", N); 2093 end if; 2094 2095 Set_Etype (Id, T); 2096 2097 if Aliased_Present (Component_Definition (N)) then 2098 Set_Is_Aliased (Id); 2099 2100 -- AI12-001: All aliased objects are considered to be specified as 2101 -- independently addressable (RM C.6(8.1/4)). 2102 2103 Set_Is_Independent (Id); 2104 end if; 2105 2106 -- The component declaration may have a per-object constraint, set 2107 -- the appropriate flag in the defining identifier of the subtype. 2108 2109 if Present (Subtype_Indication (Component_Definition (N))) then 2110 declare 2111 Sindic : constant Node_Id := 2112 Subtype_Indication (Component_Definition (N)); 2113 begin 2114 if Nkind (Sindic) = N_Subtype_Indication 2115 and then Present (Constraint (Sindic)) 2116 and then Contains_POC (Constraint (Sindic)) 2117 then 2118 Set_Has_Per_Object_Constraint (Id); 2119 end if; 2120 end; 2121 end if; 2122 2123 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry 2124 -- out some static checks. 2125 2126 if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then 2127 Null_Exclusion_Static_Checks (N); 2128 end if; 2129 2130 -- If this component is private (or depends on a private type), flag the 2131 -- record type to indicate that some operations are not available. 2132 2133 P := Private_Component (T); 2134 2135 if Present (P) then 2136 2137 -- Check for circular definitions 2138 2139 if P = Any_Type then 2140 Set_Etype (Id, Any_Type); 2141 2142 -- There is a gap in the visibility of operations only if the 2143 -- component type is not defined in the scope of the record type. 2144 2145 elsif Scope (P) = Scope (Current_Scope) then 2146 null; 2147 2148 elsif Is_Limited_Type (P) then 2149 Set_Is_Limited_Composite (Current_Scope); 2150 2151 else 2152 Set_Is_Private_Composite (Current_Scope); 2153 end if; 2154 end if; 2155 2156 if P /= Any_Type 2157 and then Is_Limited_Type (T) 2158 and then Chars (Id) /= Name_uParent 2159 and then Is_Tagged_Type (Current_Scope) 2160 then 2161 if Is_Derived_Type (Current_Scope) 2162 and then not Is_Known_Limited (Current_Scope) 2163 then 2164 Error_Msg_N 2165 ("extension of nonlimited type cannot have limited components", 2166 N); 2167 2168 if Is_Interface (Root_Type (Current_Scope)) then 2169 Error_Msg_N 2170 ("\limitedness is not inherited from limited interface", N); 2171 Error_Msg_N ("\add LIMITED to type indication", N); 2172 end if; 2173 2174 Explain_Limited_Type (T, N); 2175 Set_Etype (Id, Any_Type); 2176 Set_Is_Limited_Composite (Current_Scope, False); 2177 2178 elsif not Is_Derived_Type (Current_Scope) 2179 and then not Is_Limited_Record (Current_Scope) 2180 and then not Is_Concurrent_Type (Current_Scope) 2181 then 2182 Error_Msg_N 2183 ("nonlimited tagged type cannot have limited components", N); 2184 Explain_Limited_Type (T, N); 2185 Set_Etype (Id, Any_Type); 2186 Set_Is_Limited_Composite (Current_Scope, False); 2187 end if; 2188 end if; 2189 2190 -- If the component is an unconstrained task or protected type with 2191 -- discriminants, the component and the enclosing record are limited 2192 -- and the component is constrained by its default values. Compute 2193 -- its actual subtype, else it may be allocated the maximum size by 2194 -- the backend, and possibly overflow. 2195 2196 if Is_Concurrent_Type (T) 2197 and then not Is_Constrained (T) 2198 and then Has_Discriminants (T) 2199 and then not Has_Discriminants (Current_Scope) 2200 then 2201 declare 2202 Act_T : constant Entity_Id := Build_Default_Subtype (T, N); 2203 2204 begin 2205 Set_Etype (Id, Act_T); 2206 2207 -- Rewrite component definition to use the constrained subtype 2208 2209 Rewrite (Component_Definition (N), 2210 Make_Component_Definition (Loc, 2211 Subtype_Indication => New_Occurrence_Of (Act_T, Loc))); 2212 end; 2213 end if; 2214 2215 Set_Original_Record_Component (Id, Id); 2216 2217 if Has_Aspects (N) then 2218 Analyze_Aspect_Specifications (N, Id); 2219 end if; 2220 2221 Analyze_Dimension (N); 2222 end Analyze_Component_Declaration; 2223 2224 -------------------------- 2225 -- Analyze_Declarations -- 2226 -------------------------- 2227 2228 procedure Analyze_Declarations (L : List_Id) is 2229 Decl : Node_Id; 2230 2231 procedure Adjust_Decl; 2232 -- Adjust Decl not to include implicit label declarations, since these 2233 -- have strange Sloc values that result in elaboration check problems. 2234 -- (They have the sloc of the label as found in the source, and that 2235 -- is ahead of the current declarative part). 2236 2237 procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id); 2238 -- Create the subprogram bodies which verify the run-time semantics of 2239 -- the pragmas listed below for each elibigle type found in declarative 2240 -- list Decls. The pragmas are: 2241 -- 2242 -- Default_Initial_Condition 2243 -- Invariant 2244 -- Type_Invariant 2245 -- 2246 -- Context denotes the owner of the declarative list. 2247 2248 procedure Check_Entry_Contracts; 2249 -- Perform a preanalysis of the pre- and postconditions of an entry 2250 -- declaration. This must be done before full resolution and creation 2251 -- of the parameter block, etc. to catch illegal uses within the 2252 -- contract expression. Full analysis of the expression is done when 2253 -- the contract is processed. 2254 2255 function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean; 2256 -- Check if a nested package has entities within it that rely on library 2257 -- level private types where the full view has not been completed for 2258 -- the purposes of checking if it is acceptable to freeze an expression 2259 -- function at the point of declaration. 2260 2261 procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id); 2262 -- Determine whether Body_Decl denotes the body of a late controlled 2263 -- primitive (either Initialize, Adjust or Finalize). If this is the 2264 -- case, add a proper spec if the body lacks one. The spec is inserted 2265 -- before Body_Decl and immediately analyzed. 2266 2267 procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id); 2268 -- Spec_Id is the entity of a package that may define abstract states, 2269 -- and in the case of a child unit, whose ancestors may define abstract 2270 -- states. If the states have partial visible refinement, remove the 2271 -- partial visibility of each constituent at the end of the package 2272 -- spec and body declarations. 2273 2274 procedure Remove_Visible_Refinements (Spec_Id : Entity_Id); 2275 -- Spec_Id is the entity of a package that may define abstract states. 2276 -- If the states have visible refinement, remove the visibility of each 2277 -- constituent at the end of the package body declaration. 2278 2279 procedure Resolve_Aspects; 2280 -- Utility to resolve the expressions of aspects at the end of a list of 2281 -- declarations, or before a declaration that freezes previous entities, 2282 -- such as in a subprogram body. 2283 2284 ----------------- 2285 -- Adjust_Decl -- 2286 ----------------- 2287 2288 procedure Adjust_Decl is 2289 begin 2290 while Present (Prev (Decl)) 2291 and then Nkind (Decl) = N_Implicit_Label_Declaration 2292 loop 2293 Prev (Decl); 2294 end loop; 2295 end Adjust_Decl; 2296 2297 ---------------------------- 2298 -- Build_Assertion_Bodies -- 2299 ---------------------------- 2300 2301 procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id) is 2302 procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id); 2303 -- Create the subprogram bodies which verify the run-time semantics 2304 -- of the pragmas listed below for type Typ. The pragmas are: 2305 -- 2306 -- Default_Initial_Condition 2307 -- Invariant 2308 -- Type_Invariant 2309 2310 ------------------------------------- 2311 -- Build_Assertion_Bodies_For_Type -- 2312 ------------------------------------- 2313 2314 procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id) is 2315 begin 2316 if Nkind (Context) = N_Package_Specification then 2317 2318 -- Preanalyze and resolve the class-wide invariants of an 2319 -- interface at the end of whichever declarative part has the 2320 -- interface type. Note that an interface may be declared in 2321 -- any non-package declarative part, but reaching the end of 2322 -- such a declarative part will always freeze the type and 2323 -- generate the invariant procedure (see Freeze_Type). 2324 2325 if Is_Interface (Typ) then 2326 2327 -- Interfaces are treated as the partial view of a private 2328 -- type, in order to achieve uniformity with the general 2329 -- case. As a result, an interface receives only a "partial" 2330 -- invariant procedure, which is never called. 2331 2332 if Has_Own_Invariants (Typ) then 2333 Build_Invariant_Procedure_Body 2334 (Typ => Typ, 2335 Partial_Invariant => True); 2336 end if; 2337 2338 elsif Decls = Visible_Declarations (Context) then 2339 -- Preanalyze and resolve the invariants of a private type 2340 -- at the end of the visible declarations to catch potential 2341 -- errors. Inherited class-wide invariants are not included 2342 -- because they have already been resolved. 2343 2344 if Ekind (Typ) in E_Limited_Private_Type 2345 | E_Private_Type 2346 | E_Record_Type_With_Private 2347 and then Has_Own_Invariants (Typ) 2348 then 2349 Build_Invariant_Procedure_Body 2350 (Typ => Typ, 2351 Partial_Invariant => True); 2352 end if; 2353 2354 -- Preanalyze and resolve the Default_Initial_Condition 2355 -- assertion expression at the end of the declarations to 2356 -- catch any errors. 2357 2358 if Ekind (Typ) in E_Limited_Private_Type 2359 | E_Private_Type 2360 | E_Record_Type_With_Private 2361 and then Has_Own_DIC (Typ) 2362 then 2363 Build_DIC_Procedure_Body 2364 (Typ => Typ, 2365 Partial_DIC => True); 2366 end if; 2367 2368 elsif Decls = Private_Declarations (Context) then 2369 2370 -- Preanalyze and resolve the invariants of a private type's 2371 -- full view at the end of the private declarations to catch 2372 -- potential errors. 2373 2374 if (not Is_Private_Type (Typ) 2375 or else Present (Underlying_Full_View (Typ))) 2376 and then Has_Private_Declaration (Typ) 2377 and then Has_Invariants (Typ) 2378 then 2379 Build_Invariant_Procedure_Body (Typ); 2380 end if; 2381 2382 if (not Is_Private_Type (Typ) 2383 or else Present (Underlying_Full_View (Typ))) 2384 and then Has_Private_Declaration (Typ) 2385 and then Has_DIC (Typ) 2386 then 2387 Build_DIC_Procedure_Body (Typ); 2388 end if; 2389 end if; 2390 end if; 2391 end Build_Assertion_Bodies_For_Type; 2392 2393 -- Local variables 2394 2395 Decl : Node_Id; 2396 Decl_Id : Entity_Id; 2397 2398 -- Start of processing for Build_Assertion_Bodies 2399 2400 begin 2401 Decl := First (Decls); 2402 while Present (Decl) loop 2403 if Is_Declaration (Decl) then 2404 Decl_Id := Defining_Entity (Decl); 2405 2406 if Is_Type (Decl_Id) then 2407 Build_Assertion_Bodies_For_Type (Decl_Id); 2408 end if; 2409 end if; 2410 2411 Next (Decl); 2412 end loop; 2413 end Build_Assertion_Bodies; 2414 2415 --------------------------- 2416 -- Check_Entry_Contracts -- 2417 --------------------------- 2418 2419 procedure Check_Entry_Contracts is 2420 ASN : Node_Id; 2421 Ent : Entity_Id; 2422 Exp : Node_Id; 2423 2424 begin 2425 Ent := First_Entity (Current_Scope); 2426 while Present (Ent) loop 2427 2428 -- This only concerns entries with pre/postconditions 2429 2430 if Ekind (Ent) = E_Entry 2431 and then Present (Contract (Ent)) 2432 and then Present (Pre_Post_Conditions (Contract (Ent))) 2433 then 2434 ASN := Pre_Post_Conditions (Contract (Ent)); 2435 Push_Scope (Ent); 2436 Install_Formals (Ent); 2437 2438 -- Pre/postconditions are rewritten as Check pragmas. Analysis 2439 -- is performed on a copy of the pragma expression, to prevent 2440 -- modifying the original expression. 2441 2442 while Present (ASN) loop 2443 if Nkind (ASN) = N_Pragma then 2444 Exp := 2445 New_Copy_Tree 2446 (Expression 2447 (First (Pragma_Argument_Associations (ASN)))); 2448 Set_Parent (Exp, ASN); 2449 2450 Preanalyze_Assert_Expression (Exp, Standard_Boolean); 2451 end if; 2452 2453 ASN := Next_Pragma (ASN); 2454 end loop; 2455 2456 End_Scope; 2457 end if; 2458 2459 Next_Entity (Ent); 2460 end loop; 2461 end Check_Entry_Contracts; 2462 2463 ---------------------------------- 2464 -- Contains_Lib_Incomplete_Type -- 2465 ---------------------------------- 2466 2467 function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean is 2468 Curr : Entity_Id; 2469 2470 begin 2471 -- Avoid looking through scopes that do not meet the precondition of 2472 -- Pkg not being within a library unit spec. 2473 2474 if not Is_Compilation_Unit (Pkg) 2475 and then not Is_Generic_Instance (Pkg) 2476 and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg)) 2477 then 2478 -- Loop through all entities in the current scope to identify 2479 -- an entity that depends on a private type. 2480 2481 Curr := First_Entity (Pkg); 2482 loop 2483 if Nkind (Curr) in N_Entity 2484 and then Depends_On_Private (Curr) 2485 then 2486 return True; 2487 end if; 2488 2489 exit when Last_Entity (Current_Scope) = Curr; 2490 Next_Entity (Curr); 2491 end loop; 2492 end if; 2493 2494 return False; 2495 end Contains_Lib_Incomplete_Type; 2496 2497 -------------------------------------- 2498 -- Handle_Late_Controlled_Primitive -- 2499 -------------------------------------- 2500 2501 procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id) is 2502 Body_Spec : constant Node_Id := Specification (Body_Decl); 2503 Body_Id : constant Entity_Id := Defining_Entity (Body_Spec); 2504 Loc : constant Source_Ptr := Sloc (Body_Id); 2505 Params : constant List_Id := 2506 Parameter_Specifications (Body_Spec); 2507 Spec : Node_Id; 2508 Spec_Id : Entity_Id; 2509 Typ : Node_Id; 2510 2511 begin 2512 -- Consider only procedure bodies whose name matches one of the three 2513 -- controlled primitives. 2514 2515 if Nkind (Body_Spec) /= N_Procedure_Specification 2516 or else Chars (Body_Id) not in Name_Adjust 2517 | Name_Finalize 2518 | Name_Initialize 2519 then 2520 return; 2521 2522 -- A controlled primitive must have exactly one formal which is not 2523 -- an anonymous access type. 2524 2525 elsif List_Length (Params) /= 1 then 2526 return; 2527 end if; 2528 2529 Typ := Parameter_Type (First (Params)); 2530 2531 if Nkind (Typ) = N_Access_Definition then 2532 return; 2533 end if; 2534 2535 Find_Type (Typ); 2536 2537 -- The type of the formal must be derived from [Limited_]Controlled 2538 2539 if not Is_Controlled (Entity (Typ)) then 2540 return; 2541 end if; 2542 2543 -- Check whether a specification exists for this body. We do not 2544 -- analyze the spec of the body in full, because it will be analyzed 2545 -- again when the body is properly analyzed, and we cannot create 2546 -- duplicate entries in the formals chain. We look for an explicit 2547 -- specification because the body may be an overriding operation and 2548 -- an inherited spec may be present. 2549 2550 Spec_Id := Current_Entity (Body_Id); 2551 2552 while Present (Spec_Id) loop 2553 if Ekind (Spec_Id) in E_Procedure | E_Generic_Procedure 2554 and then Scope (Spec_Id) = Current_Scope 2555 and then Present (First_Formal (Spec_Id)) 2556 and then No (Next_Formal (First_Formal (Spec_Id))) 2557 and then Etype (First_Formal (Spec_Id)) = Entity (Typ) 2558 and then Comes_From_Source (Spec_Id) 2559 then 2560 return; 2561 end if; 2562 2563 Spec_Id := Homonym (Spec_Id); 2564 end loop; 2565 2566 -- At this point the body is known to be a late controlled primitive. 2567 -- Generate a matching spec and insert it before the body. Note the 2568 -- use of Copy_Separate_Tree - we want an entirely separate semantic 2569 -- tree in this case. 2570 2571 Spec := Copy_Separate_Tree (Body_Spec); 2572 2573 -- Ensure that the subprogram declaration does not inherit the null 2574 -- indicator from the body as we now have a proper spec/body pair. 2575 2576 Set_Null_Present (Spec, False); 2577 2578 -- Ensure that the freeze node is inserted after the declaration of 2579 -- the primitive since its expansion will freeze the primitive. 2580 2581 Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); 2582 2583 Insert_Before_And_Analyze (Body_Decl, Decl); 2584 end Handle_Late_Controlled_Primitive; 2585 2586 ---------------------------------------- 2587 -- Remove_Partial_Visible_Refinements -- 2588 ---------------------------------------- 2589 2590 procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id) is 2591 State_Elmt : Elmt_Id; 2592 begin 2593 if Present (Abstract_States (Spec_Id)) then 2594 State_Elmt := First_Elmt (Abstract_States (Spec_Id)); 2595 while Present (State_Elmt) loop 2596 Set_Has_Partial_Visible_Refinement (Node (State_Elmt), False); 2597 Next_Elmt (State_Elmt); 2598 end loop; 2599 end if; 2600 2601 -- For a child unit, also hide the partial state refinement from 2602 -- ancestor packages. 2603 2604 if Is_Child_Unit (Spec_Id) then 2605 Remove_Partial_Visible_Refinements (Scope (Spec_Id)); 2606 end if; 2607 end Remove_Partial_Visible_Refinements; 2608 2609 -------------------------------- 2610 -- Remove_Visible_Refinements -- 2611 -------------------------------- 2612 2613 procedure Remove_Visible_Refinements (Spec_Id : Entity_Id) is 2614 State_Elmt : Elmt_Id; 2615 begin 2616 if Present (Abstract_States (Spec_Id)) then 2617 State_Elmt := First_Elmt (Abstract_States (Spec_Id)); 2618 while Present (State_Elmt) loop 2619 Set_Has_Visible_Refinement (Node (State_Elmt), False); 2620 Next_Elmt (State_Elmt); 2621 end loop; 2622 end if; 2623 end Remove_Visible_Refinements; 2624 2625 --------------------- 2626 -- Resolve_Aspects -- 2627 --------------------- 2628 2629 procedure Resolve_Aspects is 2630 E : Entity_Id; 2631 2632 begin 2633 E := First_Entity (Current_Scope); 2634 while Present (E) loop 2635 Resolve_Aspect_Expressions (E); 2636 Next_Entity (E); 2637 end loop; 2638 end Resolve_Aspects; 2639 2640 -- Local variables 2641 2642 Context : Node_Id := Empty; 2643 Ctrl_Typ : Entity_Id := Empty; 2644 Freeze_From : Entity_Id := Empty; 2645 Next_Decl : Node_Id; 2646 2647 -- Start of processing for Analyze_Declarations 2648 2649 begin 2650 Decl := First (L); 2651 while Present (Decl) loop 2652 2653 -- Complete analysis of declaration 2654 2655 Analyze (Decl); 2656 Next_Decl := Next (Decl); 2657 2658 if No (Freeze_From) then 2659 Freeze_From := First_Entity (Current_Scope); 2660 end if; 2661 2662 -- Remember if the declaration we just processed is the full type 2663 -- declaration of a controlled type (to handle late overriding of 2664 -- initialize, adjust or finalize). 2665 2666 if Nkind (Decl) = N_Full_Type_Declaration 2667 and then Is_Controlled (Defining_Identifier (Decl)) 2668 then 2669 Ctrl_Typ := Defining_Identifier (Decl); 2670 end if; 2671 2672 -- At the end of a declarative part, freeze remaining entities 2673 -- declared in it. The end of the visible declarations of package 2674 -- specification is not the end of a declarative part if private 2675 -- declarations are present. The end of a package declaration is a 2676 -- freezing point only if it a library package. A task definition or 2677 -- protected type definition is not a freeze point either. Finally, 2678 -- we do not freeze entities in generic scopes, because there is no 2679 -- code generated for them and freeze nodes will be generated for 2680 -- the instance. 2681 2682 -- The end of a package instantiation is not a freeze point, but 2683 -- for now we make it one, because the generic body is inserted 2684 -- (currently) immediately after. Generic instantiations will not 2685 -- be a freeze point once delayed freezing of bodies is implemented. 2686 -- (This is needed in any case for early instantiations ???). 2687 2688 if No (Next_Decl) then 2689 if Nkind (Parent (L)) = N_Component_List then 2690 null; 2691 2692 elsif Nkind (Parent (L)) in 2693 N_Protected_Definition | N_Task_Definition 2694 then 2695 Check_Entry_Contracts; 2696 2697 elsif Nkind (Parent (L)) /= N_Package_Specification then 2698 if Nkind (Parent (L)) = N_Package_Body then 2699 Freeze_From := First_Entity (Current_Scope); 2700 end if; 2701 2702 -- There may have been several freezing points previously, 2703 -- for example object declarations or subprogram bodies, but 2704 -- at the end of a declarative part we check freezing from 2705 -- the beginning, even though entities may already be frozen, 2706 -- in order to perform visibility checks on delayed aspects. 2707 2708 Adjust_Decl; 2709 2710 -- If the current scope is a generic subprogram body. Skip the 2711 -- generic formal parameters that are not frozen here. 2712 2713 if Is_Subprogram (Current_Scope) 2714 and then Nkind (Unit_Declaration_Node (Current_Scope)) = 2715 N_Generic_Subprogram_Declaration 2716 and then Present (First_Entity (Current_Scope)) 2717 then 2718 while Is_Generic_Formal (Freeze_From) loop 2719 Next_Entity (Freeze_From); 2720 end loop; 2721 2722 Freeze_All (Freeze_From, Decl); 2723 Freeze_From := Last_Entity (Current_Scope); 2724 2725 else 2726 -- For declarations in a subprogram body there is no issue 2727 -- with name resolution in aspect specifications. 2728 2729 Freeze_All (First_Entity (Current_Scope), Decl); 2730 Freeze_From := Last_Entity (Current_Scope); 2731 end if; 2732 2733 -- Current scope is a package specification 2734 2735 elsif Scope (Current_Scope) /= Standard_Standard 2736 and then not Is_Child_Unit (Current_Scope) 2737 and then No (Generic_Parent (Parent (L))) 2738 then 2739 -- ARM rule 13.1.1(11/3): usage names in aspect definitions are 2740 -- resolved at the end of the immediately enclosing declaration 2741 -- list (AI05-0183-1). 2742 2743 Resolve_Aspects; 2744 2745 elsif L /= Visible_Declarations (Parent (L)) 2746 or else No (Private_Declarations (Parent (L))) 2747 or else Is_Empty_List (Private_Declarations (Parent (L))) 2748 then 2749 Adjust_Decl; 2750 2751 -- End of a package declaration 2752 2753 -- This is a freeze point because it is the end of a 2754 -- compilation unit. 2755 2756 Freeze_All (First_Entity (Current_Scope), Decl); 2757 Freeze_From := Last_Entity (Current_Scope); 2758 2759 -- At the end of the visible declarations the expressions in 2760 -- aspects of all entities declared so far must be resolved. 2761 -- The entities themselves might be frozen later, and the 2762 -- generated pragmas and attribute definition clauses analyzed 2763 -- in full at that point, but name resolution must take place 2764 -- now. 2765 -- In addition to being the proper semantics, this is mandatory 2766 -- within generic units, because global name capture requires 2767 -- those expressions to be analyzed, given that the generated 2768 -- pragmas do not appear in the original generic tree. 2769 2770 elsif Serious_Errors_Detected = 0 then 2771 Resolve_Aspects; 2772 end if; 2773 2774 -- If next node is a body then freeze all types before the body. 2775 -- An exception occurs for some expander-generated bodies. If these 2776 -- are generated at places where in general language rules would not 2777 -- allow a freeze point, then we assume that the expander has 2778 -- explicitly checked that all required types are properly frozen, 2779 -- and we do not cause general freezing here. This special circuit 2780 -- is used when the encountered body is marked as having already 2781 -- been analyzed. 2782 2783 -- In all other cases (bodies that come from source, and expander 2784 -- generated bodies that have not been analyzed yet), freeze all 2785 -- types now. Note that in the latter case, the expander must take 2786 -- care to attach the bodies at a proper place in the tree so as to 2787 -- not cause unwanted freezing at that point. 2788 2789 -- It is also necessary to check for a case where both an expression 2790 -- function is used and the current scope depends on an incomplete 2791 -- private type from a library unit, otherwise premature freezing of 2792 -- the private type will occur. 2793 2794 elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) 2795 and then ((Nkind (Next_Decl) /= N_Subprogram_Body 2796 or else not Was_Expression_Function (Next_Decl)) 2797 or else (not Is_Ignored_Ghost_Entity (Current_Scope) 2798 and then not Contains_Lib_Incomplete_Type 2799 (Current_Scope))) 2800 then 2801 -- When a controlled type is frozen, the expander generates stream 2802 -- and controlled-type support routines. If the freeze is caused 2803 -- by the stand-alone body of Initialize, Adjust, or Finalize, the 2804 -- expander will end up using the wrong version of these routines, 2805 -- as the body has not been processed yet. To remedy this, detect 2806 -- a late controlled primitive and create a proper spec for it. 2807 -- This ensures that the primitive will override its inherited 2808 -- counterpart before the freeze takes place. 2809 2810 -- If the declaration we just processed is a body, do not attempt 2811 -- to examine Next_Decl as the late primitive idiom can only apply 2812 -- to the first encountered body. 2813 2814 -- ??? A cleaner approach may be possible and/or this solution 2815 -- could be extended to general-purpose late primitives, TBD. 2816 2817 if Present (Ctrl_Typ) then 2818 2819 -- No need to continue searching for late body overriding if 2820 -- the controlled type is already frozen. 2821 2822 if Is_Frozen (Ctrl_Typ) then 2823 Ctrl_Typ := Empty; 2824 2825 elsif Nkind (Next_Decl) = N_Subprogram_Body then 2826 Handle_Late_Controlled_Primitive (Next_Decl); 2827 end if; 2828 end if; 2829 2830 Adjust_Decl; 2831 2832 -- The generated body of an expression function does not freeze, 2833 -- unless it is a completion, in which case only the expression 2834 -- itself freezes. This is handled when the body itself is 2835 -- analyzed (see Freeze_Expr_Types, sem_ch6.adb). 2836 2837 Freeze_All (Freeze_From, Decl); 2838 Freeze_From := Last_Entity (Current_Scope); 2839 end if; 2840 2841 Decl := Next_Decl; 2842 end loop; 2843 2844 -- Post-freezing actions 2845 2846 if Present (L) then 2847 Context := Parent (L); 2848 2849 -- Certain contract annotations have forward visibility semantics and 2850 -- must be analyzed after all declarative items have been processed. 2851 -- This timing ensures that entities referenced by such contracts are 2852 -- visible. 2853 2854 -- Analyze the contract of an immediately enclosing package spec or 2855 -- body first because other contracts may depend on its information. 2856 2857 if Nkind (Context) = N_Package_Body then 2858 Analyze_Package_Body_Contract (Defining_Entity (Context)); 2859 2860 elsif Nkind (Context) = N_Package_Specification then 2861 Analyze_Package_Contract (Defining_Entity (Context)); 2862 end if; 2863 2864 -- Analyze the contracts of various constructs in the declarative 2865 -- list. 2866 2867 Analyze_Contracts (L); 2868 2869 if Nkind (Context) = N_Package_Body then 2870 2871 -- Ensure that all abstract states and objects declared in the 2872 -- state space of a package body are utilized as constituents. 2873 2874 Check_Unused_Body_States (Defining_Entity (Context)); 2875 2876 -- State refinements are visible up to the end of the package body 2877 -- declarations. Hide the state refinements from visibility to 2878 -- restore the original state conditions. 2879 2880 Remove_Visible_Refinements (Corresponding_Spec (Context)); 2881 Remove_Partial_Visible_Refinements (Corresponding_Spec (Context)); 2882 2883 elsif Nkind (Context) = N_Package_Specification then 2884 2885 -- Partial state refinements are visible up to the end of the 2886 -- package spec declarations. Hide the partial state refinements 2887 -- from visibility to restore the original state conditions. 2888 2889 Remove_Partial_Visible_Refinements (Defining_Entity (Context)); 2890 end if; 2891 2892 -- Verify that all abstract states found in any package declared in 2893 -- the input declarative list have proper refinements. The check is 2894 -- performed only when the context denotes a block, entry, package, 2895 -- protected, subprogram, or task body (SPARK RM 7.2.2(3)). 2896 2897 Check_State_Refinements (Context); 2898 2899 -- Create the subprogram bodies which verify the run-time semantics 2900 -- of pragmas Default_Initial_Condition and [Type_]Invariant for all 2901 -- types within the current declarative list. This ensures that all 2902 -- assertion expressions are preanalyzed and resolved at the end of 2903 -- the declarative part. Note that the resolution happens even when 2904 -- freezing does not take place. 2905 2906 Build_Assertion_Bodies (L, Context); 2907 end if; 2908 end Analyze_Declarations; 2909 2910 ----------------------------------- 2911 -- Analyze_Full_Type_Declaration -- 2912 ----------------------------------- 2913 2914 procedure Analyze_Full_Type_Declaration (N : Node_Id) is 2915 Def : constant Node_Id := Type_Definition (N); 2916 Def_Id : constant Entity_Id := Defining_Identifier (N); 2917 T : Entity_Id; 2918 Prev : Entity_Id; 2919 2920 Is_Remote : constant Boolean := 2921 (Is_Remote_Types (Current_Scope) 2922 or else Is_Remote_Call_Interface (Current_Scope)) 2923 and then not (In_Private_Part (Current_Scope) 2924 or else In_Package_Body (Current_Scope)); 2925 2926 procedure Check_Nonoverridable_Aspects; 2927 -- Apply the rule in RM 13.1.1(18.4/4) on iterator aspects that cannot 2928 -- be overridden, and can only be confirmed on derivation. 2929 2930 procedure Check_Ops_From_Incomplete_Type; 2931 -- If there is a tagged incomplete partial view of the type, traverse 2932 -- the primitives of the incomplete view and change the type of any 2933 -- controlling formals and result to indicate the full view. The 2934 -- primitives will be added to the full type's primitive operations 2935 -- list later in Sem_Disp.Check_Operation_From_Incomplete_Type (which 2936 -- is called from Process_Incomplete_Dependents). 2937 2938 ---------------------------------- 2939 -- Check_Nonoverridable_Aspects -- 2940 ---------------------------------- 2941 2942 procedure Check_Nonoverridable_Aspects is 2943 function Get_Aspect_Spec 2944 (Specs : List_Id; 2945 Aspect_Name : Name_Id) return Node_Id; 2946 -- Check whether a list of aspect specifications includes an entry 2947 -- for a specific aspect. The list is either that of a partial or 2948 -- a full view. 2949 2950 --------------------- 2951 -- Get_Aspect_Spec -- 2952 --------------------- 2953 2954 function Get_Aspect_Spec 2955 (Specs : List_Id; 2956 Aspect_Name : Name_Id) return Node_Id 2957 is 2958 Spec : Node_Id; 2959 2960 begin 2961 Spec := First (Specs); 2962 while Present (Spec) loop 2963 if Chars (Identifier (Spec)) = Aspect_Name then 2964 return Spec; 2965 end if; 2966 Next (Spec); 2967 end loop; 2968 2969 return Empty; 2970 end Get_Aspect_Spec; 2971 2972 -- Local variables 2973 2974 Prev_Aspects : constant List_Id := 2975 Aspect_Specifications (Parent (Def_Id)); 2976 Par_Type : Entity_Id; 2977 Prev_Aspect : Node_Id; 2978 2979 -- Start of processing for Check_Nonoverridable_Aspects 2980 2981 begin 2982 -- Get parent type of derived type. Note that Prev is the entity in 2983 -- the partial declaration, but its contents are now those of full 2984 -- view, while Def_Id reflects the partial view. 2985 2986 if Is_Private_Type (Def_Id) then 2987 Par_Type := Etype (Full_View (Def_Id)); 2988 else 2989 Par_Type := Etype (Def_Id); 2990 end if; 2991 2992 -- If there is an inherited Implicit_Dereference, verify that it is 2993 -- made explicit in the partial view. 2994 2995 if Has_Discriminants (Base_Type (Par_Type)) 2996 and then Nkind (Parent (Prev)) = N_Full_Type_Declaration 2997 and then Present (Discriminant_Specifications (Parent (Prev))) 2998 and then Present (Get_Reference_Discriminant (Par_Type)) 2999 then 3000 Prev_Aspect := 3001 Get_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference); 3002 3003 if No (Prev_Aspect) 3004 and then Present 3005 (Discriminant_Specifications 3006 (Original_Node (Parent (Prev)))) 3007 then 3008 Error_Msg_N 3009 ("type does not inherit implicit dereference", Prev); 3010 3011 else 3012 -- If one of the views has the aspect specified, verify that it 3013 -- is consistent with that of the parent. 3014 3015 declare 3016 Cur_Discr : constant Entity_Id := 3017 Get_Reference_Discriminant (Prev); 3018 Par_Discr : constant Entity_Id := 3019 Get_Reference_Discriminant (Par_Type); 3020 3021 begin 3022 if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then 3023 Error_Msg_N 3024 ("aspect inconsistent with that of parent", N); 3025 end if; 3026 3027 -- Check that specification in partial view matches the 3028 -- inherited aspect. Compare names directly because aspect 3029 -- expression may not be analyzed. 3030 3031 if Present (Prev_Aspect) 3032 and then Nkind (Expression (Prev_Aspect)) = N_Identifier 3033 and then Chars (Expression (Prev_Aspect)) /= 3034 Chars (Cur_Discr) 3035 then 3036 Error_Msg_N 3037 ("aspect inconsistent with that of parent", N); 3038 end if; 3039 end; 3040 end if; 3041 end if; 3042 3043 -- TBD : other nonoverridable aspects. 3044 end Check_Nonoverridable_Aspects; 3045 3046 ------------------------------------ 3047 -- Check_Ops_From_Incomplete_Type -- 3048 ------------------------------------ 3049 3050 procedure Check_Ops_From_Incomplete_Type is 3051 Elmt : Elmt_Id; 3052 Formal : Entity_Id; 3053 Op : Entity_Id; 3054 3055 begin 3056 if Prev /= T 3057 and then Ekind (Prev) = E_Incomplete_Type 3058 and then Is_Tagged_Type (Prev) 3059 and then Is_Tagged_Type (T) 3060 then 3061 Elmt := First_Elmt (Primitive_Operations (Prev)); 3062 while Present (Elmt) loop 3063 Op := Node (Elmt); 3064 3065 Formal := First_Formal (Op); 3066 while Present (Formal) loop 3067 if Etype (Formal) = Prev then 3068 Set_Etype (Formal, T); 3069 end if; 3070 3071 Next_Formal (Formal); 3072 end loop; 3073 3074 if Etype (Op) = Prev then 3075 Set_Etype (Op, T); 3076 end if; 3077 3078 Next_Elmt (Elmt); 3079 end loop; 3080 end if; 3081 end Check_Ops_From_Incomplete_Type; 3082 3083 -- Start of processing for Analyze_Full_Type_Declaration 3084 3085 begin 3086 Prev := Find_Type_Name (N); 3087 3088 -- The full view, if present, now points to the current type. If there 3089 -- is an incomplete partial view, set a link to it, to simplify the 3090 -- retrieval of primitive operations of the type. 3091 3092 -- Ada 2005 (AI-50217): If the type was previously decorated when 3093 -- imported through a LIMITED WITH clause, it appears as incomplete 3094 -- but has no full view. 3095 3096 if Ekind (Prev) = E_Incomplete_Type 3097 and then Present (Full_View (Prev)) 3098 then 3099 T := Full_View (Prev); 3100 Set_Incomplete_View (N, Parent (Prev)); 3101 else 3102 T := Prev; 3103 end if; 3104 3105 Set_Is_Pure (T, Is_Pure (Current_Scope)); 3106 3107 -- We set the flag Is_First_Subtype here. It is needed to set the 3108 -- corresponding flag for the Implicit class-wide-type created 3109 -- during tagged types processing. 3110 3111 Set_Is_First_Subtype (T, True); 3112 3113 -- Only composite types other than array types are allowed to have 3114 -- discriminants. 3115 3116 case Nkind (Def) is 3117 3118 -- For derived types, the rule will be checked once we've figured 3119 -- out the parent type. 3120 3121 when N_Derived_Type_Definition => 3122 null; 3123 3124 -- For record types, discriminants are allowed. 3125 3126 when N_Record_Definition => 3127 null; 3128 3129 when others => 3130 if Present (Discriminant_Specifications (N)) then 3131 Error_Msg_N 3132 ("elementary or array type cannot have discriminants", 3133 Defining_Identifier 3134 (First (Discriminant_Specifications (N)))); 3135 end if; 3136 end case; 3137 3138 -- Elaborate the type definition according to kind, and generate 3139 -- subsidiary (implicit) subtypes where needed. We skip this if it was 3140 -- already done (this happens during the reanalysis that follows a call 3141 -- to the high level optimizer). 3142 3143 if not Analyzed (T) then 3144 Set_Analyzed (T); 3145 3146 -- Set the SPARK mode from the current context 3147 3148 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 3149 Set_SPARK_Pragma_Inherited (T); 3150 3151 case Nkind (Def) is 3152 when N_Access_To_Subprogram_Definition => 3153 Access_Subprogram_Declaration (T, Def); 3154 3155 -- If this is a remote access to subprogram, we must create the 3156 -- equivalent fat pointer type, and related subprograms. 3157 3158 if Is_Remote then 3159 Process_Remote_AST_Declaration (N); 3160 end if; 3161 3162 -- Validate categorization rule against access type declaration 3163 -- usually a violation in Pure unit, Shared_Passive unit. 3164 3165 Validate_Access_Type_Declaration (T, N); 3166 3167 -- If the type has contracts, we create the corresponding 3168 -- wrapper at once, before analyzing the aspect specifications, 3169 -- so that pre/postconditions can be handled directly on the 3170 -- generated wrapper. 3171 3172 if Ada_Version >= Ada_2020 3173 and then Present (Aspect_Specifications (N)) 3174 then 3175 Build_Access_Subprogram_Wrapper (N); 3176 end if; 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 -- Some common processing for all types 3250 3251 Set_Depends_On_Private (T, Has_Private_Component (T)); 3252 Check_Ops_From_Incomplete_Type; 3253 3254 -- Both the declared entity, and its anonymous base type if one was 3255 -- created, need freeze nodes allocated. 3256 3257 declare 3258 B : constant Entity_Id := Base_Type (T); 3259 3260 begin 3261 -- In the case where the base type differs from the first subtype, we 3262 -- pre-allocate a freeze node, and set the proper link to the first 3263 -- subtype. Freeze_Entity will use this preallocated freeze node when 3264 -- it freezes the entity. 3265 3266 -- This does not apply if the base type is a generic type, whose 3267 -- declaration is independent of the current derived definition. 3268 3269 if B /= T and then not Is_Generic_Type (B) then 3270 Ensure_Freeze_Node (B); 3271 Set_First_Subtype_Link (Freeze_Node (B), T); 3272 end if; 3273 3274 -- A type that is imported through a limited_with clause cannot 3275 -- generate any code, and thus need not be frozen. However, an access 3276 -- type with an imported designated type needs a finalization list, 3277 -- which may be referenced in some other package that has non-limited 3278 -- visibility on the designated type. Thus we must create the 3279 -- finalization list at the point the access type is frozen, to 3280 -- prevent unsatisfied references at link time. 3281 3282 if not From_Limited_With (T) or else Is_Access_Type (T) then 3283 Set_Has_Delayed_Freeze (T); 3284 end if; 3285 end; 3286 3287 -- Case where T is the full declaration of some private type which has 3288 -- been swapped in Defining_Identifier (N). 3289 3290 if T /= Def_Id and then Is_Private_Type (Def_Id) then 3291 Process_Full_View (N, T, Def_Id); 3292 3293 -- Record the reference. The form of this is a little strange, since 3294 -- the full declaration has been swapped in. So the first parameter 3295 -- here represents the entity to which a reference is made which is 3296 -- the "real" entity, i.e. the one swapped in, and the second 3297 -- parameter provides the reference location. 3298 3299 -- Also, we want to kill Has_Pragma_Unreferenced temporarily here 3300 -- since we don't want a complaint about the full type being an 3301 -- unwanted reference to the private type 3302 3303 declare 3304 B : constant Boolean := Has_Pragma_Unreferenced (T); 3305 begin 3306 Set_Has_Pragma_Unreferenced (T, False); 3307 Generate_Reference (T, T, 'c'); 3308 Set_Has_Pragma_Unreferenced (T, B); 3309 end; 3310 3311 Set_Completion_Referenced (Def_Id); 3312 3313 -- For completion of incomplete type, process incomplete dependents 3314 -- and always mark the full type as referenced (it is the incomplete 3315 -- type that we get for any real reference). 3316 3317 elsif Ekind (Prev) = E_Incomplete_Type then 3318 Process_Incomplete_Dependents (N, T, Prev); 3319 Generate_Reference (Prev, Def_Id, 'c'); 3320 Set_Completion_Referenced (Def_Id); 3321 3322 -- If not private type or incomplete type completion, this is a real 3323 -- definition of a new entity, so record it. 3324 3325 else 3326 Generate_Definition (Def_Id); 3327 end if; 3328 3329 -- Propagate any pending access types whose finalization masters need to 3330 -- be fully initialized from the partial to the full view. Guard against 3331 -- an illegal full view that remains unanalyzed. 3332 3333 if Is_Type (Def_Id) and then Is_Incomplete_Or_Private_Type (Prev) then 3334 Set_Pending_Access_Types (Def_Id, Pending_Access_Types (Prev)); 3335 end if; 3336 3337 if Chars (Scope (Def_Id)) = Name_System 3338 and then Chars (Def_Id) = Name_Address 3339 and then In_Predefined_Unit (N) 3340 then 3341 Set_Is_Descendant_Of_Address (Def_Id); 3342 Set_Is_Descendant_Of_Address (Base_Type (Def_Id)); 3343 Set_Is_Descendant_Of_Address (Prev); 3344 end if; 3345 3346 Set_Optimize_Alignment_Flags (Def_Id); 3347 Check_Eliminated (Def_Id); 3348 3349 -- If the declaration is a completion and aspects are present, apply 3350 -- them to the entity for the type which is currently the partial 3351 -- view, but which is the one that will be frozen. 3352 3353 if Has_Aspects (N) then 3354 3355 -- In most cases the partial view is a private type, and both views 3356 -- appear in different declarative parts. In the unusual case where 3357 -- the partial view is incomplete, perform the analysis on the 3358 -- full view, to prevent freezing anomalies with the corresponding 3359 -- class-wide type, which otherwise might be frozen before the 3360 -- dispatch table is built. 3361 3362 if Prev /= Def_Id 3363 and then Ekind (Prev) /= E_Incomplete_Type 3364 then 3365 Analyze_Aspect_Specifications (N, Prev); 3366 3367 -- Normal case 3368 3369 else 3370 Analyze_Aspect_Specifications (N, Def_Id); 3371 end if; 3372 end if; 3373 3374 if Is_Derived_Type (Prev) 3375 and then Def_Id /= Prev 3376 then 3377 Check_Nonoverridable_Aspects; 3378 end if; 3379 end Analyze_Full_Type_Declaration; 3380 3381 ---------------------------------- 3382 -- Analyze_Incomplete_Type_Decl -- 3383 ---------------------------------- 3384 3385 procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is 3386 F : constant Boolean := Is_Pure (Current_Scope); 3387 T : Entity_Id; 3388 3389 begin 3390 Generate_Definition (Defining_Identifier (N)); 3391 3392 -- Process an incomplete declaration. The identifier must not have been 3393 -- declared already in the scope. However, an incomplete declaration may 3394 -- appear in the private part of a package, for a private type that has 3395 -- already been declared. 3396 3397 -- In this case, the discriminants (if any) must match 3398 3399 T := Find_Type_Name (N); 3400 3401 Set_Ekind (T, E_Incomplete_Type); 3402 Set_Etype (T, T); 3403 Set_Is_First_Subtype (T); 3404 Init_Size_Align (T); 3405 3406 -- Set the SPARK mode from the current context 3407 3408 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 3409 Set_SPARK_Pragma_Inherited (T); 3410 3411 -- Ada 2005 (AI-326): Minimum decoration to give support to tagged 3412 -- incomplete types. 3413 3414 if Tagged_Present (N) then 3415 Set_Is_Tagged_Type (T, True); 3416 Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); 3417 Make_Class_Wide_Type (T); 3418 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3419 end if; 3420 3421 Set_Stored_Constraint (T, No_Elist); 3422 3423 if Present (Discriminant_Specifications (N)) then 3424 Push_Scope (T); 3425 Process_Discriminants (N); 3426 End_Scope; 3427 end if; 3428 3429 -- If the type has discriminants, nontrivial subtypes may be declared 3430 -- before the full view of the type. The full views of those subtypes 3431 -- will be built after the full view of the type. 3432 3433 Set_Private_Dependents (T, New_Elmt_List); 3434 Set_Is_Pure (T, F); 3435 end Analyze_Incomplete_Type_Decl; 3436 3437 ----------------------------------- 3438 -- Analyze_Interface_Declaration -- 3439 ----------------------------------- 3440 3441 procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is 3442 CW : constant Entity_Id := Class_Wide_Type (T); 3443 3444 begin 3445 Set_Is_Tagged_Type (T); 3446 Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); 3447 3448 Set_Is_Limited_Record (T, Limited_Present (Def) 3449 or else Task_Present (Def) 3450 or else Protected_Present (Def) 3451 or else Synchronized_Present (Def)); 3452 3453 -- Type is abstract if full declaration carries keyword, or if previous 3454 -- partial view did. 3455 3456 Set_Is_Abstract_Type (T); 3457 Set_Is_Interface (T); 3458 3459 -- Type is a limited interface if it includes the keyword limited, task, 3460 -- protected, or synchronized. 3461 3462 Set_Is_Limited_Interface 3463 (T, Limited_Present (Def) 3464 or else Protected_Present (Def) 3465 or else Synchronized_Present (Def) 3466 or else Task_Present (Def)); 3467 3468 Set_Interfaces (T, New_Elmt_List); 3469 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3470 3471 -- Complete the decoration of the class-wide entity if it was already 3472 -- built (i.e. during the creation of the limited view) 3473 3474 if Present (CW) then 3475 Set_Is_Interface (CW); 3476 Set_Is_Limited_Interface (CW, Is_Limited_Interface (T)); 3477 end if; 3478 3479 -- Check runtime support for synchronized interfaces 3480 3481 if (Is_Task_Interface (T) 3482 or else Is_Protected_Interface (T) 3483 or else Is_Synchronized_Interface (T)) 3484 and then not RTE_Available (RE_Select_Specific_Data) 3485 then 3486 Error_Msg_CRT ("synchronized interfaces", T); 3487 end if; 3488 end Analyze_Interface_Declaration; 3489 3490 ----------------------------- 3491 -- Analyze_Itype_Reference -- 3492 ----------------------------- 3493 3494 -- Nothing to do. This node is placed in the tree only for the benefit of 3495 -- back end processing, and has no effect on the semantic processing. 3496 3497 procedure Analyze_Itype_Reference (N : Node_Id) is 3498 begin 3499 pragma Assert (Is_Itype (Itype (N))); 3500 null; 3501 end Analyze_Itype_Reference; 3502 3503 -------------------------------- 3504 -- Analyze_Number_Declaration -- 3505 -------------------------------- 3506 3507 procedure Analyze_Number_Declaration (N : Node_Id) is 3508 E : constant Node_Id := Expression (N); 3509 Id : constant Entity_Id := Defining_Identifier (N); 3510 Index : Interp_Index; 3511 It : Interp; 3512 T : Entity_Id; 3513 3514 begin 3515 Generate_Definition (Id); 3516 Enter_Name (Id); 3517 3518 -- This is an optimization of a common case of an integer literal 3519 3520 if Nkind (E) = N_Integer_Literal then 3521 Set_Is_Static_Expression (E, True); 3522 Set_Etype (E, Universal_Integer); 3523 3524 Set_Etype (Id, Universal_Integer); 3525 Set_Ekind (Id, E_Named_Integer); 3526 Set_Is_Frozen (Id, True); 3527 3528 Set_Debug_Info_Needed (Id); 3529 return; 3530 end if; 3531 3532 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3533 3534 -- Process expression, replacing error by integer zero, to avoid 3535 -- cascaded errors or aborts further along in the processing 3536 3537 -- Replace Error by integer zero, which seems least likely to cause 3538 -- cascaded errors. 3539 3540 if E = Error then 3541 Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0)); 3542 Set_Error_Posted (E); 3543 end if; 3544 3545 Analyze (E); 3546 3547 -- Verify that the expression is static and numeric. If 3548 -- the expression is overloaded, we apply the preference 3549 -- rule that favors root numeric types. 3550 3551 if not Is_Overloaded (E) then 3552 T := Etype (E); 3553 if Has_Dynamic_Predicate_Aspect (T) then 3554 Error_Msg_N 3555 ("subtype has dynamic predicate, " 3556 & "not allowed in number declaration", N); 3557 end if; 3558 3559 else 3560 T := Any_Type; 3561 3562 Get_First_Interp (E, Index, It); 3563 while Present (It.Typ) loop 3564 if (Is_Integer_Type (It.Typ) or else Is_Real_Type (It.Typ)) 3565 and then (Scope (Base_Type (It.Typ))) = Standard_Standard 3566 then 3567 if T = Any_Type then 3568 T := It.Typ; 3569 3570 elsif It.Typ = Universal_Real 3571 or else 3572 It.Typ = Universal_Integer 3573 then 3574 -- Choose universal interpretation over any other 3575 3576 T := It.Typ; 3577 exit; 3578 end if; 3579 end if; 3580 3581 Get_Next_Interp (Index, It); 3582 end loop; 3583 end if; 3584 3585 if Is_Integer_Type (T) then 3586 Resolve (E, T); 3587 Set_Etype (Id, Universal_Integer); 3588 Set_Ekind (Id, E_Named_Integer); 3589 3590 elsif Is_Real_Type (T) then 3591 3592 -- Because the real value is converted to universal_real, this is a 3593 -- legal context for a universal fixed expression. 3594 3595 if T = Universal_Fixed then 3596 declare 3597 Loc : constant Source_Ptr := Sloc (N); 3598 Conv : constant Node_Id := Make_Type_Conversion (Loc, 3599 Subtype_Mark => 3600 New_Occurrence_Of (Universal_Real, Loc), 3601 Expression => Relocate_Node (E)); 3602 3603 begin 3604 Rewrite (E, Conv); 3605 Analyze (E); 3606 end; 3607 3608 elsif T = Any_Fixed then 3609 Error_Msg_N ("illegal context for mixed mode operation", E); 3610 3611 -- Expression is of the form : universal_fixed * integer. Try to 3612 -- resolve as universal_real. 3613 3614 T := Universal_Real; 3615 Set_Etype (E, T); 3616 end if; 3617 3618 Resolve (E, T); 3619 Set_Etype (Id, Universal_Real); 3620 Set_Ekind (Id, E_Named_Real); 3621 3622 else 3623 Wrong_Type (E, Any_Numeric); 3624 Resolve (E, T); 3625 3626 Set_Etype (Id, T); 3627 Set_Ekind (Id, E_Constant); 3628 Set_Never_Set_In_Source (Id, True); 3629 Set_Is_True_Constant (Id, True); 3630 return; 3631 end if; 3632 3633 if Nkind (E) in N_Integer_Literal | N_Real_Literal then 3634 Set_Etype (E, Etype (Id)); 3635 end if; 3636 3637 if not Is_OK_Static_Expression (E) then 3638 Flag_Non_Static_Expr 3639 ("non-static expression used in number declaration!", E); 3640 Rewrite (E, Make_Integer_Literal (Sloc (N), 1)); 3641 Set_Etype (E, Any_Type); 3642 end if; 3643 3644 Analyze_Dimension (N); 3645 end Analyze_Number_Declaration; 3646 3647 -------------------------------- 3648 -- Analyze_Object_Declaration -- 3649 -------------------------------- 3650 3651 -- WARNING: This routine manages Ghost regions. Return statements must be 3652 -- replaced by gotos which jump to the end of the routine and restore the 3653 -- Ghost mode. 3654 3655 procedure Analyze_Object_Declaration (N : Node_Id) is 3656 Loc : constant Source_Ptr := Sloc (N); 3657 Id : constant Entity_Id := Defining_Identifier (N); 3658 Next_Decl : constant Node_Id := Next (N); 3659 3660 Act_T : Entity_Id; 3661 T : Entity_Id; 3662 3663 E : Node_Id := Expression (N); 3664 -- E is set to Expression (N) throughout this routine. When Expression 3665 -- (N) is modified, E is changed accordingly. 3666 3667 procedure Check_Dynamic_Object (Typ : Entity_Id); 3668 -- A library-level object with nonstatic discriminant constraints may 3669 -- require dynamic allocation. The declaration is illegal if the 3670 -- profile includes the restriction No_Implicit_Heap_Allocations. 3671 3672 procedure Check_For_Null_Excluding_Components 3673 (Obj_Typ : Entity_Id; 3674 Obj_Decl : Node_Id); 3675 -- Verify that each null-excluding component of object declaration 3676 -- Obj_Decl carrying type Obj_Typ has explicit initialization. Emit 3677 -- a compile-time warning if this is not the case. 3678 3679 function Count_Tasks (T : Entity_Id) return Uint; 3680 -- This function is called when a non-generic library level object of a 3681 -- task type is declared. Its function is to count the static number of 3682 -- tasks declared within the type (it is only called if Has_Task is set 3683 -- for T). As a side effect, if an array of tasks with nonstatic bounds 3684 -- or a variant record type is encountered, Check_Restriction is called 3685 -- indicating the count is unknown. 3686 3687 function Delayed_Aspect_Present return Boolean; 3688 -- If the declaration has an expression that is an aggregate, and it 3689 -- has aspects that require delayed analysis, the resolution of the 3690 -- aggregate must be deferred to the freeze point of the object. This 3691 -- special processing was created for address clauses, but it must 3692 -- also apply to address aspects. This must be done before the aspect 3693 -- specifications are analyzed because we must handle the aggregate 3694 -- before the analysis of the object declaration is complete. 3695 3696 -- Any other relevant delayed aspects on object declarations ??? 3697 3698 -------------------------- 3699 -- Check_Dynamic_Object -- 3700 -------------------------- 3701 3702 procedure Check_Dynamic_Object (Typ : Entity_Id) is 3703 Comp : Entity_Id; 3704 Obj_Type : Entity_Id; 3705 3706 begin 3707 Obj_Type := Typ; 3708 3709 if Is_Private_Type (Obj_Type) 3710 and then Present (Full_View (Obj_Type)) 3711 then 3712 Obj_Type := Full_View (Obj_Type); 3713 end if; 3714 3715 if Known_Static_Esize (Obj_Type) then 3716 return; 3717 end if; 3718 3719 if Restriction_Active (No_Implicit_Heap_Allocations) 3720 and then Expander_Active 3721 and then Has_Discriminants (Obj_Type) 3722 then 3723 Comp := First_Component (Obj_Type); 3724 while Present (Comp) loop 3725 if Known_Static_Esize (Etype (Comp)) 3726 or else Size_Known_At_Compile_Time (Etype (Comp)) 3727 then 3728 null; 3729 3730 elsif not Discriminated_Size (Comp) 3731 and then Comes_From_Source (Comp) 3732 then 3733 Error_Msg_NE 3734 ("component& of non-static size will violate restriction " 3735 & "No_Implicit_Heap_Allocation?", N, Comp); 3736 3737 elsif Is_Record_Type (Etype (Comp)) then 3738 Check_Dynamic_Object (Etype (Comp)); 3739 end if; 3740 3741 Next_Component (Comp); 3742 end loop; 3743 end if; 3744 end Check_Dynamic_Object; 3745 3746 ----------------------------------------- 3747 -- Check_For_Null_Excluding_Components -- 3748 ----------------------------------------- 3749 3750 procedure Check_For_Null_Excluding_Components 3751 (Obj_Typ : Entity_Id; 3752 Obj_Decl : Node_Id) 3753 is 3754 procedure Check_Component 3755 (Comp_Typ : Entity_Id; 3756 Comp_Decl : Node_Id := Empty; 3757 Array_Comp : Boolean := False); 3758 -- Apply a compile-time null-exclusion check on a component denoted 3759 -- by its declaration Comp_Decl and type Comp_Typ, and all of its 3760 -- subcomponents (if any). 3761 3762 --------------------- 3763 -- Check_Component -- 3764 --------------------- 3765 3766 procedure Check_Component 3767 (Comp_Typ : Entity_Id; 3768 Comp_Decl : Node_Id := Empty; 3769 Array_Comp : Boolean := False) 3770 is 3771 Comp : Entity_Id; 3772 T : Entity_Id; 3773 3774 begin 3775 -- Do not consider internally-generated components or those that 3776 -- are already initialized. 3777 3778 if Present (Comp_Decl) 3779 and then (not Comes_From_Source (Comp_Decl) 3780 or else Present (Expression (Comp_Decl))) 3781 then 3782 return; 3783 end if; 3784 3785 if Is_Incomplete_Or_Private_Type (Comp_Typ) 3786 and then Present (Full_View (Comp_Typ)) 3787 then 3788 T := Full_View (Comp_Typ); 3789 else 3790 T := Comp_Typ; 3791 end if; 3792 3793 -- Verify a component of a null-excluding access type 3794 3795 if Is_Access_Type (T) 3796 and then Can_Never_Be_Null (T) 3797 then 3798 if Comp_Decl = Obj_Decl then 3799 Null_Exclusion_Static_Checks 3800 (N => Obj_Decl, 3801 Comp => Empty, 3802 Array_Comp => Array_Comp); 3803 3804 else 3805 Null_Exclusion_Static_Checks 3806 (N => Obj_Decl, 3807 Comp => Comp_Decl, 3808 Array_Comp => Array_Comp); 3809 end if; 3810 3811 -- Check array components 3812 3813 elsif Is_Array_Type (T) then 3814 3815 -- There is no suitable component when the object is of an 3816 -- array type. However, a namable component may appear at some 3817 -- point during the recursive inspection, but not at the top 3818 -- level. At the top level just indicate array component case. 3819 3820 if Comp_Decl = Obj_Decl then 3821 Check_Component (Component_Type (T), Array_Comp => True); 3822 else 3823 Check_Component (Component_Type (T), Comp_Decl); 3824 end if; 3825 3826 -- Verify all components of type T 3827 3828 -- Note: No checks are performed on types with discriminants due 3829 -- to complexities involving variants. ??? 3830 3831 elsif (Is_Concurrent_Type (T) 3832 or else Is_Incomplete_Or_Private_Type (T) 3833 or else Is_Record_Type (T)) 3834 and then not Has_Discriminants (T) 3835 then 3836 Comp := First_Component (T); 3837 while Present (Comp) loop 3838 Check_Component (Etype (Comp), Parent (Comp)); 3839 3840 Next_Component (Comp); 3841 end loop; 3842 end if; 3843 end Check_Component; 3844 3845 -- Start processing for Check_For_Null_Excluding_Components 3846 3847 begin 3848 Check_Component (Obj_Typ, Obj_Decl); 3849 end Check_For_Null_Excluding_Components; 3850 3851 ----------------- 3852 -- Count_Tasks -- 3853 ----------------- 3854 3855 function Count_Tasks (T : Entity_Id) return Uint is 3856 C : Entity_Id; 3857 X : Node_Id; 3858 V : Uint; 3859 3860 begin 3861 if Is_Task_Type (T) then 3862 return Uint_1; 3863 3864 elsif Is_Record_Type (T) then 3865 if Has_Discriminants (T) then 3866 Check_Restriction (Max_Tasks, N); 3867 return Uint_0; 3868 3869 else 3870 V := Uint_0; 3871 C := First_Component (T); 3872 while Present (C) loop 3873 V := V + Count_Tasks (Etype (C)); 3874 Next_Component (C); 3875 end loop; 3876 3877 return V; 3878 end if; 3879 3880 elsif Is_Array_Type (T) then 3881 X := First_Index (T); 3882 V := Count_Tasks (Component_Type (T)); 3883 while Present (X) loop 3884 C := Etype (X); 3885 3886 if not Is_OK_Static_Subtype (C) then 3887 Check_Restriction (Max_Tasks, N); 3888 return Uint_0; 3889 else 3890 V := V * (UI_Max (Uint_0, 3891 Expr_Value (Type_High_Bound (C)) - 3892 Expr_Value (Type_Low_Bound (C)) + Uint_1)); 3893 end if; 3894 3895 Next_Index (X); 3896 end loop; 3897 3898 return V; 3899 3900 else 3901 return Uint_0; 3902 end if; 3903 end Count_Tasks; 3904 3905 ---------------------------- 3906 -- Delayed_Aspect_Present -- 3907 ---------------------------- 3908 3909 function Delayed_Aspect_Present return Boolean is 3910 A : Node_Id; 3911 A_Id : Aspect_Id; 3912 3913 begin 3914 if Present (Aspect_Specifications (N)) then 3915 A := First (Aspect_Specifications (N)); 3916 3917 while Present (A) loop 3918 A_Id := Get_Aspect_Id (Chars (Identifier (A))); 3919 3920 if A_Id = Aspect_Address then 3921 3922 -- Set flag on object entity, for later processing at 3923 -- the freeze point. 3924 3925 Set_Has_Delayed_Aspects (Id); 3926 return True; 3927 end if; 3928 3929 Next (A); 3930 end loop; 3931 end if; 3932 3933 return False; 3934 end Delayed_Aspect_Present; 3935 3936 -- Local variables 3937 3938 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 3939 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 3940 -- Save the Ghost-related attributes to restore on exit 3941 3942 Prev_Entity : Entity_Id := Empty; 3943 Related_Id : Entity_Id; 3944 Full_View_Present : Boolean := False; 3945 3946 -- Start of processing for Analyze_Object_Declaration 3947 3948 begin 3949 -- There are three kinds of implicit types generated by an 3950 -- object declaration: 3951 3952 -- 1. Those generated by the original Object Definition 3953 3954 -- 2. Those generated by the Expression 3955 3956 -- 3. Those used to constrain the Object Definition with the 3957 -- expression constraints when the definition is unconstrained. 3958 3959 -- They must be generated in this order to avoid order of elaboration 3960 -- issues. Thus the first step (after entering the name) is to analyze 3961 -- the object definition. 3962 3963 if Constant_Present (N) then 3964 Prev_Entity := Current_Entity_In_Scope (Id); 3965 3966 if Present (Prev_Entity) 3967 and then 3968 -- If the homograph is an implicit subprogram, it is overridden 3969 -- by the current declaration. 3970 3971 ((Is_Overloadable (Prev_Entity) 3972 and then Is_Inherited_Operation (Prev_Entity)) 3973 3974 -- The current object is a discriminal generated for an entry 3975 -- family index. Even though the index is a constant, in this 3976 -- particular context there is no true constant redeclaration. 3977 -- Enter_Name will handle the visibility. 3978 3979 or else 3980 (Is_Discriminal (Id) 3981 and then Ekind (Discriminal_Link (Id)) = 3982 E_Entry_Index_Parameter) 3983 3984 -- The current object is the renaming for a generic declared 3985 -- within the instance. 3986 3987 or else 3988 (Ekind (Prev_Entity) = E_Package 3989 and then Nkind (Parent (Prev_Entity)) = 3990 N_Package_Renaming_Declaration 3991 and then not Comes_From_Source (Prev_Entity) 3992 and then 3993 Is_Generic_Instance (Renamed_Entity (Prev_Entity))) 3994 3995 -- The entity may be a homonym of a private component of the 3996 -- enclosing protected object, for which we create a local 3997 -- renaming declaration. The declaration is legal, even if 3998 -- useless when it just captures that component. 3999 4000 or else 4001 (Ekind (Scope (Current_Scope)) = E_Protected_Type 4002 and then Nkind (Parent (Prev_Entity)) = 4003 N_Object_Renaming_Declaration)) 4004 then 4005 Prev_Entity := Empty; 4006 end if; 4007 end if; 4008 4009 if Present (Prev_Entity) then 4010 4011 -- The object declaration is Ghost when it completes a deferred Ghost 4012 -- constant. 4013 4014 Mark_And_Set_Ghost_Completion (N, Prev_Entity); 4015 4016 Constant_Redeclaration (Id, N, T); 4017 4018 Generate_Reference (Prev_Entity, Id, 'c'); 4019 Set_Completion_Referenced (Id); 4020 4021 if Error_Posted (N) then 4022 4023 -- Type mismatch or illegal redeclaration; do not analyze 4024 -- expression to avoid cascaded errors. 4025 4026 T := Find_Type_Of_Object (Object_Definition (N), N); 4027 Set_Etype (Id, T); 4028 Set_Ekind (Id, E_Variable); 4029 goto Leave; 4030 end if; 4031 4032 -- In the normal case, enter identifier at the start to catch premature 4033 -- usage in the initialization expression. 4034 4035 else 4036 Generate_Definition (Id); 4037 Enter_Name (Id); 4038 4039 Mark_Coextensions (N, Object_Definition (N)); 4040 4041 T := Find_Type_Of_Object (Object_Definition (N), N); 4042 4043 if Nkind (Object_Definition (N)) = N_Access_Definition 4044 and then Present 4045 (Access_To_Subprogram_Definition (Object_Definition (N))) 4046 and then Protected_Present 4047 (Access_To_Subprogram_Definition (Object_Definition (N))) 4048 then 4049 T := Replace_Anonymous_Access_To_Protected_Subprogram (N); 4050 end if; 4051 4052 if Error_Posted (Id) then 4053 Set_Etype (Id, T); 4054 Set_Ekind (Id, E_Variable); 4055 goto Leave; 4056 end if; 4057 end if; 4058 4059 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry 4060 -- out some static checks. 4061 4062 if Ada_Version >= Ada_2005 then 4063 4064 -- In case of aggregates we must also take care of the correct 4065 -- initialization of nested aggregates bug this is done at the 4066 -- point of the analysis of the aggregate (see sem_aggr.adb) ??? 4067 4068 if Can_Never_Be_Null (T) then 4069 if Present (Expression (N)) 4070 and then Nkind (Expression (N)) = N_Aggregate 4071 then 4072 null; 4073 4074 elsif Comes_From_Source (Id) then 4075 declare 4076 Save_Typ : constant Entity_Id := Etype (Id); 4077 begin 4078 Set_Etype (Id, T); -- Temp. decoration for static checks 4079 Null_Exclusion_Static_Checks (N); 4080 Set_Etype (Id, Save_Typ); 4081 end; 4082 end if; 4083 4084 -- We might be dealing with an object of a composite type containing 4085 -- null-excluding components without an aggregate, so we must verify 4086 -- that such components have default initialization. 4087 4088 else 4089 Check_For_Null_Excluding_Components (T, N); 4090 end if; 4091 end if; 4092 4093 -- Object is marked pure if it is in a pure scope 4094 4095 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 4096 4097 -- If deferred constant, make sure context is appropriate. We detect 4098 -- a deferred constant as a constant declaration with no expression. 4099 -- A deferred constant can appear in a package body if its completion 4100 -- is by means of an interface pragma. 4101 4102 if Constant_Present (N) and then No (E) then 4103 4104 -- A deferred constant may appear in the declarative part of the 4105 -- following constructs: 4106 4107 -- blocks 4108 -- entry bodies 4109 -- extended return statements 4110 -- package specs 4111 -- package bodies 4112 -- subprogram bodies 4113 -- task bodies 4114 4115 -- When declared inside a package spec, a deferred constant must be 4116 -- completed by a full constant declaration or pragma Import. In all 4117 -- other cases, the only proper completion is pragma Import. Extended 4118 -- return statements are flagged as invalid contexts because they do 4119 -- not have a declarative part and so cannot accommodate the pragma. 4120 4121 if Ekind (Current_Scope) = E_Return_Statement then 4122 Error_Msg_N 4123 ("invalid context for deferred constant declaration (RM 7.4)", 4124 N); 4125 Error_Msg_N 4126 ("\declaration requires an initialization expression", 4127 N); 4128 Set_Constant_Present (N, False); 4129 4130 -- In Ada 83, deferred constant must be of private type 4131 4132 elsif not Is_Private_Type (T) then 4133 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 4134 Error_Msg_N 4135 ("(Ada 83) deferred constant must be private type", N); 4136 end if; 4137 end if; 4138 4139 -- If not a deferred constant, then the object declaration freezes 4140 -- its type, unless the object is of an anonymous type and has delayed 4141 -- aspects. In that case the type is frozen when the object itself is. 4142 4143 else 4144 Check_Fully_Declared (T, N); 4145 4146 if Has_Delayed_Aspects (Id) 4147 and then Is_Array_Type (T) 4148 and then Is_Itype (T) 4149 then 4150 Set_Has_Delayed_Freeze (T); 4151 else 4152 Freeze_Before (N, T); 4153 end if; 4154 end if; 4155 4156 -- If the object was created by a constrained array definition, then 4157 -- set the link in both the anonymous base type and anonymous subtype 4158 -- that are built to represent the array type to point to the object. 4159 4160 if Nkind (Object_Definition (Declaration_Node (Id))) = 4161 N_Constrained_Array_Definition 4162 then 4163 Set_Related_Array_Object (T, Id); 4164 Set_Related_Array_Object (Base_Type (T), Id); 4165 end if; 4166 4167 -- Special checks for protected objects not at library level 4168 4169 if Has_Protected (T) and then not Is_Library_Level_Entity (Id) then 4170 Check_Restriction (No_Local_Protected_Objects, Id); 4171 4172 -- Protected objects with interrupt handlers must be at library level 4173 4174 -- Ada 2005: This test is not needed (and the corresponding clause 4175 -- in the RM is removed) because accessibility checks are sufficient 4176 -- to make handlers not at the library level illegal. 4177 4178 -- AI05-0303: The AI is in fact a binding interpretation, and thus 4179 -- applies to the '95 version of the language as well. 4180 4181 if Is_Protected_Type (T) 4182 and then Has_Interrupt_Handler (T) 4183 and then Ada_Version < Ada_95 4184 then 4185 Error_Msg_N 4186 ("interrupt object can only be declared at library level", Id); 4187 end if; 4188 end if; 4189 4190 -- Check for violation of No_Local_Timing_Events 4191 4192 if Has_Timing_Event (T) and then not Is_Library_Level_Entity (Id) then 4193 Check_Restriction (No_Local_Timing_Events, Id); 4194 end if; 4195 4196 -- The actual subtype of the object is the nominal subtype, unless 4197 -- the nominal one is unconstrained and obtained from the expression. 4198 4199 Act_T := T; 4200 4201 if Is_Library_Level_Entity (Id) then 4202 Check_Dynamic_Object (T); 4203 end if; 4204 4205 -- Process initialization expression if present and not in error 4206 4207 if Present (E) and then E /= Error then 4208 4209 -- Generate an error in case of CPP class-wide object initialization. 4210 -- Required because otherwise the expansion of the class-wide 4211 -- assignment would try to use 'size to initialize the object 4212 -- (primitive that is not available in CPP tagged types). 4213 4214 if Is_Class_Wide_Type (Act_T) 4215 and then 4216 (Is_CPP_Class (Root_Type (Etype (Act_T))) 4217 or else 4218 (Present (Full_View (Root_Type (Etype (Act_T)))) 4219 and then 4220 Is_CPP_Class (Full_View (Root_Type (Etype (Act_T)))))) 4221 then 4222 Error_Msg_N 4223 ("predefined assignment not available for 'C'P'P tagged types", 4224 E); 4225 end if; 4226 4227 Mark_Coextensions (N, E); 4228 Analyze (E); 4229 4230 -- In case of errors detected in the analysis of the expression, 4231 -- decorate it with the expected type to avoid cascaded errors. 4232 4233 if No (Etype (E)) then 4234 Set_Etype (E, T); 4235 end if; 4236 4237 -- If an initialization expression is present, then we set the 4238 -- Is_True_Constant flag. It will be reset if this is a variable 4239 -- and it is indeed modified. 4240 4241 Set_Is_True_Constant (Id, True); 4242 4243 -- If we are analyzing a constant declaration, set its completion 4244 -- flag after analyzing and resolving the expression. 4245 4246 if Constant_Present (N) then 4247 Set_Has_Completion (Id); 4248 end if; 4249 4250 -- Set type and resolve (type may be overridden later on). Note: 4251 -- Ekind (Id) must still be E_Void at this point so that incorrect 4252 -- early usage within E is properly diagnosed. 4253 4254 Set_Etype (Id, T); 4255 4256 -- If the expression is an aggregate we must look ahead to detect 4257 -- the possible presence of an address clause, and defer resolution 4258 -- and expansion of the aggregate to the freeze point of the entity. 4259 4260 -- This is not always legal because the aggregate may contain other 4261 -- references that need freezing, e.g. references to other entities 4262 -- with address clauses. In any case, when compiling with -gnatI the 4263 -- presence of the address clause must be ignored. 4264 4265 if Comes_From_Source (N) 4266 and then Expander_Active 4267 and then Nkind (E) = N_Aggregate 4268 and then 4269 ((Present (Following_Address_Clause (N)) 4270 and then not Ignore_Rep_Clauses) 4271 or else Delayed_Aspect_Present) 4272 then 4273 Set_Etype (E, T); 4274 4275 -- If the aggregate is limited it will be built in place, and its 4276 -- expansion is deferred until the object declaration is expanded. 4277 4278 -- This is also required when generating C code to ensure that an 4279 -- object with an alignment or address clause can be initialized 4280 -- by means of component by component assignments. 4281 4282 if Is_Limited_Type (T) or else Modify_Tree_For_C then 4283 Set_Expansion_Delayed (E); 4284 end if; 4285 4286 else 4287 -- If the expression is a formal that is a "subprogram pointer" 4288 -- this is illegal in accessibility terms (see RM 3.10.2 (13.1/2) 4289 -- and AARM 3.10.2 (13.b/2)). Add an explicit conversion to force 4290 -- the corresponding check, as is done for assignments. 4291 4292 if Is_Entity_Name (E) 4293 and then Present (Entity (E)) 4294 and then Is_Formal (Entity (E)) 4295 and then 4296 Ekind (Etype (Entity (E))) = E_Anonymous_Access_Subprogram_Type 4297 and then Ekind (T) /= E_Anonymous_Access_Subprogram_Type 4298 then 4299 Rewrite (E, Convert_To (T, Relocate_Node (E))); 4300 end if; 4301 4302 Resolve (E, T); 4303 end if; 4304 4305 -- No further action needed if E is a call to an inlined function 4306 -- which returns an unconstrained type and it has been expanded into 4307 -- a procedure call. In that case N has been replaced by an object 4308 -- declaration without initializing expression and it has been 4309 -- analyzed (see Expand_Inlined_Call). 4310 4311 if Back_End_Inlining 4312 and then Expander_Active 4313 and then Nkind (E) = N_Function_Call 4314 and then Nkind (Name (E)) in N_Has_Entity 4315 and then Is_Inlined (Entity (Name (E))) 4316 and then not Is_Constrained (Etype (E)) 4317 and then Analyzed (N) 4318 and then No (Expression (N)) 4319 then 4320 goto Leave; 4321 end if; 4322 4323 -- If E is null and has been replaced by an N_Raise_Constraint_Error 4324 -- node (which was marked already-analyzed), we need to set the type 4325 -- to something other than Any_Access in order to keep gigi happy. 4326 4327 if Etype (E) = Any_Access then 4328 Set_Etype (E, T); 4329 end if; 4330 4331 -- If the object is an access to variable, the initialization 4332 -- expression cannot be an access to constant. 4333 4334 if Is_Access_Type (T) 4335 and then not Is_Access_Constant (T) 4336 and then Is_Access_Type (Etype (E)) 4337 and then Is_Access_Constant (Etype (E)) 4338 then 4339 Error_Msg_N 4340 ("access to variable cannot be initialized with an " 4341 & "access-to-constant expression", E); 4342 end if; 4343 4344 if not Assignment_OK (N) then 4345 Check_Initialization (T, E); 4346 end if; 4347 4348 Check_Unset_Reference (E); 4349 4350 -- If this is a variable, then set current value. If this is a 4351 -- declared constant of a scalar type with a static expression, 4352 -- indicate that it is always valid. 4353 4354 if not Constant_Present (N) then 4355 if Compile_Time_Known_Value (E) then 4356 Set_Current_Value (Id, E); 4357 end if; 4358 4359 elsif Is_Scalar_Type (T) and then Is_OK_Static_Expression (E) then 4360 Set_Is_Known_Valid (Id); 4361 4362 -- If it is a constant initialized with a valid nonstatic entity, 4363 -- the constant is known valid as well, and can inherit the subtype 4364 -- of the entity if it is a subtype of the given type. This info 4365 -- is preserved on the actual subtype of the constant. 4366 4367 elsif Is_Scalar_Type (T) 4368 and then Is_Entity_Name (E) 4369 and then Is_Known_Valid (Entity (E)) 4370 and then In_Subrange_Of (Etype (Entity (E)), T) 4371 then 4372 Set_Is_Known_Valid (Id); 4373 Set_Ekind (Id, E_Constant); 4374 Set_Actual_Subtype (Id, Etype (Entity (E))); 4375 end if; 4376 4377 -- Deal with setting of null flags 4378 4379 if Is_Access_Type (T) then 4380 if Known_Non_Null (E) then 4381 Set_Is_Known_Non_Null (Id, True); 4382 elsif Known_Null (E) and then not Can_Never_Be_Null (Id) then 4383 Set_Is_Known_Null (Id, True); 4384 end if; 4385 end if; 4386 4387 -- Check incorrect use of dynamically tagged expressions 4388 4389 if Is_Tagged_Type (T) then 4390 Check_Dynamically_Tagged_Expression 4391 (Expr => E, 4392 Typ => T, 4393 Related_Nod => N); 4394 end if; 4395 4396 Apply_Scalar_Range_Check (E, T); 4397 Apply_Static_Length_Check (E, T); 4398 4399 -- A formal parameter of a specific tagged type whose related 4400 -- subprogram is subject to pragma Extensions_Visible with value 4401 -- "False" cannot be implicitly converted to a class-wide type by 4402 -- means of an initialization expression (SPARK RM 6.1.7(3)). Do 4403 -- not consider internally generated expressions. 4404 4405 if Is_Class_Wide_Type (T) 4406 and then Comes_From_Source (E) 4407 and then Is_EVF_Expression (E) 4408 then 4409 Error_Msg_N 4410 ("formal parameter cannot be implicitly converted to " 4411 & "class-wide type when Extensions_Visible is False", E); 4412 end if; 4413 end if; 4414 4415 -- If the No_Streams restriction is set, check that the type of the 4416 -- object is not, and does not contain, any subtype derived from 4417 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to 4418 -- Has_Stream just for efficiency reasons. There is no point in 4419 -- spending time on a Has_Stream check if the restriction is not set. 4420 4421 if Restriction_Check_Required (No_Streams) then 4422 if Has_Stream (T) then 4423 Check_Restriction (No_Streams, N); 4424 end if; 4425 end if; 4426 4427 -- Deal with predicate check before we start to do major rewriting. It 4428 -- is OK to initialize and then check the initialized value, since the 4429 -- object goes out of scope if we get a predicate failure. Note that we 4430 -- do this in the analyzer and not the expander because the analyzer 4431 -- does some substantial rewriting in some cases. 4432 4433 -- We need a predicate check if the type has predicates that are not 4434 -- ignored, and if either there is an initializing expression, or for 4435 -- default initialization when we have at least one case of an explicit 4436 -- default initial value (including via a Default_Value or 4437 -- Default_Component_Value aspect, see AI12-0301) and then this is not 4438 -- an internal declaration whose initialization comes later (as for an 4439 -- aggregate expansion). 4440 -- If expression is an aggregate it may be expanded into assignments 4441 -- and the declaration itself is marked with No_Initialization, but 4442 -- the predicate still applies. 4443 4444 if not Suppress_Assignment_Checks (N) 4445 and then (Predicate_Enabled (T) or else Has_Static_Predicate (T)) 4446 and then 4447 (not No_Initialization (N) 4448 or else (Present (E) and then Nkind (E) = N_Aggregate)) 4449 and then 4450 (Present (E) 4451 or else 4452 Is_Partially_Initialized_Type (T, Include_Implicit => False)) 4453 then 4454 -- If the type has a static predicate and the expression is known at 4455 -- compile time, see if the expression satisfies the predicate. 4456 -- In the case of a static expression, this must be done even if 4457 -- the predicate is not enabled (as per static expression rules). 4458 4459 if Present (E) then 4460 Check_Expression_Against_Static_Predicate (E, T); 4461 end if; 4462 4463 -- Do not perform further predicate-related checks unless 4464 -- predicates are enabled for the subtype. 4465 4466 if not Predicate_Enabled (T) then 4467 null; 4468 4469 -- If the type is a null record and there is no explicit initial 4470 -- expression, no predicate check applies. 4471 4472 elsif No (E) and then Is_Null_Record_Type (T) then 4473 null; 4474 4475 -- Do not generate a predicate check if the initialization expression 4476 -- is a type conversion because the conversion has been subjected to 4477 -- the same check. This is a small optimization which avoid redundant 4478 -- checks. 4479 4480 elsif Present (E) and then Nkind (E) = N_Type_Conversion then 4481 null; 4482 4483 else 4484 -- The check must be inserted after the expanded aggregate 4485 -- expansion code, if any. 4486 4487 declare 4488 Check : constant Node_Id := 4489 Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)); 4490 4491 begin 4492 if No (Next_Decl) then 4493 Append_To (List_Containing (N), Check); 4494 else 4495 Insert_Before (Next_Decl, Check); 4496 end if; 4497 end; 4498 end if; 4499 end if; 4500 4501 -- Case of unconstrained type 4502 4503 if not Is_Definite_Subtype (T) then 4504 4505 -- Nothing to do in deferred constant case 4506 4507 if Constant_Present (N) and then No (E) then 4508 null; 4509 4510 -- Case of no initialization present 4511 4512 elsif No (E) then 4513 if No_Initialization (N) then 4514 null; 4515 4516 elsif Is_Class_Wide_Type (T) then 4517 Error_Msg_N 4518 ("initialization required in class-wide declaration ", N); 4519 4520 else 4521 Error_Msg_N 4522 ("unconstrained subtype not allowed (need initialization)", 4523 Object_Definition (N)); 4524 4525 if Is_Record_Type (T) and then Has_Discriminants (T) then 4526 Error_Msg_N 4527 ("\provide initial value or explicit discriminant values", 4528 Object_Definition (N)); 4529 4530 Error_Msg_NE 4531 ("\or give default discriminant values for type&", 4532 Object_Definition (N), T); 4533 4534 elsif Is_Array_Type (T) then 4535 Error_Msg_N 4536 ("\provide initial value or explicit array bounds", 4537 Object_Definition (N)); 4538 end if; 4539 end if; 4540 4541 -- Case of initialization present but in error. Set initial 4542 -- expression as absent (but do not make above complaints). 4543 4544 elsif E = Error then 4545 Set_Expression (N, Empty); 4546 E := Empty; 4547 4548 -- Case of initialization present 4549 4550 else 4551 -- Unconstrained variables not allowed in Ada 83 4552 4553 if Ada_Version = Ada_83 4554 and then not Constant_Present (N) 4555 and then Comes_From_Source (Object_Definition (N)) 4556 then 4557 Error_Msg_N 4558 ("(Ada 83) unconstrained variable not allowed", 4559 Object_Definition (N)); 4560 end if; 4561 4562 -- Now we constrain the variable from the initializing expression 4563 4564 -- If the expression is an aggregate, it has been expanded into 4565 -- individual assignments. Retrieve the actual type from the 4566 -- expanded construct. 4567 4568 if Is_Array_Type (T) 4569 and then No_Initialization (N) 4570 and then Nkind (Original_Node (E)) = N_Aggregate 4571 then 4572 Act_T := Etype (E); 4573 4574 -- In case of class-wide interface object declarations we delay 4575 -- the generation of the equivalent record type declarations until 4576 -- its expansion because there are cases in they are not required. 4577 4578 elsif Is_Interface (T) then 4579 null; 4580 4581 -- If the type is an unchecked union, no subtype can be built from 4582 -- the expression. Rewrite declaration as a renaming, which the 4583 -- back-end can handle properly. This is a rather unusual case, 4584 -- because most unchecked_union declarations have default values 4585 -- for discriminants and are thus not indefinite. 4586 4587 elsif Is_Unchecked_Union (T) then 4588 if Constant_Present (N) or else Nkind (E) = N_Function_Call then 4589 Set_Ekind (Id, E_Constant); 4590 else 4591 Set_Ekind (Id, E_Variable); 4592 end if; 4593 4594 -- If the expression is an aggregate it contains the required 4595 -- discriminant values but it has not been resolved yet, so do 4596 -- it now, and treat it as the initial expression of an object 4597 -- declaration, rather than a renaming. 4598 4599 if Nkind (E) = N_Aggregate then 4600 Analyze_And_Resolve (E, T); 4601 4602 else 4603 Rewrite (N, 4604 Make_Object_Renaming_Declaration (Loc, 4605 Defining_Identifier => Id, 4606 Subtype_Mark => New_Occurrence_Of (T, Loc), 4607 Name => E)); 4608 4609 Set_Renamed_Object (Id, E); 4610 Freeze_Before (N, T); 4611 Set_Is_Frozen (Id); 4612 goto Leave; 4613 end if; 4614 4615 else 4616 -- Ensure that the generated subtype has a unique external name 4617 -- when the related object is public. This guarantees that the 4618 -- subtype and its bounds will not be affected by switches or 4619 -- pragmas that may offset the internal counter due to extra 4620 -- generated code. 4621 4622 if Is_Public (Id) then 4623 Related_Id := Id; 4624 else 4625 Related_Id := Empty; 4626 end if; 4627 4628 Expand_Subtype_From_Expr 4629 (N => N, 4630 Unc_Type => T, 4631 Subtype_Indic => Object_Definition (N), 4632 Exp => E, 4633 Related_Id => Related_Id); 4634 4635 Act_T := Find_Type_Of_Object (Object_Definition (N), N); 4636 end if; 4637 4638 -- Propagate attributes to full view when needed 4639 4640 Set_Is_Constr_Subt_For_U_Nominal (Act_T); 4641 4642 if Is_Private_Type (Act_T) and then Present (Full_View (Act_T)) 4643 then 4644 Full_View_Present := True; 4645 end if; 4646 4647 if Full_View_Present then 4648 Set_Is_Constr_Subt_For_U_Nominal (Full_View (Act_T)); 4649 end if; 4650 4651 if Aliased_Present (N) then 4652 Set_Is_Constr_Subt_For_UN_Aliased (Act_T); 4653 4654 if Full_View_Present then 4655 Set_Is_Constr_Subt_For_UN_Aliased (Full_View (Act_T)); 4656 end if; 4657 end if; 4658 4659 Freeze_Before (N, Act_T); 4660 Freeze_Before (N, T); 4661 end if; 4662 4663 elsif Is_Array_Type (T) 4664 and then No_Initialization (N) 4665 and then (Nkind (Original_Node (E)) = N_Aggregate 4666 or else (Nkind (Original_Node (E)) = N_Qualified_Expression 4667 and then Nkind (Original_Node (Expression 4668 (Original_Node (E)))) = N_Aggregate)) 4669 then 4670 if not Is_Entity_Name (Object_Definition (N)) then 4671 Act_T := Etype (E); 4672 Check_Compile_Time_Size (Act_T); 4673 4674 if Aliased_Present (N) then 4675 Set_Is_Constr_Subt_For_UN_Aliased (Act_T); 4676 end if; 4677 end if; 4678 4679 -- When the given object definition and the aggregate are specified 4680 -- independently, and their lengths might differ do a length check. 4681 -- This cannot happen if the aggregate is of the form (others =>...) 4682 4683 if not Is_Constrained (T) then 4684 null; 4685 4686 elsif Nkind (E) = N_Raise_Constraint_Error then 4687 4688 -- Aggregate is statically illegal. Place back in declaration 4689 4690 Set_Expression (N, E); 4691 Set_No_Initialization (N, False); 4692 4693 elsif T = Etype (E) then 4694 null; 4695 4696 elsif Nkind (E) = N_Aggregate 4697 and then Present (Component_Associations (E)) 4698 and then Present (Choice_List (First (Component_Associations (E)))) 4699 and then 4700 Nkind (First (Choice_List (First (Component_Associations (E))))) = 4701 N_Others_Choice 4702 then 4703 null; 4704 4705 else 4706 Apply_Length_Check (E, T); 4707 end if; 4708 4709 -- If the type is limited unconstrained with defaulted discriminants and 4710 -- there is no expression, then the object is constrained by the 4711 -- defaults, so it is worthwhile building the corresponding subtype. 4712 4713 elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T)) 4714 and then not Is_Constrained (T) 4715 and then Has_Discriminants (T) 4716 then 4717 if No (E) then 4718 Act_T := Build_Default_Subtype (T, N); 4719 else 4720 -- Ada 2005: A limited object may be initialized by means of an 4721 -- aggregate. If the type has default discriminants it has an 4722 -- unconstrained nominal type, Its actual subtype will be obtained 4723 -- from the aggregate, and not from the default discriminants. 4724 4725 Act_T := Etype (E); 4726 end if; 4727 4728 Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc)); 4729 4730 elsif Nkind (E) = N_Function_Call 4731 and then Constant_Present (N) 4732 and then Has_Unconstrained_Elements (Etype (E)) 4733 then 4734 -- The back-end has problems with constants of a discriminated type 4735 -- with defaults, if the initial value is a function call. We 4736 -- generate an intermediate temporary that will receive a reference 4737 -- to the result of the call. The initialization expression then 4738 -- becomes a dereference of that temporary. 4739 4740 Remove_Side_Effects (E); 4741 4742 -- If this is a constant declaration of an unconstrained type and 4743 -- the initialization is an aggregate, we can use the subtype of the 4744 -- aggregate for the declared entity because it is immutable. 4745 4746 elsif not Is_Constrained (T) 4747 and then Has_Discriminants (T) 4748 and then Constant_Present (N) 4749 and then not Has_Unchecked_Union (T) 4750 and then Nkind (E) = N_Aggregate 4751 then 4752 Act_T := Etype (E); 4753 end if; 4754 4755 -- Check No_Wide_Characters restriction 4756 4757 Check_Wide_Character_Restriction (T, Object_Definition (N)); 4758 4759 -- Indicate this is not set in source. Certainly true for constants, and 4760 -- true for variables so far (will be reset for a variable if and when 4761 -- we encounter a modification in the source). 4762 4763 Set_Never_Set_In_Source (Id); 4764 4765 -- Now establish the proper kind and type of the object 4766 4767 if Constant_Present (N) then 4768 Set_Ekind (Id, E_Constant); 4769 Set_Is_True_Constant (Id); 4770 4771 else 4772 Set_Ekind (Id, E_Variable); 4773 4774 -- A variable is set as shared passive if it appears in a shared 4775 -- passive package, and is at the outer level. This is not done for 4776 -- entities generated during expansion, because those are always 4777 -- manipulated locally. 4778 4779 if Is_Shared_Passive (Current_Scope) 4780 and then Is_Library_Level_Entity (Id) 4781 and then Comes_From_Source (Id) 4782 then 4783 Set_Is_Shared_Passive (Id); 4784 Check_Shared_Var (Id, T, N); 4785 end if; 4786 4787 -- Set Has_Initial_Value if initializing expression present. Note 4788 -- that if there is no initializing expression, we leave the state 4789 -- of this flag unchanged (usually it will be False, but notably in 4790 -- the case of exception choice variables, it will already be true). 4791 4792 if Present (E) then 4793 Set_Has_Initial_Value (Id); 4794 end if; 4795 end if; 4796 4797 -- Set the SPARK mode from the current context (may be overwritten later 4798 -- with explicit pragma). 4799 4800 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); 4801 Set_SPARK_Pragma_Inherited (Id); 4802 4803 -- Preserve relevant elaboration-related attributes of the context which 4804 -- are no longer available or very expensive to recompute once analysis, 4805 -- resolution, and expansion are over. 4806 4807 Mark_Elaboration_Attributes 4808 (N_Id => Id, 4809 Checks => True, 4810 Warnings => True); 4811 4812 -- Initialize alignment and size and capture alignment setting 4813 4814 Init_Alignment (Id); 4815 Init_Esize (Id); 4816 Set_Optimize_Alignment_Flags (Id); 4817 4818 -- Deal with aliased case 4819 4820 if Aliased_Present (N) then 4821 Set_Is_Aliased (Id); 4822 4823 -- AI12-001: All aliased objects are considered to be specified as 4824 -- independently addressable (RM C.6(8.1/4)). 4825 4826 Set_Is_Independent (Id); 4827 4828 -- If the object is aliased and the type is unconstrained with 4829 -- defaulted discriminants and there is no expression, then the 4830 -- object is constrained by the defaults, so it is worthwhile 4831 -- building the corresponding subtype. 4832 4833 -- Ada 2005 (AI-363): If the aliased object is discriminated and 4834 -- unconstrained, then only establish an actual subtype if the 4835 -- nominal subtype is indefinite. In definite cases the object is 4836 -- unconstrained in Ada 2005. 4837 4838 if No (E) 4839 and then Is_Record_Type (T) 4840 and then not Is_Constrained (T) 4841 and then Has_Discriminants (T) 4842 and then (Ada_Version < Ada_2005 4843 or else not Is_Definite_Subtype (T)) 4844 then 4845 Set_Actual_Subtype (Id, Build_Default_Subtype (T, N)); 4846 end if; 4847 end if; 4848 4849 -- Now we can set the type of the object 4850 4851 Set_Etype (Id, Act_T); 4852 4853 -- Non-constant object is marked to be treated as volatile if type is 4854 -- volatile and we clear the Current_Value setting that may have been 4855 -- set above. Doing so for constants isn't required and might interfere 4856 -- with possible uses of the object as a static expression in contexts 4857 -- incompatible with volatility (e.g. as a case-statement alternative). 4858 4859 if Ekind (Id) /= E_Constant and then Treat_As_Volatile (Etype (Id)) then 4860 Set_Treat_As_Volatile (Id); 4861 Set_Current_Value (Id, Empty); 4862 end if; 4863 4864 -- Deal with controlled types 4865 4866 if Has_Controlled_Component (Etype (Id)) 4867 or else Is_Controlled (Etype (Id)) 4868 then 4869 if not Is_Library_Level_Entity (Id) then 4870 Check_Restriction (No_Nested_Finalization, N); 4871 else 4872 Validate_Controlled_Object (Id); 4873 end if; 4874 end if; 4875 4876 if Has_Task (Etype (Id)) then 4877 Check_Restriction (No_Tasking, N); 4878 4879 -- Deal with counting max tasks 4880 4881 -- Nothing to do if inside a generic 4882 4883 if Inside_A_Generic then 4884 null; 4885 4886 -- If library level entity, then count tasks 4887 4888 elsif Is_Library_Level_Entity (Id) then 4889 Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id))); 4890 4891 -- If not library level entity, then indicate we don't know max 4892 -- tasks and also check task hierarchy restriction and blocking 4893 -- operation (since starting a task is definitely blocking). 4894 4895 else 4896 Check_Restriction (Max_Tasks, N); 4897 Check_Restriction (No_Task_Hierarchy, N); 4898 Check_Potentially_Blocking_Operation (N); 4899 end if; 4900 4901 -- A rather specialized test. If we see two tasks being declared 4902 -- of the same type in the same object declaration, and the task 4903 -- has an entry with an address clause, we know that program error 4904 -- will be raised at run time since we can't have two tasks with 4905 -- entries at the same address. 4906 4907 if Is_Task_Type (Etype (Id)) and then More_Ids (N) then 4908 declare 4909 E : Entity_Id; 4910 4911 begin 4912 E := First_Entity (Etype (Id)); 4913 while Present (E) loop 4914 if Ekind (E) = E_Entry 4915 and then Present (Get_Attribute_Definition_Clause 4916 (E, Attribute_Address)) 4917 then 4918 Error_Msg_Warn := SPARK_Mode /= On; 4919 Error_Msg_N 4920 ("more than one task with same entry address<<", N); 4921 Error_Msg_N ("\Program_Error [<<", N); 4922 Insert_Action (N, 4923 Make_Raise_Program_Error (Loc, 4924 Reason => PE_Duplicated_Entry_Address)); 4925 exit; 4926 end if; 4927 4928 Next_Entity (E); 4929 end loop; 4930 end; 4931 end if; 4932 end if; 4933 4934 -- Some simple constant-propagation: if the expression is a constant 4935 -- string initialized with a literal, share the literal. This avoids 4936 -- a run-time copy. 4937 4938 if Present (E) 4939 and then Is_Entity_Name (E) 4940 and then Ekind (Entity (E)) = E_Constant 4941 and then Base_Type (Etype (E)) = Standard_String 4942 then 4943 declare 4944 Val : constant Node_Id := Constant_Value (Entity (E)); 4945 begin 4946 if Present (Val) and then Nkind (Val) = N_String_Literal then 4947 Rewrite (E, New_Copy (Val)); 4948 end if; 4949 end; 4950 end if; 4951 4952 -- Another optimization: if the nominal subtype is unconstrained and 4953 -- the expression is a function call that returns an unconstrained 4954 -- type, rewrite the declaration as a renaming of the result of the 4955 -- call. The exceptions below are cases where the copy is expected, 4956 -- either by the back end (Aliased case) or by the semantics, as for 4957 -- initializing controlled types or copying tags for class-wide types. 4958 4959 if Present (E) 4960 and then Nkind (E) = N_Explicit_Dereference 4961 and then Nkind (Original_Node (E)) = N_Function_Call 4962 and then not Is_Library_Level_Entity (Id) 4963 and then not Is_Constrained (Underlying_Type (T)) 4964 and then not Is_Aliased (Id) 4965 and then not Is_Class_Wide_Type (T) 4966 and then not Is_Controlled (T) 4967 and then not Has_Controlled_Component (Base_Type (T)) 4968 and then Expander_Active 4969 then 4970 Rewrite (N, 4971 Make_Object_Renaming_Declaration (Loc, 4972 Defining_Identifier => Id, 4973 Access_Definition => Empty, 4974 Subtype_Mark => New_Occurrence_Of 4975 (Base_Type (Etype (Id)), Loc), 4976 Name => E)); 4977 4978 Set_Renamed_Object (Id, E); 4979 4980 -- Force generation of debugging information for the constant and for 4981 -- the renamed function call. 4982 4983 Set_Debug_Info_Needed (Id); 4984 Set_Debug_Info_Needed (Entity (Prefix (E))); 4985 end if; 4986 4987 if Present (Prev_Entity) 4988 and then Is_Frozen (Prev_Entity) 4989 and then not Error_Posted (Id) 4990 then 4991 Error_Msg_N ("full constant declaration appears too late", N); 4992 end if; 4993 4994 Check_Eliminated (Id); 4995 4996 -- Deal with setting In_Private_Part flag if in private part 4997 4998 if Ekind (Scope (Id)) = E_Package 4999 and then In_Private_Part (Scope (Id)) 5000 then 5001 Set_In_Private_Part (Id); 5002 end if; 5003 5004 <<Leave>> 5005 -- Initialize the refined state of a variable here because this is a 5006 -- common destination for legal and illegal object declarations. 5007 5008 if Ekind (Id) = E_Variable then 5009 Set_Encapsulating_State (Id, Empty); 5010 end if; 5011 5012 if Has_Aspects (N) then 5013 Analyze_Aspect_Specifications (N, Id); 5014 end if; 5015 5016 Analyze_Dimension (N); 5017 5018 -- Verify whether the object declaration introduces an illegal hidden 5019 -- state within a package subject to a null abstract state. 5020 5021 if Ekind (Id) = E_Variable then 5022 Check_No_Hidden_State (Id); 5023 end if; 5024 5025 Restore_Ghost_Region (Saved_GM, Saved_IGR); 5026 end Analyze_Object_Declaration; 5027 5028 --------------------------- 5029 -- Analyze_Others_Choice -- 5030 --------------------------- 5031 5032 -- Nothing to do for the others choice node itself, the semantic analysis 5033 -- of the others choice will occur as part of the processing of the parent 5034 5035 procedure Analyze_Others_Choice (N : Node_Id) is 5036 pragma Warnings (Off, N); 5037 begin 5038 null; 5039 end Analyze_Others_Choice; 5040 5041 ------------------------------------------- 5042 -- Analyze_Private_Extension_Declaration -- 5043 ------------------------------------------- 5044 5045 procedure Analyze_Private_Extension_Declaration (N : Node_Id) is 5046 Indic : constant Node_Id := Subtype_Indication (N); 5047 T : constant Entity_Id := Defining_Identifier (N); 5048 Iface : Entity_Id; 5049 Iface_Elmt : Elmt_Id; 5050 Parent_Base : Entity_Id; 5051 Parent_Type : Entity_Id; 5052 5053 begin 5054 -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces 5055 5056 if Is_Non_Empty_List (Interface_List (N)) then 5057 declare 5058 Intf : Node_Id; 5059 T : Entity_Id; 5060 5061 begin 5062 Intf := First (Interface_List (N)); 5063 while Present (Intf) loop 5064 T := Find_Type_Of_Subtype_Indic (Intf); 5065 5066 Diagnose_Interface (Intf, T); 5067 Next (Intf); 5068 end loop; 5069 end; 5070 end if; 5071 5072 Generate_Definition (T); 5073 5074 -- For other than Ada 2012, just enter the name in the current scope 5075 5076 if Ada_Version < Ada_2012 then 5077 Enter_Name (T); 5078 5079 -- Ada 2012 (AI05-0162): Enter the name in the current scope handling 5080 -- case of private type that completes an incomplete type. 5081 5082 else 5083 declare 5084 Prev : Entity_Id; 5085 5086 begin 5087 Prev := Find_Type_Name (N); 5088 5089 pragma Assert (Prev = T 5090 or else (Ekind (Prev) = E_Incomplete_Type 5091 and then Present (Full_View (Prev)) 5092 and then Full_View (Prev) = T)); 5093 end; 5094 end if; 5095 5096 Parent_Type := Find_Type_Of_Subtype_Indic (Indic); 5097 Parent_Base := Base_Type (Parent_Type); 5098 5099 if Parent_Type = Any_Type or else Etype (Parent_Type) = Any_Type then 5100 Set_Ekind (T, Ekind (Parent_Type)); 5101 Set_Etype (T, Any_Type); 5102 goto Leave; 5103 5104 elsif not Is_Tagged_Type (Parent_Type) then 5105 Error_Msg_N 5106 ("parent of type extension must be a tagged type ", Indic); 5107 goto Leave; 5108 5109 elsif Ekind (Parent_Type) in E_Void | E_Incomplete_Type then 5110 Error_Msg_N ("premature derivation of incomplete type", Indic); 5111 goto Leave; 5112 5113 elsif Is_Concurrent_Type (Parent_Type) then 5114 Error_Msg_N 5115 ("parent type of a private extension cannot be a synchronized " 5116 & "tagged type (RM 3.9.1 (3/1))", N); 5117 5118 Set_Etype (T, Any_Type); 5119 Set_Ekind (T, E_Limited_Private_Type); 5120 Set_Private_Dependents (T, New_Elmt_List); 5121 Set_Error_Posted (T); 5122 goto Leave; 5123 end if; 5124 5125 -- Perhaps the parent type should be changed to the class-wide type's 5126 -- specific type in this case to prevent cascading errors ??? 5127 5128 if Is_Class_Wide_Type (Parent_Type) then 5129 Error_Msg_N 5130 ("parent of type extension must not be a class-wide type", Indic); 5131 goto Leave; 5132 end if; 5133 5134 if (not Is_Package_Or_Generic_Package (Current_Scope) 5135 and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration) 5136 or else In_Private_Part (Current_Scope) 5137 then 5138 Error_Msg_N ("invalid context for private extension", N); 5139 end if; 5140 5141 -- Set common attributes 5142 5143 Set_Is_Pure (T, Is_Pure (Current_Scope)); 5144 Set_Scope (T, Current_Scope); 5145 Set_Ekind (T, E_Record_Type_With_Private); 5146 Init_Size_Align (T); 5147 Set_Default_SSO (T); 5148 Set_No_Reordering (T, No_Component_Reordering); 5149 5150 Set_Etype (T, Parent_Base); 5151 Propagate_Concurrent_Flags (T, Parent_Base); 5152 5153 Set_Convention (T, Convention (Parent_Type)); 5154 Set_First_Rep_Item (T, First_Rep_Item (Parent_Type)); 5155 Set_Is_First_Subtype (T); 5156 Make_Class_Wide_Type (T); 5157 5158 -- Set the SPARK mode from the current context 5159 5160 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 5161 Set_SPARK_Pragma_Inherited (T); 5162 5163 if Unknown_Discriminants_Present (N) then 5164 Set_Discriminant_Constraint (T, No_Elist); 5165 end if; 5166 5167 Build_Derived_Record_Type (N, Parent_Type, T); 5168 5169 -- A private extension inherits the Default_Initial_Condition pragma 5170 -- coming from any parent type within the derivation chain. 5171 5172 if Has_DIC (Parent_Type) then 5173 Set_Has_Inherited_DIC (T); 5174 end if; 5175 5176 -- A private extension inherits any class-wide invariants coming from a 5177 -- parent type or an interface. Note that the invariant procedure of the 5178 -- parent type should not be inherited because the private extension may 5179 -- define invariants of its own. 5180 5181 if Has_Inherited_Invariants (Parent_Type) 5182 or else Has_Inheritable_Invariants (Parent_Type) 5183 then 5184 Set_Has_Inherited_Invariants (T); 5185 5186 elsif Present (Interfaces (T)) then 5187 Iface_Elmt := First_Elmt (Interfaces (T)); 5188 while Present (Iface_Elmt) loop 5189 Iface := Node (Iface_Elmt); 5190 5191 if Has_Inheritable_Invariants (Iface) then 5192 Set_Has_Inherited_Invariants (T); 5193 exit; 5194 end if; 5195 5196 Next_Elmt (Iface_Elmt); 5197 end loop; 5198 end if; 5199 5200 -- Ada 2005 (AI-443): Synchronized private extension or a rewritten 5201 -- synchronized formal derived type. 5202 5203 if Ada_Version >= Ada_2005 and then Synchronized_Present (N) then 5204 Set_Is_Limited_Record (T); 5205 5206 -- Formal derived type case 5207 5208 if Is_Generic_Type (T) then 5209 5210 -- The parent must be a tagged limited type or a synchronized 5211 -- interface. 5212 5213 if (not Is_Tagged_Type (Parent_Type) 5214 or else not Is_Limited_Type (Parent_Type)) 5215 and then 5216 (not Is_Interface (Parent_Type) 5217 or else not Is_Synchronized_Interface (Parent_Type)) 5218 then 5219 Error_Msg_NE 5220 ("parent type of & must be tagged limited or synchronized", 5221 N, T); 5222 end if; 5223 5224 -- The progenitors (if any) must be limited or synchronized 5225 -- interfaces. 5226 5227 if Present (Interfaces (T)) then 5228 Iface_Elmt := First_Elmt (Interfaces (T)); 5229 while Present (Iface_Elmt) loop 5230 Iface := Node (Iface_Elmt); 5231 5232 if not Is_Limited_Interface (Iface) 5233 and then not Is_Synchronized_Interface (Iface) 5234 then 5235 Error_Msg_NE 5236 ("progenitor & must be limited or synchronized", 5237 N, Iface); 5238 end if; 5239 5240 Next_Elmt (Iface_Elmt); 5241 end loop; 5242 end if; 5243 5244 -- Regular derived extension, the parent must be a limited or 5245 -- synchronized interface. 5246 5247 else 5248 if not Is_Interface (Parent_Type) 5249 or else (not Is_Limited_Interface (Parent_Type) 5250 and then not Is_Synchronized_Interface (Parent_Type)) 5251 then 5252 Error_Msg_NE 5253 ("parent type of & must be limited interface", N, T); 5254 end if; 5255 end if; 5256 5257 -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private 5258 -- extension with a synchronized parent must be explicitly declared 5259 -- synchronized, because the full view will be a synchronized type. 5260 -- This must be checked before the check for limited types below, 5261 -- to ensure that types declared limited are not allowed to extend 5262 -- synchronized interfaces. 5263 5264 elsif Is_Interface (Parent_Type) 5265 and then Is_Synchronized_Interface (Parent_Type) 5266 and then not Synchronized_Present (N) 5267 then 5268 Error_Msg_NE 5269 ("private extension of& must be explicitly synchronized", 5270 N, Parent_Type); 5271 5272 elsif Limited_Present (N) then 5273 Set_Is_Limited_Record (T); 5274 5275 if not Is_Limited_Type (Parent_Type) 5276 and then 5277 (not Is_Interface (Parent_Type) 5278 or else not Is_Limited_Interface (Parent_Type)) 5279 then 5280 Error_Msg_NE ("parent type& of limited extension must be limited", 5281 N, Parent_Type); 5282 end if; 5283 end if; 5284 5285 -- Remember that its parent type has a private extension. Used to warn 5286 -- on public primitives of the parent type defined after its private 5287 -- extensions (see Check_Dispatching_Operation). 5288 5289 Set_Has_Private_Extension (Parent_Type); 5290 5291 <<Leave>> 5292 if Has_Aspects (N) then 5293 Analyze_Aspect_Specifications (N, T); 5294 end if; 5295 end Analyze_Private_Extension_Declaration; 5296 5297 --------------------------------- 5298 -- Analyze_Subtype_Declaration -- 5299 --------------------------------- 5300 5301 procedure Analyze_Subtype_Declaration 5302 (N : Node_Id; 5303 Skip : Boolean := False) 5304 is 5305 Id : constant Entity_Id := Defining_Identifier (N); 5306 T : Entity_Id; 5307 5308 begin 5309 Generate_Definition (Id); 5310 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 5311 Init_Size_Align (Id); 5312 5313 -- The following guard condition on Enter_Name is to handle cases where 5314 -- the defining identifier has already been entered into the scope but 5315 -- the declaration as a whole needs to be analyzed. 5316 5317 -- This case in particular happens for derived enumeration types. The 5318 -- derived enumeration type is processed as an inserted enumeration type 5319 -- declaration followed by a rewritten subtype declaration. The defining 5320 -- identifier, however, is entered into the name scope very early in the 5321 -- processing of the original type declaration and therefore needs to be 5322 -- avoided here, when the created subtype declaration is analyzed. (See 5323 -- Build_Derived_Types) 5324 5325 -- This also happens when the full view of a private type is derived 5326 -- type with constraints. In this case the entity has been introduced 5327 -- in the private declaration. 5328 5329 -- Finally this happens in some complex cases when validity checks are 5330 -- enabled, where the same subtype declaration may be analyzed twice. 5331 -- This can happen if the subtype is created by the preanalysis of 5332 -- an attribute tht gives the range of a loop statement, and the loop 5333 -- itself appears within an if_statement that will be rewritten during 5334 -- expansion. 5335 5336 if Skip 5337 or else (Present (Etype (Id)) 5338 and then (Is_Private_Type (Etype (Id)) 5339 or else Is_Task_Type (Etype (Id)) 5340 or else Is_Rewrite_Substitution (N))) 5341 then 5342 null; 5343 5344 elsif Current_Entity (Id) = Id then 5345 null; 5346 5347 else 5348 Enter_Name (Id); 5349 end if; 5350 5351 T := Process_Subtype (Subtype_Indication (N), N, Id, 'P'); 5352 5353 -- Class-wide equivalent types of records with unknown discriminants 5354 -- involve the generation of an itype which serves as the private view 5355 -- of a constrained record subtype. In such cases the base type of the 5356 -- current subtype we are processing is the private itype. Use the full 5357 -- of the private itype when decorating various attributes. 5358 5359 if Is_Itype (T) 5360 and then Is_Private_Type (T) 5361 and then Present (Full_View (T)) 5362 then 5363 T := Full_View (T); 5364 end if; 5365 5366 -- Inherit common attributes 5367 5368 Set_Is_Volatile (Id, Is_Volatile (T)); 5369 Set_Treat_As_Volatile (Id, Treat_As_Volatile (T)); 5370 Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T))); 5371 Set_Convention (Id, Convention (T)); 5372 5373 -- If ancestor has predicates then so does the subtype, and in addition 5374 -- we must delay the freeze to properly arrange predicate inheritance. 5375 5376 -- The Ancestor_Type test is really unpleasant, there seem to be cases 5377 -- in which T = ID, so the above tests and assignments do nothing??? 5378 5379 if Has_Predicates (T) 5380 or else (Present (Ancestor_Subtype (T)) 5381 and then Has_Predicates (Ancestor_Subtype (T))) 5382 then 5383 Set_Has_Predicates (Id); 5384 Set_Has_Delayed_Freeze (Id); 5385 5386 -- Generated subtypes inherit the predicate function from the parent 5387 -- (no aspects to examine on the generated declaration). 5388 5389 if not Comes_From_Source (N) then 5390 Set_Ekind (Id, Ekind (T)); 5391 5392 if Present (Predicate_Function (Id)) then 5393 null; 5394 5395 elsif Present (Predicate_Function (T)) then 5396 Set_Predicate_Function (Id, Predicate_Function (T)); 5397 5398 elsif Present (Ancestor_Subtype (T)) 5399 and then Present (Predicate_Function (Ancestor_Subtype (T))) 5400 then 5401 Set_Predicate_Function (Id, 5402 Predicate_Function (Ancestor_Subtype (T))); 5403 end if; 5404 end if; 5405 end if; 5406 5407 -- In the case where there is no constraint given in the subtype 5408 -- indication, Process_Subtype just returns the Subtype_Mark, so its 5409 -- semantic attributes must be established here. 5410 5411 if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then 5412 Set_Etype (Id, Base_Type (T)); 5413 5414 case Ekind (T) is 5415 when Array_Kind => 5416 Set_Ekind (Id, E_Array_Subtype); 5417 Copy_Array_Subtype_Attributes (Id, T); 5418 5419 when Decimal_Fixed_Point_Kind => 5420 Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype); 5421 Set_Digits_Value (Id, Digits_Value (T)); 5422 Set_Delta_Value (Id, Delta_Value (T)); 5423 Set_Scale_Value (Id, Scale_Value (T)); 5424 Set_Small_Value (Id, Small_Value (T)); 5425 Set_Scalar_Range (Id, Scalar_Range (T)); 5426 Set_Machine_Radix_10 (Id, Machine_Radix_10 (T)); 5427 Set_Is_Constrained (Id, Is_Constrained (T)); 5428 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5429 Set_RM_Size (Id, RM_Size (T)); 5430 5431 when Enumeration_Kind => 5432 Set_Ekind (Id, E_Enumeration_Subtype); 5433 Set_First_Literal (Id, First_Literal (Base_Type (T))); 5434 Set_Scalar_Range (Id, Scalar_Range (T)); 5435 Set_Is_Character_Type (Id, Is_Character_Type (T)); 5436 Set_Is_Constrained (Id, Is_Constrained (T)); 5437 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5438 Set_RM_Size (Id, RM_Size (T)); 5439 5440 when Ordinary_Fixed_Point_Kind => 5441 Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype); 5442 Set_Scalar_Range (Id, Scalar_Range (T)); 5443 Set_Small_Value (Id, Small_Value (T)); 5444 Set_Delta_Value (Id, Delta_Value (T)); 5445 Set_Is_Constrained (Id, Is_Constrained (T)); 5446 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5447 Set_RM_Size (Id, RM_Size (T)); 5448 5449 when Float_Kind => 5450 Set_Ekind (Id, E_Floating_Point_Subtype); 5451 Set_Scalar_Range (Id, Scalar_Range (T)); 5452 Set_Digits_Value (Id, Digits_Value (T)); 5453 Set_Is_Constrained (Id, Is_Constrained (T)); 5454 5455 -- If the floating point type has dimensions, these will be 5456 -- inherited subsequently when Analyze_Dimensions is called. 5457 5458 when Signed_Integer_Kind => 5459 Set_Ekind (Id, E_Signed_Integer_Subtype); 5460 Set_Scalar_Range (Id, Scalar_Range (T)); 5461 Set_Is_Constrained (Id, Is_Constrained (T)); 5462 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5463 Set_RM_Size (Id, RM_Size (T)); 5464 5465 when Modular_Integer_Kind => 5466 Set_Ekind (Id, E_Modular_Integer_Subtype); 5467 Set_Scalar_Range (Id, Scalar_Range (T)); 5468 Set_Is_Constrained (Id, Is_Constrained (T)); 5469 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5470 Set_RM_Size (Id, RM_Size (T)); 5471 5472 when Class_Wide_Kind => 5473 Set_Ekind (Id, E_Class_Wide_Subtype); 5474 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 5475 Set_Cloned_Subtype (Id, T); 5476 Set_Is_Tagged_Type (Id, True); 5477 Set_Is_Limited_Record (Id, Is_Limited_Record (T)); 5478 Set_Has_Unknown_Discriminants 5479 (Id, True); 5480 Set_No_Tagged_Streams_Pragma 5481 (Id, No_Tagged_Streams_Pragma (T)); 5482 5483 if Ekind (T) = E_Class_Wide_Subtype then 5484 Set_Equivalent_Type (Id, Equivalent_Type (T)); 5485 end if; 5486 5487 when E_Record_Subtype 5488 | E_Record_Type 5489 => 5490 Set_Ekind (Id, E_Record_Subtype); 5491 5492 -- Subtype declarations introduced for formal type parameters 5493 -- in generic instantiations should inherit the Size value of 5494 -- the type they rename. 5495 5496 if Present (Generic_Parent_Type (N)) then 5497 Set_RM_Size (Id, RM_Size (T)); 5498 end if; 5499 5500 if Ekind (T) = E_Record_Subtype 5501 and then Present (Cloned_Subtype (T)) 5502 then 5503 Set_Cloned_Subtype (Id, Cloned_Subtype (T)); 5504 else 5505 Set_Cloned_Subtype (Id, T); 5506 end if; 5507 5508 Set_First_Entity (Id, First_Entity (T)); 5509 Set_Last_Entity (Id, Last_Entity (T)); 5510 Set_Has_Discriminants (Id, Has_Discriminants (T)); 5511 Set_Is_Constrained (Id, Is_Constrained (T)); 5512 Set_Is_Limited_Record (Id, Is_Limited_Record (T)); 5513 Set_Has_Implicit_Dereference 5514 (Id, Has_Implicit_Dereference (T)); 5515 Set_Has_Unknown_Discriminants 5516 (Id, Has_Unknown_Discriminants (T)); 5517 5518 if Has_Discriminants (T) then 5519 Set_Discriminant_Constraint 5520 (Id, Discriminant_Constraint (T)); 5521 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 5522 5523 elsif Has_Unknown_Discriminants (Id) then 5524 Set_Discriminant_Constraint (Id, No_Elist); 5525 end if; 5526 5527 if Is_Tagged_Type (T) then 5528 Set_Is_Tagged_Type (Id, True); 5529 Set_No_Tagged_Streams_Pragma 5530 (Id, No_Tagged_Streams_Pragma (T)); 5531 Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); 5532 Set_Direct_Primitive_Operations 5533 (Id, Direct_Primitive_Operations (T)); 5534 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 5535 5536 if Is_Interface (T) then 5537 Set_Is_Interface (Id); 5538 Set_Is_Limited_Interface (Id, Is_Limited_Interface (T)); 5539 end if; 5540 end if; 5541 5542 when Private_Kind => 5543 Set_Ekind (Id, Subtype_Kind (Ekind (T))); 5544 Set_Has_Discriminants (Id, Has_Discriminants (T)); 5545 Set_Is_Constrained (Id, Is_Constrained (T)); 5546 Set_First_Entity (Id, First_Entity (T)); 5547 Set_Last_Entity (Id, Last_Entity (T)); 5548 Set_Private_Dependents (Id, New_Elmt_List); 5549 Set_Is_Limited_Record (Id, Is_Limited_Record (T)); 5550 Set_Has_Implicit_Dereference 5551 (Id, Has_Implicit_Dereference (T)); 5552 Set_Has_Unknown_Discriminants 5553 (Id, Has_Unknown_Discriminants (T)); 5554 Set_Known_To_Have_Preelab_Init 5555 (Id, Known_To_Have_Preelab_Init (T)); 5556 5557 if Is_Tagged_Type (T) then 5558 Set_Is_Tagged_Type (Id); 5559 Set_No_Tagged_Streams_Pragma (Id, 5560 No_Tagged_Streams_Pragma (T)); 5561 Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); 5562 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 5563 Set_Direct_Primitive_Operations (Id, 5564 Direct_Primitive_Operations (T)); 5565 end if; 5566 5567 -- In general the attributes of the subtype of a private type 5568 -- are the attributes of the partial view of parent. However, 5569 -- the full view may be a discriminated type, and the subtype 5570 -- must share the discriminant constraint to generate correct 5571 -- calls to initialization procedures. 5572 5573 if Has_Discriminants (T) then 5574 Set_Discriminant_Constraint 5575 (Id, Discriminant_Constraint (T)); 5576 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 5577 5578 elsif Present (Full_View (T)) 5579 and then Has_Discriminants (Full_View (T)) 5580 then 5581 Set_Discriminant_Constraint 5582 (Id, Discriminant_Constraint (Full_View (T))); 5583 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 5584 5585 -- This would seem semantically correct, but apparently 5586 -- generates spurious errors about missing components ??? 5587 5588 -- Set_Has_Discriminants (Id); 5589 end if; 5590 5591 Prepare_Private_Subtype_Completion (Id, N); 5592 5593 -- If this is the subtype of a constrained private type with 5594 -- discriminants that has got a full view and we also have 5595 -- built a completion just above, show that the completion 5596 -- is a clone of the full view to the back-end. 5597 5598 if Has_Discriminants (T) 5599 and then not Has_Unknown_Discriminants (T) 5600 and then not Is_Empty_Elmt_List (Discriminant_Constraint (T)) 5601 and then Present (Full_View (T)) 5602 and then Present (Full_View (Id)) 5603 then 5604 Set_Cloned_Subtype (Full_View (Id), Full_View (T)); 5605 end if; 5606 5607 when Access_Kind => 5608 Set_Ekind (Id, E_Access_Subtype); 5609 Set_Is_Constrained (Id, Is_Constrained (T)); 5610 Set_Is_Access_Constant 5611 (Id, Is_Access_Constant (T)); 5612 Set_Directly_Designated_Type 5613 (Id, Designated_Type (T)); 5614 Set_Can_Never_Be_Null (Id, Can_Never_Be_Null (T)); 5615 5616 -- A Pure library_item must not contain the declaration of a 5617 -- named access type, except within a subprogram, generic 5618 -- subprogram, task unit, or protected unit, or if it has 5619 -- a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)). 5620 5621 if Comes_From_Source (Id) 5622 and then In_Pure_Unit 5623 and then not In_Subprogram_Task_Protected_Unit 5624 and then not No_Pool_Assigned (Id) 5625 then 5626 Error_Msg_N 5627 ("named access types not allowed in pure unit", N); 5628 end if; 5629 5630 when Concurrent_Kind => 5631 Set_Ekind (Id, Subtype_Kind (Ekind (T))); 5632 Set_Corresponding_Record_Type (Id, 5633 Corresponding_Record_Type (T)); 5634 Set_First_Entity (Id, First_Entity (T)); 5635 Set_First_Private_Entity (Id, First_Private_Entity (T)); 5636 Set_Has_Discriminants (Id, Has_Discriminants (T)); 5637 Set_Is_Constrained (Id, Is_Constrained (T)); 5638 Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); 5639 Set_Last_Entity (Id, Last_Entity (T)); 5640 5641 if Is_Tagged_Type (T) then 5642 Set_No_Tagged_Streams_Pragma 5643 (Id, No_Tagged_Streams_Pragma (T)); 5644 end if; 5645 5646 if Has_Discriminants (T) then 5647 Set_Discriminant_Constraint 5648 (Id, Discriminant_Constraint (T)); 5649 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 5650 end if; 5651 5652 when Incomplete_Kind => 5653 if Ada_Version >= Ada_2005 then 5654 5655 -- In Ada 2005 an incomplete type can be explicitly tagged: 5656 -- propagate indication. Note that we also have to include 5657 -- subtypes for Ada 2012 extended use of incomplete types. 5658 5659 Set_Ekind (Id, E_Incomplete_Subtype); 5660 Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); 5661 Set_Private_Dependents (Id, New_Elmt_List); 5662 5663 if Is_Tagged_Type (Id) then 5664 Set_No_Tagged_Streams_Pragma 5665 (Id, No_Tagged_Streams_Pragma (T)); 5666 Set_Direct_Primitive_Operations (Id, New_Elmt_List); 5667 end if; 5668 5669 -- Ada 2005 (AI-412): Decorate an incomplete subtype of an 5670 -- incomplete type visible through a limited with clause. 5671 5672 if From_Limited_With (T) 5673 and then Present (Non_Limited_View (T)) 5674 then 5675 Set_From_Limited_With (Id); 5676 Set_Non_Limited_View (Id, Non_Limited_View (T)); 5677 5678 -- Ada 2005 (AI-412): Add the regular incomplete subtype 5679 -- to the private dependents of the original incomplete 5680 -- type for future transformation. 5681 5682 else 5683 Append_Elmt (Id, Private_Dependents (T)); 5684 end if; 5685 5686 -- If the subtype name denotes an incomplete type an error 5687 -- was already reported by Process_Subtype. 5688 5689 else 5690 Set_Etype (Id, Any_Type); 5691 end if; 5692 5693 when others => 5694 raise Program_Error; 5695 end case; 5696 5697 -- If there is no constraint in the subtype indication, the 5698 -- declared entity inherits predicates from the parent. 5699 5700 Inherit_Predicate_Flags (Id, T); 5701 end if; 5702 5703 if Etype (Id) = Any_Type then 5704 goto Leave; 5705 end if; 5706 5707 -- Some common processing on all types 5708 5709 Set_Size_Info (Id, T); 5710 Set_First_Rep_Item (Id, First_Rep_Item (T)); 5711 5712 -- If the parent type is a generic actual, so is the subtype. This may 5713 -- happen in a nested instance. Why Comes_From_Source test??? 5714 5715 if not Comes_From_Source (N) then 5716 Set_Is_Generic_Actual_Type (Id, Is_Generic_Actual_Type (T)); 5717 end if; 5718 5719 -- If this is a subtype declaration for an actual in an instance, 5720 -- inherit static and dynamic predicates if any. 5721 5722 -- If declaration has no aspect specifications, inherit predicate 5723 -- info as well. Unclear how to handle the case of both specified 5724 -- and inherited predicates ??? Other inherited aspects, such as 5725 -- invariants, should be OK, but the combination with later pragmas 5726 -- may also require special merging. 5727 5728 if Has_Predicates (T) 5729 and then Present (Predicate_Function (T)) 5730 and then 5731 ((In_Instance and then not Comes_From_Source (N)) 5732 or else No (Aspect_Specifications (N))) 5733 then 5734 Set_Subprograms_For_Type (Id, Subprograms_For_Type (T)); 5735 5736 -- If the current declaration created both a private and a full view, 5737 -- then propagate Predicate_Function to the latter as well. 5738 5739 if Present (Full_View (Id)) 5740 and then No (Predicate_Function (Full_View (Id))) 5741 then 5742 Set_Subprograms_For_Type 5743 (Full_View (Id), Subprograms_For_Type (Id)); 5744 end if; 5745 5746 if Has_Static_Predicate (T) then 5747 Set_Has_Static_Predicate (Id); 5748 Set_Static_Discrete_Predicate (Id, Static_Discrete_Predicate (T)); 5749 end if; 5750 end if; 5751 5752 -- If the base type is a scalar type, or else if there is no 5753 -- constraint, the atomic flag is inherited by the subtype. 5754 -- Ditto for the Independent aspect. 5755 5756 if Is_Scalar_Type (Id) 5757 or else Is_Entity_Name (Subtype_Indication (N)) 5758 then 5759 Set_Is_Atomic (Id, Is_Atomic (T)); 5760 Set_Is_Independent (Id, Is_Independent (T)); 5761 end if; 5762 5763 -- Remaining processing depends on characteristics of base type 5764 5765 T := Etype (Id); 5766 5767 Set_Is_Immediately_Visible (Id, True); 5768 Set_Depends_On_Private (Id, Has_Private_Component (T)); 5769 Set_Is_Descendant_Of_Address (Id, Is_Descendant_Of_Address (T)); 5770 5771 if Is_Interface (T) then 5772 Set_Is_Interface (Id); 5773 Set_Is_Limited_Interface (Id, Is_Limited_Interface (T)); 5774 end if; 5775 5776 if Present (Generic_Parent_Type (N)) 5777 and then 5778 (Nkind (Parent (Generic_Parent_Type (N))) /= 5779 N_Formal_Type_Declaration 5780 or else Nkind (Formal_Type_Definition 5781 (Parent (Generic_Parent_Type (N)))) /= 5782 N_Formal_Private_Type_Definition) 5783 then 5784 if Is_Tagged_Type (Id) then 5785 5786 -- If this is a generic actual subtype for a synchronized type, 5787 -- the primitive operations are those of the corresponding record 5788 -- for which there is a separate subtype declaration. 5789 5790 if Is_Concurrent_Type (Id) then 5791 null; 5792 elsif Is_Class_Wide_Type (Id) then 5793 Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T)); 5794 else 5795 Derive_Subprograms (Generic_Parent_Type (N), Id, T); 5796 end if; 5797 5798 elsif Scope (Etype (Id)) /= Standard_Standard then 5799 Derive_Subprograms (Generic_Parent_Type (N), Id); 5800 end if; 5801 end if; 5802 5803 if Is_Private_Type (T) and then Present (Full_View (T)) then 5804 Conditional_Delay (Id, Full_View (T)); 5805 5806 -- The subtypes of components or subcomponents of protected types 5807 -- do not need freeze nodes, which would otherwise appear in the 5808 -- wrong scope (before the freeze node for the protected type). The 5809 -- proper subtypes are those of the subcomponents of the corresponding 5810 -- record. 5811 5812 elsif Ekind (Scope (Id)) /= E_Protected_Type 5813 and then Present (Scope (Scope (Id))) -- error defense 5814 and then Ekind (Scope (Scope (Id))) /= E_Protected_Type 5815 then 5816 Conditional_Delay (Id, T); 5817 end if; 5818 5819 -- If we have a subtype of an incomplete type whose full type is a 5820 -- derived numeric type, we need to have a freeze node for the subtype. 5821 -- Otherwise gigi will complain while computing the (static) bounds of 5822 -- the subtype. 5823 5824 if Is_Itype (T) 5825 and then Is_Elementary_Type (Id) 5826 and then Etype (Id) /= Id 5827 then 5828 declare 5829 Partial : constant Entity_Id := 5830 Incomplete_Or_Partial_View (First_Subtype (Id)); 5831 begin 5832 if Present (Partial) 5833 and then Ekind (Partial) = E_Incomplete_Type 5834 then 5835 Set_Has_Delayed_Freeze (Id); 5836 end if; 5837 end; 5838 end if; 5839 5840 -- Check that Constraint_Error is raised for a scalar subtype indication 5841 -- when the lower or upper bound of a non-null range lies outside the 5842 -- range of the type mark. Likewise for an array subtype, but check the 5843 -- compatibility for each index. 5844 5845 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then 5846 declare 5847 Indic_Typ : constant Entity_Id := 5848 Etype (Subtype_Mark (Subtype_Indication (N))); 5849 Subt_Index : Node_Id; 5850 Target_Index : Node_Id; 5851 5852 begin 5853 if Is_Scalar_Type (Etype (Id)) 5854 and then Scalar_Range (Id) /= Scalar_Range (Indic_Typ) 5855 then 5856 Apply_Range_Check (Scalar_Range (Id), Indic_Typ); 5857 5858 elsif Is_Array_Type (Etype (Id)) 5859 and then Present (First_Index (Id)) 5860 then 5861 Subt_Index := First_Index (Id); 5862 Target_Index := First_Index (Indic_Typ); 5863 5864 while Present (Subt_Index) loop 5865 if ((Nkind (Subt_Index) in N_Expanded_Name | N_Identifier 5866 and then Is_Scalar_Type (Entity (Subt_Index))) 5867 or else Nkind (Subt_Index) = N_Subtype_Indication) 5868 and then 5869 Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range 5870 then 5871 Apply_Range_Check 5872 (Scalar_Range (Etype (Subt_Index)), 5873 Etype (Target_Index), 5874 Insert_Node => N); 5875 end if; 5876 5877 Next_Index (Subt_Index); 5878 Next_Index (Target_Index); 5879 end loop; 5880 end if; 5881 end; 5882 end if; 5883 5884 Set_Optimize_Alignment_Flags (Id); 5885 Check_Eliminated (Id); 5886 5887 <<Leave>> 5888 if Has_Aspects (N) then 5889 Analyze_Aspect_Specifications (N, Id); 5890 end if; 5891 5892 Analyze_Dimension (N); 5893 5894 -- Check No_Dynamic_Sized_Objects restriction, which disallows subtype 5895 -- indications on composite types where the constraints are dynamic. 5896 -- Note that object declarations and aggregates generate implicit 5897 -- subtype declarations, which this covers. One special case is that the 5898 -- implicitly generated "=" for discriminated types includes an 5899 -- offending subtype declaration, which is harmless, so we ignore it 5900 -- here. 5901 5902 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then 5903 declare 5904 Cstr : constant Node_Id := Constraint (Subtype_Indication (N)); 5905 begin 5906 if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint 5907 and then not (Is_Internal (Id) 5908 and then Is_TSS (Scope (Id), 5909 TSS_Composite_Equality)) 5910 and then not Within_Init_Proc 5911 and then not All_Composite_Constraints_Static (Cstr) 5912 then 5913 Check_Restriction (No_Dynamic_Sized_Objects, Cstr); 5914 end if; 5915 end; 5916 end if; 5917 end Analyze_Subtype_Declaration; 5918 5919 -------------------------------- 5920 -- Analyze_Subtype_Indication -- 5921 -------------------------------- 5922 5923 procedure Analyze_Subtype_Indication (N : Node_Id) is 5924 T : constant Entity_Id := Subtype_Mark (N); 5925 R : constant Node_Id := Range_Expression (Constraint (N)); 5926 5927 begin 5928 Analyze (T); 5929 5930 if R /= Error then 5931 Analyze (R); 5932 Set_Etype (N, Etype (R)); 5933 Resolve (R, Entity (T)); 5934 else 5935 Set_Error_Posted (R); 5936 Set_Error_Posted (T); 5937 end if; 5938 end Analyze_Subtype_Indication; 5939 5940 -------------------------- 5941 -- Analyze_Variant_Part -- 5942 -------------------------- 5943 5944 procedure Analyze_Variant_Part (N : Node_Id) is 5945 Discr_Name : Node_Id; 5946 Discr_Type : Entity_Id; 5947 5948 procedure Process_Variant (A : Node_Id); 5949 -- Analyze declarations for a single variant 5950 5951 package Analyze_Variant_Choices is 5952 new Generic_Analyze_Choices (Process_Variant); 5953 use Analyze_Variant_Choices; 5954 5955 --------------------- 5956 -- Process_Variant -- 5957 --------------------- 5958 5959 procedure Process_Variant (A : Node_Id) is 5960 CL : constant Node_Id := Component_List (A); 5961 begin 5962 if not Null_Present (CL) then 5963 Analyze_Declarations (Component_Items (CL)); 5964 5965 if Present (Variant_Part (CL)) then 5966 Analyze (Variant_Part (CL)); 5967 end if; 5968 end if; 5969 end Process_Variant; 5970 5971 -- Start of processing for Analyze_Variant_Part 5972 5973 begin 5974 Discr_Name := Name (N); 5975 Analyze (Discr_Name); 5976 5977 -- If Discr_Name bad, get out (prevent cascaded errors) 5978 5979 if Etype (Discr_Name) = Any_Type then 5980 return; 5981 end if; 5982 5983 -- Check invalid discriminant in variant part 5984 5985 if Ekind (Entity (Discr_Name)) /= E_Discriminant then 5986 Error_Msg_N ("invalid discriminant name in variant part", Discr_Name); 5987 end if; 5988 5989 Discr_Type := Etype (Entity (Discr_Name)); 5990 5991 if not Is_Discrete_Type (Discr_Type) then 5992 Error_Msg_N 5993 ("discriminant in a variant part must be of a discrete type", 5994 Name (N)); 5995 return; 5996 end if; 5997 5998 -- Now analyze the choices, which also analyzes the declarations that 5999 -- are associated with each choice. 6000 6001 Analyze_Choices (Variants (N), Discr_Type); 6002 6003 -- Note: we used to instantiate and call Check_Choices here to check 6004 -- that the choices covered the discriminant, but it's too early to do 6005 -- that because of statically predicated subtypes, whose analysis may 6006 -- be deferred to their freeze point which may be as late as the freeze 6007 -- point of the containing record. So this call is now to be found in 6008 -- Freeze_Record_Declaration. 6009 6010 end Analyze_Variant_Part; 6011 6012 ---------------------------- 6013 -- Array_Type_Declaration -- 6014 ---------------------------- 6015 6016 procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is 6017 Component_Def : constant Node_Id := Component_Definition (Def); 6018 Component_Typ : constant Node_Id := Subtype_Indication (Component_Def); 6019 P : constant Node_Id := Parent (Def); 6020 Element_Type : Entity_Id; 6021 Implicit_Base : Entity_Id; 6022 Index : Node_Id; 6023 Nb_Index : Pos; 6024 Priv : Entity_Id; 6025 Related_Id : Entity_Id; 6026 6027 begin 6028 if Nkind (Def) = N_Constrained_Array_Definition then 6029 Index := First (Discrete_Subtype_Definitions (Def)); 6030 else 6031 Index := First (Subtype_Marks (Def)); 6032 end if; 6033 6034 -- Find proper names for the implicit types which may be public. In case 6035 -- of anonymous arrays we use the name of the first object of that type 6036 -- as prefix. 6037 6038 if No (T) then 6039 Related_Id := Defining_Identifier (P); 6040 else 6041 Related_Id := T; 6042 end if; 6043 6044 Nb_Index := 1; 6045 while Present (Index) loop 6046 Analyze (Index); 6047 6048 -- Test for odd case of trying to index a type by the type itself 6049 6050 if Is_Entity_Name (Index) and then Entity (Index) = T then 6051 Error_Msg_N ("type& cannot be indexed by itself", Index); 6052 Set_Entity (Index, Standard_Boolean); 6053 Set_Etype (Index, Standard_Boolean); 6054 end if; 6055 6056 -- Add a subtype declaration for each index of private array type 6057 -- declaration whose type is also private. For example: 6058 6059 -- package Pkg is 6060 -- type Index is private; 6061 -- private 6062 -- type Table is array (Index) of ... 6063 -- end; 6064 6065 -- This is currently required by the expander for the internally 6066 -- generated equality subprogram of records with variant parts in 6067 -- which the type of some component is such a private type. And it 6068 -- also helps semantic analysis in peculiar cases where the array 6069 -- type is referenced from an instance but not the index directly. 6070 6071 if Is_Package_Or_Generic_Package (Current_Scope) 6072 and then In_Private_Part (Current_Scope) 6073 and then Has_Private_Declaration (Etype (Index)) 6074 and then Scope (Etype (Index)) = Current_Scope 6075 then 6076 declare 6077 Loc : constant Source_Ptr := Sloc (Def); 6078 Decl : Node_Id; 6079 New_E : Entity_Id; 6080 6081 begin 6082 New_E := Make_Temporary (Loc, 'T'); 6083 Set_Is_Internal (New_E); 6084 6085 Decl := 6086 Make_Subtype_Declaration (Loc, 6087 Defining_Identifier => New_E, 6088 Subtype_Indication => 6089 New_Occurrence_Of (Etype (Index), Loc)); 6090 6091 Insert_Before (Parent (Def), Decl); 6092 Analyze (Decl); 6093 Set_Etype (Index, New_E); 6094 6095 -- If the index is a range or a subtype indication it carries 6096 -- no entity. Example: 6097 6098 -- package Pkg is 6099 -- type T is private; 6100 -- private 6101 -- type T is new Natural; 6102 -- Table : array (T(1) .. T(10)) of Boolean; 6103 -- end Pkg; 6104 6105 -- Otherwise the type of the reference is its entity. 6106 6107 if Is_Entity_Name (Index) then 6108 Set_Entity (Index, New_E); 6109 end if; 6110 end; 6111 end if; 6112 6113 Make_Index (Index, P, Related_Id, Nb_Index); 6114 6115 -- Check error of subtype with predicate for index type 6116 6117 Bad_Predicated_Subtype_Use 6118 ("subtype& has predicate, not allowed as index subtype", 6119 Index, Etype (Index)); 6120 6121 -- Move to next index 6122 6123 Next_Index (Index); 6124 Nb_Index := Nb_Index + 1; 6125 end loop; 6126 6127 -- Process subtype indication if one is present 6128 6129 if Present (Component_Typ) then 6130 Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C'); 6131 Set_Etype (Component_Typ, Element_Type); 6132 6133 -- Ada 2005 (AI-230): Access Definition case 6134 6135 else pragma Assert (Present (Access_Definition (Component_Def))); 6136 6137 -- Indicate that the anonymous access type is created by the 6138 -- array type declaration. 6139 6140 Element_Type := Access_Definition 6141 (Related_Nod => P, 6142 N => Access_Definition (Component_Def)); 6143 Set_Is_Local_Anonymous_Access (Element_Type); 6144 6145 -- Propagate the parent. This field is needed if we have to generate 6146 -- the master_id associated with an anonymous access to task type 6147 -- component (see Expand_N_Full_Type_Declaration.Build_Master) 6148 6149 Set_Parent (Element_Type, Parent (T)); 6150 6151 -- Ada 2005 (AI-230): In case of components that are anonymous access 6152 -- types the level of accessibility depends on the enclosing type 6153 -- declaration 6154 6155 Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230) 6156 6157 -- Ada 2005 (AI-254) 6158 6159 declare 6160 CD : constant Node_Id := 6161 Access_To_Subprogram_Definition 6162 (Access_Definition (Component_Def)); 6163 begin 6164 if Present (CD) and then Protected_Present (CD) then 6165 Element_Type := 6166 Replace_Anonymous_Access_To_Protected_Subprogram (Def); 6167 end if; 6168 end; 6169 end if; 6170 6171 -- Constrained array case 6172 6173 if No (T) then 6174 -- We might be creating more than one itype with the same Related_Id, 6175 -- e.g. for an array object definition and its initial value. Give 6176 -- them unique suffixes, because GNATprove require distinct types to 6177 -- have different names. 6178 6179 T := Create_Itype (E_Void, P, Related_Id, 'T', Suffix_Index => -1); 6180 end if; 6181 6182 if Nkind (Def) = N_Constrained_Array_Definition then 6183 6184 -- Establish Implicit_Base as unconstrained base type 6185 6186 Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B'); 6187 6188 Set_Etype (Implicit_Base, Implicit_Base); 6189 Set_Scope (Implicit_Base, Current_Scope); 6190 Set_Has_Delayed_Freeze (Implicit_Base); 6191 Set_Default_SSO (Implicit_Base); 6192 6193 -- The constrained array type is a subtype of the unconstrained one 6194 6195 Set_Ekind (T, E_Array_Subtype); 6196 Init_Size_Align (T); 6197 Set_Etype (T, Implicit_Base); 6198 Set_Scope (T, Current_Scope); 6199 Set_Is_Constrained (T); 6200 Set_First_Index (T, 6201 First (Discrete_Subtype_Definitions (Def))); 6202 Set_Has_Delayed_Freeze (T); 6203 6204 -- Complete setup of implicit base type 6205 6206 Set_Component_Size (Implicit_Base, Uint_0); 6207 Set_Component_Type (Implicit_Base, Element_Type); 6208 Set_Finalize_Storage_Only 6209 (Implicit_Base, 6210 Finalize_Storage_Only (Element_Type)); 6211 Set_First_Index (Implicit_Base, First_Index (T)); 6212 Set_Has_Controlled_Component 6213 (Implicit_Base, 6214 Has_Controlled_Component (Element_Type) 6215 or else Is_Controlled (Element_Type)); 6216 Set_Packed_Array_Impl_Type 6217 (Implicit_Base, Empty); 6218 6219 Propagate_Concurrent_Flags (Implicit_Base, Element_Type); 6220 6221 -- Unconstrained array case 6222 6223 else pragma Assert (Nkind (Def) = N_Unconstrained_Array_Definition); 6224 6225 Set_Ekind (T, E_Array_Type); 6226 Init_Size_Align (T); 6227 Set_Etype (T, T); 6228 Set_Scope (T, Current_Scope); 6229 Set_Component_Size (T, Uint_0); 6230 Set_Is_Constrained (T, False); 6231 Set_First_Index (T, First (Subtype_Marks (Def))); 6232 Set_Has_Delayed_Freeze (T, True); 6233 Propagate_Concurrent_Flags (T, Element_Type); 6234 Set_Has_Controlled_Component (T, Has_Controlled_Component 6235 (Element_Type) 6236 or else 6237 Is_Controlled (Element_Type)); 6238 Set_Finalize_Storage_Only (T, Finalize_Storage_Only 6239 (Element_Type)); 6240 Set_Default_SSO (T); 6241 end if; 6242 6243 -- Common attributes for both cases 6244 6245 Set_Component_Type (Base_Type (T), Element_Type); 6246 Set_Packed_Array_Impl_Type (T, Empty); 6247 6248 if Aliased_Present (Component_Definition (Def)) then 6249 Set_Has_Aliased_Components (Etype (T)); 6250 6251 -- AI12-001: All aliased objects are considered to be specified as 6252 -- independently addressable (RM C.6(8.1/4)). 6253 6254 Set_Has_Independent_Components (Etype (T)); 6255 end if; 6256 6257 -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the 6258 -- array type to ensure that objects of this type are initialized. 6259 6260 if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (Element_Type) then 6261 Set_Can_Never_Be_Null (T); 6262 6263 if Null_Exclusion_Present (Component_Definition (Def)) 6264 6265 -- No need to check itypes because in their case this check was 6266 -- done at their point of creation 6267 6268 and then not Is_Itype (Element_Type) 6269 then 6270 Error_Msg_N 6271 ("`NOT NULL` not allowed (null already excluded)", 6272 Subtype_Indication (Component_Definition (Def))); 6273 end if; 6274 end if; 6275 6276 Priv := Private_Component (Element_Type); 6277 6278 if Present (Priv) then 6279 6280 -- Check for circular definitions 6281 6282 if Priv = Any_Type then 6283 Set_Component_Type (Etype (T), Any_Type); 6284 6285 -- There is a gap in the visibility of operations on the composite 6286 -- type only if the component type is defined in a different scope. 6287 6288 elsif Scope (Priv) = Current_Scope then 6289 null; 6290 6291 elsif Is_Limited_Type (Priv) then 6292 Set_Is_Limited_Composite (Etype (T)); 6293 Set_Is_Limited_Composite (T); 6294 else 6295 Set_Is_Private_Composite (Etype (T)); 6296 Set_Is_Private_Composite (T); 6297 end if; 6298 end if; 6299 6300 -- A syntax error in the declaration itself may lead to an empty index 6301 -- list, in which case do a minimal patch. 6302 6303 if No (First_Index (T)) then 6304 Error_Msg_N ("missing index definition in array type declaration", T); 6305 6306 declare 6307 Indexes : constant List_Id := 6308 New_List (New_Occurrence_Of (Any_Id, Sloc (T))); 6309 begin 6310 Set_Discrete_Subtype_Definitions (Def, Indexes); 6311 Set_First_Index (T, First (Indexes)); 6312 return; 6313 end; 6314 end if; 6315 6316 -- Create a concatenation operator for the new type. Internal array 6317 -- types created for packed entities do not need such, they are 6318 -- compatible with the user-defined type. 6319 6320 if Number_Dimensions (T) = 1 6321 and then not Is_Packed_Array_Impl_Type (T) 6322 then 6323 New_Concatenation_Op (T); 6324 end if; 6325 6326 -- In the case of an unconstrained array the parser has already verified 6327 -- that all the indexes are unconstrained but we still need to make sure 6328 -- that the element type is constrained. 6329 6330 if not Is_Definite_Subtype (Element_Type) then 6331 Error_Msg_N 6332 ("unconstrained element type in array declaration", 6333 Subtype_Indication (Component_Def)); 6334 6335 elsif Is_Abstract_Type (Element_Type) then 6336 Error_Msg_N 6337 ("the type of a component cannot be abstract", 6338 Subtype_Indication (Component_Def)); 6339 end if; 6340 6341 -- There may be an invariant declared for the component type, but 6342 -- the construction of the component invariant checking procedure 6343 -- takes place during expansion. 6344 end Array_Type_Declaration; 6345 6346 ------------------------------------------------------ 6347 -- Replace_Anonymous_Access_To_Protected_Subprogram -- 6348 ------------------------------------------------------ 6349 6350 function Replace_Anonymous_Access_To_Protected_Subprogram 6351 (N : Node_Id) return Entity_Id 6352 is 6353 Loc : constant Source_Ptr := Sloc (N); 6354 6355 Curr_Scope : constant Scope_Stack_Entry := 6356 Scope_Stack.Table (Scope_Stack.Last); 6357 6358 Anon : constant Entity_Id := Make_Temporary (Loc, 'S'); 6359 6360 Acc : Node_Id; 6361 -- Access definition in declaration 6362 6363 Comp : Node_Id; 6364 -- Object definition or formal definition with an access definition 6365 6366 Decl : Node_Id; 6367 -- Declaration of anonymous access to subprogram type 6368 6369 Spec : Node_Id; 6370 -- Original specification in access to subprogram 6371 6372 P : Node_Id; 6373 6374 begin 6375 Set_Is_Internal (Anon); 6376 6377 case Nkind (N) is 6378 when N_Constrained_Array_Definition 6379 | N_Component_Declaration 6380 | N_Unconstrained_Array_Definition 6381 => 6382 Comp := Component_Definition (N); 6383 Acc := Access_Definition (Comp); 6384 6385 when N_Discriminant_Specification => 6386 Comp := Discriminant_Type (N); 6387 Acc := Comp; 6388 6389 when N_Parameter_Specification => 6390 Comp := Parameter_Type (N); 6391 Acc := Comp; 6392 6393 when N_Access_Function_Definition => 6394 Comp := Result_Definition (N); 6395 Acc := Comp; 6396 6397 when N_Object_Declaration => 6398 Comp := Object_Definition (N); 6399 Acc := Comp; 6400 6401 when N_Function_Specification => 6402 Comp := Result_Definition (N); 6403 Acc := Comp; 6404 6405 when others => 6406 raise Program_Error; 6407 end case; 6408 6409 Spec := Access_To_Subprogram_Definition (Acc); 6410 6411 Decl := 6412 Make_Full_Type_Declaration (Loc, 6413 Defining_Identifier => Anon, 6414 Type_Definition => Copy_Separate_Tree (Spec)); 6415 6416 Mark_Rewrite_Insertion (Decl); 6417 6418 -- Insert the new declaration in the nearest enclosing scope. If the 6419 -- parent is a body and N is its return type, the declaration belongs 6420 -- in the enclosing scope. Likewise if N is the type of a parameter. 6421 6422 P := Parent (N); 6423 6424 if Nkind (N) = N_Function_Specification 6425 and then Nkind (P) = N_Subprogram_Body 6426 then 6427 P := Parent (P); 6428 elsif Nkind (N) = N_Parameter_Specification 6429 and then Nkind (P) in N_Subprogram_Specification 6430 and then Nkind (Parent (P)) = N_Subprogram_Body 6431 then 6432 P := Parent (Parent (P)); 6433 end if; 6434 6435 while Present (P) and then not Has_Declarations (P) loop 6436 P := Parent (P); 6437 end loop; 6438 6439 pragma Assert (Present (P)); 6440 6441 if Nkind (P) = N_Package_Specification then 6442 Prepend (Decl, Visible_Declarations (P)); 6443 else 6444 Prepend (Decl, Declarations (P)); 6445 end if; 6446 6447 -- Replace the anonymous type with an occurrence of the new declaration. 6448 -- In all cases the rewritten node does not have the null-exclusion 6449 -- attribute because (if present) it was already inherited by the 6450 -- anonymous entity (Anon). Thus, in case of components we do not 6451 -- inherit this attribute. 6452 6453 if Nkind (N) = N_Parameter_Specification then 6454 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 6455 Set_Etype (Defining_Identifier (N), Anon); 6456 Set_Null_Exclusion_Present (N, False); 6457 6458 elsif Nkind (N) = N_Object_Declaration then 6459 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 6460 Set_Etype (Defining_Identifier (N), Anon); 6461 6462 elsif Nkind (N) = N_Access_Function_Definition then 6463 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 6464 6465 elsif Nkind (N) = N_Function_Specification then 6466 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 6467 Set_Etype (Defining_Unit_Name (N), Anon); 6468 6469 else 6470 Rewrite (Comp, 6471 Make_Component_Definition (Loc, 6472 Subtype_Indication => New_Occurrence_Of (Anon, Loc))); 6473 end if; 6474 6475 Mark_Rewrite_Insertion (Comp); 6476 6477 if Nkind (N) in N_Object_Declaration | N_Access_Function_Definition 6478 or else (Nkind (Parent (N)) = N_Full_Type_Declaration 6479 and then not Is_Type (Current_Scope)) 6480 then 6481 6482 -- Declaration can be analyzed in the current scope. 6483 6484 Analyze (Decl); 6485 6486 else 6487 -- Temporarily remove the current scope (record or subprogram) from 6488 -- the stack to add the new declarations to the enclosing scope. 6489 -- The anonymous entity is an Itype with the proper attributes. 6490 6491 Scope_Stack.Decrement_Last; 6492 Analyze (Decl); 6493 Set_Is_Itype (Anon); 6494 Set_Associated_Node_For_Itype (Anon, N); 6495 Scope_Stack.Append (Curr_Scope); 6496 end if; 6497 6498 Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type); 6499 Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target); 6500 return Anon; 6501 end Replace_Anonymous_Access_To_Protected_Subprogram; 6502 6503 ------------------------------------- 6504 -- Build_Access_Subprogram_Wrapper -- 6505 ------------------------------------- 6506 6507 procedure Build_Access_Subprogram_Wrapper (Decl : Node_Id) is 6508 Loc : constant Source_Ptr := Sloc (Decl); 6509 Id : constant Entity_Id := Defining_Identifier (Decl); 6510 Type_Def : constant Node_Id := Type_Definition (Decl); 6511 Specs : constant List_Id := 6512 Parameter_Specifications (Type_Def); 6513 Profile : constant List_Id := New_List; 6514 Subp : constant Entity_Id := Make_Temporary (Loc, 'A'); 6515 6516 Contracts : constant List_Id := New_List; 6517 Form_P : Node_Id; 6518 New_P : Node_Id; 6519 New_Decl : Node_Id; 6520 Spec : Node_Id; 6521 6522 procedure Replace_Type_Name (Expr : Node_Id); 6523 -- In the expressions for contract aspects, replace occurrences of the 6524 -- access type with the name of the subprogram entity, as needed, e.g. 6525 -- for 'Result. Aspects that are not contracts, e.g. Size or Alignment) 6526 -- remain on the original access type declaration. What about expanded 6527 -- names denoting formals, whose prefix in source is the type name ??? 6528 6529 ----------------------- 6530 -- Replace_Type_Name -- 6531 ----------------------- 6532 6533 procedure Replace_Type_Name (Expr : Node_Id) is 6534 function Process (N : Node_Id) return Traverse_Result; 6535 function Process (N : Node_Id) return Traverse_Result is 6536 begin 6537 if Nkind (N) = N_Attribute_Reference 6538 and then Is_Entity_Name (Prefix (N)) 6539 and then Chars (Prefix (N)) = Chars (Id) 6540 then 6541 Set_Prefix (N, Make_Identifier (Sloc (N), Chars (Subp))); 6542 end if; 6543 6544 return OK; 6545 end Process; 6546 6547 procedure Traverse is new Traverse_Proc (Process); 6548 begin 6549 Traverse (Expr); 6550 end Replace_Type_Name; 6551 6552 begin 6553 if Ekind (Id) in E_Access_Subprogram_Type 6554 | E_Access_Protected_Subprogram_Type 6555 | E_Anonymous_Access_Protected_Subprogram_Type 6556 | E_Anonymous_Access_Subprogram_Type 6557 then 6558 null; 6559 6560 else 6561 Error_Msg_N 6562 ("illegal pre/postcondition on access type", Decl); 6563 return; 6564 end if; 6565 6566 declare 6567 Asp : Node_Id; 6568 A_Id : Aspect_Id; 6569 Cond : Node_Id; 6570 Expr : Node_Id; 6571 6572 begin 6573 Asp := First (Aspect_Specifications (Decl)); 6574 while Present (Asp) loop 6575 A_Id := Get_Aspect_Id (Chars (Identifier (Asp))); 6576 if A_Id = Aspect_Pre or else A_Id = Aspect_Post then 6577 Cond := Asp; 6578 Expr := Expression (Cond); 6579 Replace_Type_Name (Expr); 6580 Next (Asp); 6581 6582 Remove (Cond); 6583 Append (Cond, Contracts); 6584 6585 else 6586 Next (Asp); 6587 end if; 6588 end loop; 6589 end; 6590 6591 -- If there are no contract aspects, no need for a wrapper. 6592 6593 if Is_Empty_List (Contracts) then 6594 return; 6595 end if; 6596 6597 Form_P := First (Specs); 6598 6599 while Present (Form_P) loop 6600 New_P := New_Copy_Tree (Form_P); 6601 Set_Defining_Identifier (New_P, 6602 Make_Defining_Identifier 6603 (Loc, Chars (Defining_Identifier (Form_P)))); 6604 Append (New_P, Profile); 6605 Next (Form_P); 6606 end loop; 6607 6608 -- Add to parameter specifications the access parameter that is passed 6609 -- in from an indirect call. 6610 6611 Append ( 6612 Make_Parameter_Specification (Loc, 6613 Defining_Identifier => Make_Temporary (Loc, 'P'), 6614 Parameter_Type => New_Occurrence_Of (Id, Loc)), 6615 Profile); 6616 6617 if Nkind (Type_Def) = N_Access_Procedure_Definition then 6618 Spec := 6619 Make_Procedure_Specification (Loc, 6620 Defining_Unit_Name => Subp, 6621 Parameter_Specifications => Profile); 6622 else 6623 Spec := 6624 Make_Function_Specification (Loc, 6625 Defining_Unit_Name => Subp, 6626 Parameter_Specifications => Profile, 6627 Result_Definition => 6628 New_Copy_Tree 6629 (Result_Definition (Type_Definition (Decl)))); 6630 end if; 6631 6632 New_Decl := 6633 Make_Subprogram_Declaration (Loc, Specification => Spec); 6634 Set_Aspect_Specifications (New_Decl, Contracts); 6635 6636 Insert_After (Decl, New_Decl); 6637 Set_Access_Subprogram_Wrapper (Designated_Type (Id), Subp); 6638 Build_Access_Subprogram_Wrapper_Body (Decl, New_Decl); 6639 end Build_Access_Subprogram_Wrapper; 6640 6641 ------------------------------- 6642 -- Build_Derived_Access_Type -- 6643 ------------------------------- 6644 6645 procedure Build_Derived_Access_Type 6646 (N : Node_Id; 6647 Parent_Type : Entity_Id; 6648 Derived_Type : Entity_Id) 6649 is 6650 S : constant Node_Id := Subtype_Indication (Type_Definition (N)); 6651 6652 Desig_Type : Entity_Id; 6653 Discr : Entity_Id; 6654 Discr_Con_Elist : Elist_Id; 6655 Discr_Con_El : Elmt_Id; 6656 Subt : Entity_Id; 6657 6658 begin 6659 -- Set the designated type so it is available in case this is an access 6660 -- to a self-referential type, e.g. a standard list type with a next 6661 -- pointer. Will be reset after subtype is built. 6662 6663 Set_Directly_Designated_Type 6664 (Derived_Type, Designated_Type (Parent_Type)); 6665 6666 Subt := Process_Subtype (S, N); 6667 6668 if Nkind (S) /= N_Subtype_Indication 6669 and then Subt /= Base_Type (Subt) 6670 then 6671 Set_Ekind (Derived_Type, E_Access_Subtype); 6672 end if; 6673 6674 if Ekind (Derived_Type) = E_Access_Subtype then 6675 declare 6676 Pbase : constant Entity_Id := Base_Type (Parent_Type); 6677 Ibase : constant Entity_Id := 6678 Create_Itype (Ekind (Pbase), N, Derived_Type, 'B'); 6679 Svg_Chars : constant Name_Id := Chars (Ibase); 6680 Svg_Next_E : constant Entity_Id := Next_Entity (Ibase); 6681 Svg_Prev_E : constant Entity_Id := Prev_Entity (Ibase); 6682 6683 begin 6684 Copy_Node (Pbase, Ibase); 6685 6686 -- Restore Itype status after Copy_Node 6687 6688 Set_Is_Itype (Ibase); 6689 Set_Associated_Node_For_Itype (Ibase, N); 6690 6691 Set_Chars (Ibase, Svg_Chars); 6692 Set_Prev_Entity (Ibase, Svg_Prev_E); 6693 Set_Next_Entity (Ibase, Svg_Next_E); 6694 Set_Sloc (Ibase, Sloc (Derived_Type)); 6695 Set_Scope (Ibase, Scope (Derived_Type)); 6696 Set_Freeze_Node (Ibase, Empty); 6697 Set_Is_Frozen (Ibase, False); 6698 Set_Comes_From_Source (Ibase, False); 6699 Set_Is_First_Subtype (Ibase, False); 6700 6701 Set_Etype (Ibase, Pbase); 6702 Set_Etype (Derived_Type, Ibase); 6703 end; 6704 end if; 6705 6706 Set_Directly_Designated_Type 6707 (Derived_Type, Designated_Type (Subt)); 6708 6709 Set_Is_Constrained (Derived_Type, Is_Constrained (Subt)); 6710 Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type)); 6711 Set_Size_Info (Derived_Type, Parent_Type); 6712 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 6713 Set_Depends_On_Private (Derived_Type, 6714 Has_Private_Component (Derived_Type)); 6715 Conditional_Delay (Derived_Type, Subt); 6716 6717 if Is_Access_Subprogram_Type (Derived_Type) then 6718 Set_Can_Use_Internal_Rep 6719 (Derived_Type, Can_Use_Internal_Rep (Parent_Type)); 6720 end if; 6721 6722 -- Ada 2005 (AI-231): Set the null-exclusion attribute, and verify 6723 -- that it is not redundant. 6724 6725 if Null_Exclusion_Present (Type_Definition (N)) then 6726 Set_Can_Never_Be_Null (Derived_Type); 6727 6728 elsif Can_Never_Be_Null (Parent_Type) then 6729 Set_Can_Never_Be_Null (Derived_Type); 6730 end if; 6731 6732 -- Note: we do not copy the Storage_Size_Variable, since we always go to 6733 -- the root type for this information. 6734 6735 -- Apply range checks to discriminants for derived record case 6736 -- ??? THIS CODE SHOULD NOT BE HERE REALLY. 6737 6738 Desig_Type := Designated_Type (Derived_Type); 6739 6740 if Is_Composite_Type (Desig_Type) 6741 and then (not Is_Array_Type (Desig_Type)) 6742 and then Has_Discriminants (Desig_Type) 6743 and then Base_Type (Desig_Type) /= Desig_Type 6744 then 6745 Discr_Con_Elist := Discriminant_Constraint (Desig_Type); 6746 Discr_Con_El := First_Elmt (Discr_Con_Elist); 6747 6748 Discr := First_Discriminant (Base_Type (Desig_Type)); 6749 while Present (Discr_Con_El) loop 6750 Apply_Range_Check (Node (Discr_Con_El), Etype (Discr)); 6751 Next_Elmt (Discr_Con_El); 6752 Next_Discriminant (Discr); 6753 end loop; 6754 end if; 6755 end Build_Derived_Access_Type; 6756 6757 ------------------------------ 6758 -- Build_Derived_Array_Type -- 6759 ------------------------------ 6760 6761 procedure Build_Derived_Array_Type 6762 (N : Node_Id; 6763 Parent_Type : Entity_Id; 6764 Derived_Type : Entity_Id) 6765 is 6766 Loc : constant Source_Ptr := Sloc (N); 6767 Tdef : constant Node_Id := Type_Definition (N); 6768 Indic : constant Node_Id := Subtype_Indication (Tdef); 6769 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 6770 Implicit_Base : Entity_Id := Empty; 6771 New_Indic : Node_Id; 6772 6773 procedure Make_Implicit_Base; 6774 -- If the parent subtype is constrained, the derived type is a subtype 6775 -- of an implicit base type derived from the parent base. 6776 6777 ------------------------ 6778 -- Make_Implicit_Base -- 6779 ------------------------ 6780 6781 procedure Make_Implicit_Base is 6782 begin 6783 Implicit_Base := 6784 Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); 6785 6786 Set_Ekind (Implicit_Base, Ekind (Parent_Base)); 6787 Set_Etype (Implicit_Base, Parent_Base); 6788 6789 Copy_Array_Subtype_Attributes (Implicit_Base, Parent_Base); 6790 Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base); 6791 6792 Set_Has_Delayed_Freeze (Implicit_Base, True); 6793 end Make_Implicit_Base; 6794 6795 -- Start of processing for Build_Derived_Array_Type 6796 6797 begin 6798 if not Is_Constrained (Parent_Type) then 6799 if Nkind (Indic) /= N_Subtype_Indication then 6800 Set_Ekind (Derived_Type, E_Array_Type); 6801 6802 Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); 6803 Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type); 6804 6805 Set_Has_Delayed_Freeze (Derived_Type, True); 6806 6807 else 6808 Make_Implicit_Base; 6809 Set_Etype (Derived_Type, Implicit_Base); 6810 6811 New_Indic := 6812 Make_Subtype_Declaration (Loc, 6813 Defining_Identifier => Derived_Type, 6814 Subtype_Indication => 6815 Make_Subtype_Indication (Loc, 6816 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc), 6817 Constraint => Constraint (Indic))); 6818 6819 Rewrite (N, New_Indic); 6820 Analyze (N); 6821 end if; 6822 6823 else 6824 if Nkind (Indic) /= N_Subtype_Indication then 6825 Make_Implicit_Base; 6826 6827 Set_Ekind (Derived_Type, Ekind (Parent_Type)); 6828 Set_Etype (Derived_Type, Implicit_Base); 6829 Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); 6830 6831 else 6832 Error_Msg_N ("illegal constraint on constrained type", Indic); 6833 end if; 6834 end if; 6835 6836 -- If parent type is not a derived type itself, and is declared in 6837 -- closed scope (e.g. a subprogram), then we must explicitly introduce 6838 -- the new type's concatenation operator since Derive_Subprograms 6839 -- will not inherit the parent's operator. If the parent type is 6840 -- unconstrained, the operator is of the unconstrained base type. 6841 6842 if Number_Dimensions (Parent_Type) = 1 6843 and then not Is_Limited_Type (Parent_Type) 6844 and then not Is_Derived_Type (Parent_Type) 6845 and then not Is_Package_Or_Generic_Package 6846 (Scope (Base_Type (Parent_Type))) 6847 then 6848 if not Is_Constrained (Parent_Type) 6849 and then Is_Constrained (Derived_Type) 6850 then 6851 New_Concatenation_Op (Implicit_Base); 6852 else 6853 New_Concatenation_Op (Derived_Type); 6854 end if; 6855 end if; 6856 end Build_Derived_Array_Type; 6857 6858 ----------------------------------- 6859 -- Build_Derived_Concurrent_Type -- 6860 ----------------------------------- 6861 6862 procedure Build_Derived_Concurrent_Type 6863 (N : Node_Id; 6864 Parent_Type : Entity_Id; 6865 Derived_Type : Entity_Id) 6866 is 6867 Loc : constant Source_Ptr := Sloc (N); 6868 Def : constant Node_Id := Type_Definition (N); 6869 Indic : constant Node_Id := Subtype_Indication (Def); 6870 6871 Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C'); 6872 Corr_Decl : Node_Id; 6873 Corr_Decl_Needed : Boolean; 6874 -- If the derived type has fewer discriminants than its parent, the 6875 -- corresponding record is also a derived type, in order to account for 6876 -- the bound discriminants. We create a full type declaration for it in 6877 -- this case. 6878 6879 Constraint_Present : constant Boolean := 6880 Nkind (Indic) = N_Subtype_Indication; 6881 6882 D_Constraint : Node_Id; 6883 New_Constraint : Elist_Id := No_Elist; 6884 Old_Disc : Entity_Id; 6885 New_Disc : Entity_Id; 6886 New_N : Node_Id; 6887 6888 begin 6889 Set_Stored_Constraint (Derived_Type, No_Elist); 6890 Corr_Decl_Needed := False; 6891 Old_Disc := Empty; 6892 6893 if Present (Discriminant_Specifications (N)) 6894 and then Constraint_Present 6895 then 6896 Old_Disc := First_Discriminant (Parent_Type); 6897 New_Disc := First (Discriminant_Specifications (N)); 6898 while Present (New_Disc) and then Present (Old_Disc) loop 6899 Next_Discriminant (Old_Disc); 6900 Next (New_Disc); 6901 end loop; 6902 end if; 6903 6904 if Present (Old_Disc) and then Expander_Active then 6905 6906 -- The new type has fewer discriminants, so we need to create a new 6907 -- corresponding record, which is derived from the corresponding 6908 -- record of the parent, and has a stored constraint that captures 6909 -- the values of the discriminant constraints. The corresponding 6910 -- record is needed only if expander is active and code generation is 6911 -- enabled. 6912 6913 -- The type declaration for the derived corresponding record has the 6914 -- same discriminant part and constraints as the current declaration. 6915 -- Copy the unanalyzed tree to build declaration. 6916 6917 Corr_Decl_Needed := True; 6918 New_N := Copy_Separate_Tree (N); 6919 6920 Corr_Decl := 6921 Make_Full_Type_Declaration (Loc, 6922 Defining_Identifier => Corr_Record, 6923 Discriminant_Specifications => 6924 Discriminant_Specifications (New_N), 6925 Type_Definition => 6926 Make_Derived_Type_Definition (Loc, 6927 Subtype_Indication => 6928 Make_Subtype_Indication (Loc, 6929 Subtype_Mark => 6930 New_Occurrence_Of 6931 (Corresponding_Record_Type (Parent_Type), Loc), 6932 Constraint => 6933 Constraint 6934 (Subtype_Indication (Type_Definition (New_N)))))); 6935 end if; 6936 6937 -- Copy Storage_Size and Relative_Deadline variables if task case 6938 6939 if Is_Task_Type (Parent_Type) then 6940 Set_Storage_Size_Variable (Derived_Type, 6941 Storage_Size_Variable (Parent_Type)); 6942 Set_Relative_Deadline_Variable (Derived_Type, 6943 Relative_Deadline_Variable (Parent_Type)); 6944 end if; 6945 6946 if Present (Discriminant_Specifications (N)) then 6947 Push_Scope (Derived_Type); 6948 Check_Or_Process_Discriminants (N, Derived_Type); 6949 6950 if Constraint_Present then 6951 New_Constraint := 6952 Expand_To_Stored_Constraint 6953 (Parent_Type, 6954 Build_Discriminant_Constraints 6955 (Parent_Type, Indic, True)); 6956 end if; 6957 6958 End_Scope; 6959 6960 elsif Constraint_Present then 6961 6962 -- Build an unconstrained derived type and rewrite the derived type 6963 -- as a subtype of this new base type. 6964 6965 declare 6966 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 6967 New_Base : Entity_Id; 6968 New_Decl : Node_Id; 6969 New_Indic : Node_Id; 6970 6971 begin 6972 New_Base := 6973 Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B'); 6974 6975 New_Decl := 6976 Make_Full_Type_Declaration (Loc, 6977 Defining_Identifier => New_Base, 6978 Type_Definition => 6979 Make_Derived_Type_Definition (Loc, 6980 Abstract_Present => Abstract_Present (Def), 6981 Limited_Present => Limited_Present (Def), 6982 Subtype_Indication => 6983 New_Occurrence_Of (Parent_Base, Loc))); 6984 6985 Mark_Rewrite_Insertion (New_Decl); 6986 Insert_Before (N, New_Decl); 6987 Analyze (New_Decl); 6988 6989 New_Indic := 6990 Make_Subtype_Indication (Loc, 6991 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 6992 Constraint => Relocate_Node (Constraint (Indic))); 6993 6994 Rewrite (N, 6995 Make_Subtype_Declaration (Loc, 6996 Defining_Identifier => Derived_Type, 6997 Subtype_Indication => New_Indic)); 6998 6999 Analyze (N); 7000 return; 7001 end; 7002 end if; 7003 7004 -- By default, operations and private data are inherited from parent. 7005 -- However, in the presence of bound discriminants, a new corresponding 7006 -- record will be created, see below. 7007 7008 Set_Has_Discriminants 7009 (Derived_Type, Has_Discriminants (Parent_Type)); 7010 Set_Corresponding_Record_Type 7011 (Derived_Type, Corresponding_Record_Type (Parent_Type)); 7012 7013 -- Is_Constrained is set according the parent subtype, but is set to 7014 -- False if the derived type is declared with new discriminants. 7015 7016 Set_Is_Constrained 7017 (Derived_Type, 7018 (Is_Constrained (Parent_Type) or else Constraint_Present) 7019 and then not Present (Discriminant_Specifications (N))); 7020 7021 if Constraint_Present then 7022 if not Has_Discriminants (Parent_Type) then 7023 Error_Msg_N ("untagged parent must have discriminants", N); 7024 7025 elsif Present (Discriminant_Specifications (N)) then 7026 7027 -- Verify that new discriminants are used to constrain old ones 7028 7029 D_Constraint := First (Constraints (Constraint (Indic))); 7030 7031 Old_Disc := First_Discriminant (Parent_Type); 7032 7033 while Present (D_Constraint) loop 7034 if Nkind (D_Constraint) /= N_Discriminant_Association then 7035 7036 -- Positional constraint. If it is a reference to a new 7037 -- discriminant, it constrains the corresponding old one. 7038 7039 if Nkind (D_Constraint) = N_Identifier then 7040 New_Disc := First_Discriminant (Derived_Type); 7041 while Present (New_Disc) loop 7042 exit when Chars (New_Disc) = Chars (D_Constraint); 7043 Next_Discriminant (New_Disc); 7044 end loop; 7045 7046 if Present (New_Disc) then 7047 Set_Corresponding_Discriminant (New_Disc, Old_Disc); 7048 end if; 7049 end if; 7050 7051 Next_Discriminant (Old_Disc); 7052 7053 -- if this is a named constraint, search by name for the old 7054 -- discriminants constrained by the new one. 7055 7056 elsif Nkind (Expression (D_Constraint)) = N_Identifier then 7057 7058 -- Find new discriminant with that name 7059 7060 New_Disc := First_Discriminant (Derived_Type); 7061 while Present (New_Disc) loop 7062 exit when 7063 Chars (New_Disc) = Chars (Expression (D_Constraint)); 7064 Next_Discriminant (New_Disc); 7065 end loop; 7066 7067 if Present (New_Disc) then 7068 7069 -- Verify that new discriminant renames some discriminant 7070 -- of the parent type, and associate the new discriminant 7071 -- with one or more old ones that it renames. 7072 7073 declare 7074 Selector : Node_Id; 7075 7076 begin 7077 Selector := First (Selector_Names (D_Constraint)); 7078 while Present (Selector) loop 7079 Old_Disc := First_Discriminant (Parent_Type); 7080 while Present (Old_Disc) loop 7081 exit when Chars (Old_Disc) = Chars (Selector); 7082 Next_Discriminant (Old_Disc); 7083 end loop; 7084 7085 if Present (Old_Disc) then 7086 Set_Corresponding_Discriminant 7087 (New_Disc, Old_Disc); 7088 end if; 7089 7090 Next (Selector); 7091 end loop; 7092 end; 7093 end if; 7094 end if; 7095 7096 Next (D_Constraint); 7097 end loop; 7098 7099 New_Disc := First_Discriminant (Derived_Type); 7100 while Present (New_Disc) loop 7101 if No (Corresponding_Discriminant (New_Disc)) then 7102 Error_Msg_NE 7103 ("new discriminant& must constrain old one", N, New_Disc); 7104 7105 -- If a new discriminant is used in the constraint, then its 7106 -- subtype must be statically compatible with the subtype of 7107 -- the parent discriminant (RM 3.7(15)). 7108 7109 else 7110 Check_Constraining_Discriminant 7111 (New_Disc, Corresponding_Discriminant (New_Disc)); 7112 end if; 7113 7114 Next_Discriminant (New_Disc); 7115 end loop; 7116 end if; 7117 7118 elsif Present (Discriminant_Specifications (N)) then 7119 Error_Msg_N 7120 ("missing discriminant constraint in untagged derivation", N); 7121 end if; 7122 7123 -- The entity chain of the derived type includes the new discriminants 7124 -- but shares operations with the parent. 7125 7126 if Present (Discriminant_Specifications (N)) then 7127 Old_Disc := First_Discriminant (Parent_Type); 7128 while Present (Old_Disc) loop 7129 if No (Next_Entity (Old_Disc)) 7130 or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant 7131 then 7132 Link_Entities 7133 (Last_Entity (Derived_Type), Next_Entity (Old_Disc)); 7134 exit; 7135 end if; 7136 7137 Next_Discriminant (Old_Disc); 7138 end loop; 7139 7140 else 7141 Set_First_Entity (Derived_Type, First_Entity (Parent_Type)); 7142 if Has_Discriminants (Parent_Type) then 7143 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 7144 Set_Discriminant_Constraint ( 7145 Derived_Type, Discriminant_Constraint (Parent_Type)); 7146 end if; 7147 end if; 7148 7149 Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type)); 7150 7151 Set_Has_Completion (Derived_Type); 7152 7153 if Corr_Decl_Needed then 7154 Set_Stored_Constraint (Derived_Type, New_Constraint); 7155 Insert_After (N, Corr_Decl); 7156 Analyze (Corr_Decl); 7157 Set_Corresponding_Record_Type (Derived_Type, Corr_Record); 7158 end if; 7159 end Build_Derived_Concurrent_Type; 7160 7161 ------------------------------------ 7162 -- Build_Derived_Enumeration_Type -- 7163 ------------------------------------ 7164 7165 procedure Build_Derived_Enumeration_Type 7166 (N : Node_Id; 7167 Parent_Type : Entity_Id; 7168 Derived_Type : Entity_Id) 7169 is 7170 function Bound_Belongs_To_Type (B : Node_Id) return Boolean; 7171 -- When the type declaration includes a constraint, we generate 7172 -- a subtype declaration of an anonymous base type, with the constraint 7173 -- given in the original type declaration. Conceptually, the bounds 7174 -- are converted to the new base type, and this conversion freezes 7175 -- (prematurely) that base type, when the bounds are simply literals. 7176 -- As a result, a representation clause for the derived type is then 7177 -- rejected or ignored. This procedure recognizes the simple case of 7178 -- literal bounds, which allows us to indicate that the conversions 7179 -- are not freeze points, and the subsequent representation clause 7180 -- can be accepted. 7181 -- A similar approach might be used to resolve the long-standing 7182 -- problem of premature freezing of derived numeric types ??? 7183 7184 function Bound_Belongs_To_Type (B : Node_Id) return Boolean is 7185 begin 7186 return Nkind (B) = N_Type_Conversion 7187 and then Is_Entity_Name (Expression (B)) 7188 and then Ekind (Entity (Expression (B))) = E_Enumeration_Literal; 7189 end Bound_Belongs_To_Type; 7190 7191 Loc : constant Source_Ptr := Sloc (N); 7192 Def : constant Node_Id := Type_Definition (N); 7193 Indic : constant Node_Id := Subtype_Indication (Def); 7194 Implicit_Base : Entity_Id; 7195 Literal : Entity_Id; 7196 New_Lit : Entity_Id; 7197 Literals_List : List_Id; 7198 Type_Decl : Node_Id; 7199 Hi, Lo : Node_Id; 7200 Rang_Expr : Node_Id; 7201 7202 begin 7203 -- Since types Standard.Character and Standard.[Wide_]Wide_Character do 7204 -- not have explicit literals lists we need to process types derived 7205 -- from them specially. This is handled by Derived_Standard_Character. 7206 -- If the parent type is a generic type, there are no literals either, 7207 -- and we construct the same skeletal representation as for the generic 7208 -- parent type. 7209 7210 if Is_Standard_Character_Type (Parent_Type) then 7211 Derived_Standard_Character (N, Parent_Type, Derived_Type); 7212 7213 elsif Is_Generic_Type (Root_Type (Parent_Type)) then 7214 declare 7215 Lo : Node_Id; 7216 Hi : Node_Id; 7217 7218 begin 7219 if Nkind (Indic) /= N_Subtype_Indication then 7220 Lo := 7221 Make_Attribute_Reference (Loc, 7222 Attribute_Name => Name_First, 7223 Prefix => New_Occurrence_Of (Derived_Type, Loc)); 7224 Set_Etype (Lo, Derived_Type); 7225 7226 Hi := 7227 Make_Attribute_Reference (Loc, 7228 Attribute_Name => Name_Last, 7229 Prefix => New_Occurrence_Of (Derived_Type, Loc)); 7230 Set_Etype (Hi, Derived_Type); 7231 7232 Set_Scalar_Range (Derived_Type, 7233 Make_Range (Loc, 7234 Low_Bound => Lo, 7235 High_Bound => Hi)); 7236 else 7237 7238 -- Analyze subtype indication and verify compatibility 7239 -- with parent type. 7240 7241 if Base_Type (Process_Subtype (Indic, N)) /= 7242 Base_Type (Parent_Type) 7243 then 7244 Error_Msg_N 7245 ("illegal constraint for formal discrete type", N); 7246 end if; 7247 end if; 7248 end; 7249 7250 else 7251 -- If a constraint is present, analyze the bounds to catch 7252 -- premature usage of the derived literals. 7253 7254 if Nkind (Indic) = N_Subtype_Indication 7255 and then Nkind (Range_Expression (Constraint (Indic))) = N_Range 7256 then 7257 Analyze (Low_Bound (Range_Expression (Constraint (Indic)))); 7258 Analyze (High_Bound (Range_Expression (Constraint (Indic)))); 7259 end if; 7260 7261 -- Introduce an implicit base type for the derived type even if there 7262 -- is no constraint attached to it, since this seems closer to the 7263 -- Ada semantics. Build a full type declaration tree for the derived 7264 -- type using the implicit base type as the defining identifier. Then 7265 -- build a subtype declaration tree which applies the constraint (if 7266 -- any) have it replace the derived type declaration. 7267 7268 Literal := First_Literal (Parent_Type); 7269 Literals_List := New_List; 7270 while Present (Literal) 7271 and then Ekind (Literal) = E_Enumeration_Literal 7272 loop 7273 -- Literals of the derived type have the same representation as 7274 -- those of the parent type, but this representation can be 7275 -- overridden by an explicit representation clause. Indicate 7276 -- that there is no explicit representation given yet. These 7277 -- derived literals are implicit operations of the new type, 7278 -- and can be overridden by explicit ones. 7279 7280 if Nkind (Literal) = N_Defining_Character_Literal then 7281 New_Lit := 7282 Make_Defining_Character_Literal (Loc, Chars (Literal)); 7283 else 7284 New_Lit := Make_Defining_Identifier (Loc, Chars (Literal)); 7285 end if; 7286 7287 Set_Ekind (New_Lit, E_Enumeration_Literal); 7288 Set_Enumeration_Pos (New_Lit, Enumeration_Pos (Literal)); 7289 Set_Enumeration_Rep (New_Lit, Enumeration_Rep (Literal)); 7290 Set_Enumeration_Rep_Expr (New_Lit, Empty); 7291 Set_Alias (New_Lit, Literal); 7292 Set_Is_Known_Valid (New_Lit, True); 7293 7294 Append (New_Lit, Literals_List); 7295 Next_Literal (Literal); 7296 end loop; 7297 7298 Implicit_Base := 7299 Make_Defining_Identifier (Sloc (Derived_Type), 7300 Chars => New_External_Name (Chars (Derived_Type), 'B')); 7301 7302 -- Indicate the proper nature of the derived type. This must be done 7303 -- before analysis of the literals, to recognize cases when a literal 7304 -- may be hidden by a previous explicit function definition (cf. 7305 -- c83031a). 7306 7307 Set_Ekind (Derived_Type, E_Enumeration_Subtype); 7308 Set_Etype (Derived_Type, Implicit_Base); 7309 7310 Type_Decl := 7311 Make_Full_Type_Declaration (Loc, 7312 Defining_Identifier => Implicit_Base, 7313 Discriminant_Specifications => No_List, 7314 Type_Definition => 7315 Make_Enumeration_Type_Definition (Loc, Literals_List)); 7316 7317 Mark_Rewrite_Insertion (Type_Decl); 7318 Insert_Before (N, Type_Decl); 7319 Analyze (Type_Decl); 7320 7321 -- The anonymous base now has a full declaration, but this base 7322 -- is not a first subtype. 7323 7324 Set_Is_First_Subtype (Implicit_Base, False); 7325 7326 -- After the implicit base is analyzed its Etype needs to be changed 7327 -- to reflect the fact that it is derived from the parent type which 7328 -- was ignored during analysis. We also set the size at this point. 7329 7330 Set_Etype (Implicit_Base, Parent_Type); 7331 7332 Set_Size_Info (Implicit_Base, Parent_Type); 7333 Set_RM_Size (Implicit_Base, RM_Size (Parent_Type)); 7334 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type)); 7335 7336 -- Copy other flags from parent type 7337 7338 Set_Has_Non_Standard_Rep 7339 (Implicit_Base, Has_Non_Standard_Rep 7340 (Parent_Type)); 7341 Set_Has_Pragma_Ordered 7342 (Implicit_Base, Has_Pragma_Ordered 7343 (Parent_Type)); 7344 Set_Has_Delayed_Freeze (Implicit_Base); 7345 7346 -- Process the subtype indication including a validation check on the 7347 -- constraint, if any. If a constraint is given, its bounds must be 7348 -- implicitly converted to the new type. 7349 7350 if Nkind (Indic) = N_Subtype_Indication then 7351 declare 7352 R : constant Node_Id := 7353 Range_Expression (Constraint (Indic)); 7354 7355 begin 7356 if Nkind (R) = N_Range then 7357 Hi := Build_Scalar_Bound 7358 (High_Bound (R), Parent_Type, Implicit_Base); 7359 Lo := Build_Scalar_Bound 7360 (Low_Bound (R), Parent_Type, Implicit_Base); 7361 7362 else 7363 -- Constraint is a Range attribute. Replace with explicit 7364 -- mention of the bounds of the prefix, which must be a 7365 -- subtype. 7366 7367 Analyze (Prefix (R)); 7368 Hi := 7369 Convert_To (Implicit_Base, 7370 Make_Attribute_Reference (Loc, 7371 Attribute_Name => Name_Last, 7372 Prefix => 7373 New_Occurrence_Of (Entity (Prefix (R)), Loc))); 7374 7375 Lo := 7376 Convert_To (Implicit_Base, 7377 Make_Attribute_Reference (Loc, 7378 Attribute_Name => Name_First, 7379 Prefix => 7380 New_Occurrence_Of (Entity (Prefix (R)), Loc))); 7381 end if; 7382 end; 7383 7384 else 7385 Hi := 7386 Build_Scalar_Bound 7387 (Type_High_Bound (Parent_Type), 7388 Parent_Type, Implicit_Base); 7389 Lo := 7390 Build_Scalar_Bound 7391 (Type_Low_Bound (Parent_Type), 7392 Parent_Type, Implicit_Base); 7393 end if; 7394 7395 Rang_Expr := 7396 Make_Range (Loc, 7397 Low_Bound => Lo, 7398 High_Bound => Hi); 7399 7400 -- If we constructed a default range for the case where no range 7401 -- was given, then the expressions in the range must not freeze 7402 -- since they do not correspond to expressions in the source. 7403 -- However, if the type inherits predicates the expressions will 7404 -- be elaborated earlier and must freeze. 7405 7406 if (Nkind (Indic) /= N_Subtype_Indication 7407 or else 7408 (Bound_Belongs_To_Type (Lo) and then Bound_Belongs_To_Type (Hi))) 7409 and then not Has_Predicates (Derived_Type) 7410 then 7411 Set_Must_Not_Freeze (Lo); 7412 Set_Must_Not_Freeze (Hi); 7413 Set_Must_Not_Freeze (Rang_Expr); 7414 end if; 7415 7416 Rewrite (N, 7417 Make_Subtype_Declaration (Loc, 7418 Defining_Identifier => Derived_Type, 7419 Subtype_Indication => 7420 Make_Subtype_Indication (Loc, 7421 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc), 7422 Constraint => 7423 Make_Range_Constraint (Loc, 7424 Range_Expression => Rang_Expr)))); 7425 7426 Analyze (N); 7427 7428 -- Propagate the aspects from the original type declaration to the 7429 -- declaration of the implicit base. 7430 7431 Move_Aspects (From => Original_Node (N), To => Type_Decl); 7432 7433 -- Apply a range check. Since this range expression doesn't have an 7434 -- Etype, we have to specifically pass the Source_Typ parameter. Is 7435 -- this right??? 7436 7437 if Nkind (Indic) = N_Subtype_Indication then 7438 Apply_Range_Check 7439 (Range_Expression (Constraint (Indic)), Parent_Type, 7440 Source_Typ => Entity (Subtype_Mark (Indic))); 7441 end if; 7442 end if; 7443 end Build_Derived_Enumeration_Type; 7444 7445 -------------------------------- 7446 -- Build_Derived_Numeric_Type -- 7447 -------------------------------- 7448 7449 procedure Build_Derived_Numeric_Type 7450 (N : Node_Id; 7451 Parent_Type : Entity_Id; 7452 Derived_Type : Entity_Id) 7453 is 7454 Loc : constant Source_Ptr := Sloc (N); 7455 Tdef : constant Node_Id := Type_Definition (N); 7456 Indic : constant Node_Id := Subtype_Indication (Tdef); 7457 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 7458 No_Constraint : constant Boolean := Nkind (Indic) /= 7459 N_Subtype_Indication; 7460 Implicit_Base : Entity_Id; 7461 7462 Lo : Node_Id; 7463 Hi : Node_Id; 7464 7465 begin 7466 -- Process the subtype indication including a validation check on 7467 -- the constraint if any. 7468 7469 Discard_Node (Process_Subtype (Indic, N)); 7470 7471 -- Introduce an implicit base type for the derived type even if there 7472 -- is no constraint attached to it, since this seems closer to the Ada 7473 -- semantics. 7474 7475 Implicit_Base := 7476 Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); 7477 7478 Set_Etype (Implicit_Base, Parent_Base); 7479 Set_Ekind (Implicit_Base, Ekind (Parent_Base)); 7480 Set_Size_Info (Implicit_Base, Parent_Base); 7481 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base)); 7482 Set_Parent (Implicit_Base, Parent (Derived_Type)); 7483 Set_Is_Known_Valid (Implicit_Base, Is_Known_Valid (Parent_Base)); 7484 Set_Is_Volatile (Implicit_Base, Is_Volatile (Parent_Base)); 7485 7486 -- Set RM Size for discrete type or decimal fixed-point type 7487 -- Ordinary fixed-point is excluded, why??? 7488 7489 if Is_Discrete_Type (Parent_Base) 7490 or else Is_Decimal_Fixed_Point_Type (Parent_Base) 7491 then 7492 Set_RM_Size (Implicit_Base, RM_Size (Parent_Base)); 7493 end if; 7494 7495 Set_Has_Delayed_Freeze (Implicit_Base); 7496 7497 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); 7498 Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); 7499 7500 Set_Scalar_Range (Implicit_Base, 7501 Make_Range (Loc, 7502 Low_Bound => Lo, 7503 High_Bound => Hi)); 7504 7505 if Has_Infinities (Parent_Base) then 7506 Set_Includes_Infinities (Scalar_Range (Implicit_Base)); 7507 end if; 7508 7509 -- The Derived_Type, which is the entity of the declaration, is a 7510 -- subtype of the implicit base. Its Ekind is a subtype, even in the 7511 -- absence of an explicit constraint. 7512 7513 Set_Etype (Derived_Type, Implicit_Base); 7514 7515 -- If we did not have a constraint, then the Ekind is set from the 7516 -- parent type (otherwise Process_Subtype has set the bounds) 7517 7518 if No_Constraint then 7519 Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type))); 7520 end if; 7521 7522 -- If we did not have a range constraint, then set the range from the 7523 -- parent type. Otherwise, the Process_Subtype call has set the bounds. 7524 7525 if No_Constraint or else not Has_Range_Constraint (Indic) then 7526 Set_Scalar_Range (Derived_Type, 7527 Make_Range (Loc, 7528 Low_Bound => New_Copy_Tree (Type_Low_Bound (Parent_Type)), 7529 High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type)))); 7530 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 7531 7532 if Has_Infinities (Parent_Type) then 7533 Set_Includes_Infinities (Scalar_Range (Derived_Type)); 7534 end if; 7535 7536 Set_Is_Known_Valid (Derived_Type, Is_Known_Valid (Parent_Type)); 7537 end if; 7538 7539 Set_Is_Descendant_Of_Address (Derived_Type, 7540 Is_Descendant_Of_Address (Parent_Type)); 7541 Set_Is_Descendant_Of_Address (Implicit_Base, 7542 Is_Descendant_Of_Address (Parent_Type)); 7543 7544 -- Set remaining type-specific fields, depending on numeric type 7545 7546 if Is_Modular_Integer_Type (Parent_Type) then 7547 Set_Modulus (Implicit_Base, Modulus (Parent_Base)); 7548 7549 Set_Non_Binary_Modulus 7550 (Implicit_Base, Non_Binary_Modulus (Parent_Base)); 7551 7552 Set_Is_Known_Valid 7553 (Implicit_Base, Is_Known_Valid (Parent_Base)); 7554 7555 elsif Is_Floating_Point_Type (Parent_Type) then 7556 7557 -- Digits of base type is always copied from the digits value of 7558 -- the parent base type, but the digits of the derived type will 7559 -- already have been set if there was a constraint present. 7560 7561 Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); 7562 Set_Float_Rep (Implicit_Base, Float_Rep (Parent_Base)); 7563 7564 if No_Constraint then 7565 Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type)); 7566 end if; 7567 7568 elsif Is_Fixed_Point_Type (Parent_Type) then 7569 7570 -- Small of base type and derived type are always copied from the 7571 -- parent base type, since smalls never change. The delta of the 7572 -- base type is also copied from the parent base type. However the 7573 -- delta of the derived type will have been set already if a 7574 -- constraint was present. 7575 7576 Set_Small_Value (Derived_Type, Small_Value (Parent_Base)); 7577 Set_Small_Value (Implicit_Base, Small_Value (Parent_Base)); 7578 Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base)); 7579 7580 if No_Constraint then 7581 Set_Delta_Value (Derived_Type, Delta_Value (Parent_Type)); 7582 end if; 7583 7584 -- The scale and machine radix in the decimal case are always 7585 -- copied from the parent base type. 7586 7587 if Is_Decimal_Fixed_Point_Type (Parent_Type) then 7588 Set_Scale_Value (Derived_Type, Scale_Value (Parent_Base)); 7589 Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base)); 7590 7591 Set_Machine_Radix_10 7592 (Derived_Type, Machine_Radix_10 (Parent_Base)); 7593 Set_Machine_Radix_10 7594 (Implicit_Base, Machine_Radix_10 (Parent_Base)); 7595 7596 Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); 7597 7598 if No_Constraint then 7599 Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base)); 7600 7601 else 7602 -- the analysis of the subtype_indication sets the 7603 -- digits value of the derived type. 7604 7605 null; 7606 end if; 7607 end if; 7608 end if; 7609 7610 if Is_Integer_Type (Parent_Type) then 7611 Set_Has_Shift_Operator 7612 (Implicit_Base, Has_Shift_Operator (Parent_Type)); 7613 end if; 7614 7615 -- The type of the bounds is that of the parent type, and they 7616 -- must be converted to the derived type. 7617 7618 Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); 7619 7620 -- The implicit_base should be frozen when the derived type is frozen, 7621 -- but note that it is used in the conversions of the bounds. For fixed 7622 -- types we delay the determination of the bounds until the proper 7623 -- freezing point. For other numeric types this is rejected by GCC, for 7624 -- reasons that are currently unclear (???), so we choose to freeze the 7625 -- implicit base now. In the case of integers and floating point types 7626 -- this is harmless because subsequent representation clauses cannot 7627 -- affect anything, but it is still baffling that we cannot use the 7628 -- same mechanism for all derived numeric types. 7629 7630 -- There is a further complication: actually some representation 7631 -- clauses can affect the implicit base type. For example, attribute 7632 -- definition clauses for stream-oriented attributes need to set the 7633 -- corresponding TSS entries on the base type, and this normally 7634 -- cannot be done after the base type is frozen, so the circuitry in 7635 -- Sem_Ch13.New_Stream_Subprogram must account for this possibility 7636 -- and not use Set_TSS in this case. 7637 7638 -- There are also consequences for the case of delayed representation 7639 -- aspects for some cases. For example, a Size aspect is delayed and 7640 -- should not be evaluated to the freeze point. This early freezing 7641 -- means that the size attribute evaluation happens too early??? 7642 7643 if Is_Fixed_Point_Type (Parent_Type) then 7644 Conditional_Delay (Implicit_Base, Parent_Type); 7645 else 7646 Freeze_Before (N, Implicit_Base); 7647 end if; 7648 end Build_Derived_Numeric_Type; 7649 7650 -------------------------------- 7651 -- Build_Derived_Private_Type -- 7652 -------------------------------- 7653 7654 procedure Build_Derived_Private_Type 7655 (N : Node_Id; 7656 Parent_Type : Entity_Id; 7657 Derived_Type : Entity_Id; 7658 Is_Completion : Boolean; 7659 Derive_Subps : Boolean := True) 7660 is 7661 Loc : constant Source_Ptr := Sloc (N); 7662 Par_Base : constant Entity_Id := Base_Type (Parent_Type); 7663 Par_Scope : constant Entity_Id := Scope (Par_Base); 7664 Full_N : constant Node_Id := New_Copy_Tree (N); 7665 Full_Der : Entity_Id := New_Copy (Derived_Type); 7666 Full_P : Entity_Id; 7667 7668 function Available_Full_View (Typ : Entity_Id) return Entity_Id; 7669 -- Return the Full_View or Underlying_Full_View of Typ, whichever is 7670 -- present (they cannot be both present for the same type), or Empty. 7671 7672 procedure Build_Full_Derivation; 7673 -- Build full derivation, i.e. derive from the full view 7674 7675 procedure Copy_And_Build; 7676 -- Copy derived type declaration, replace parent with its full view, 7677 -- and build derivation 7678 7679 ------------------------- 7680 -- Available_Full_View -- 7681 ------------------------- 7682 7683 function Available_Full_View (Typ : Entity_Id) return Entity_Id is 7684 begin 7685 if Present (Full_View (Typ)) then 7686 return Full_View (Typ); 7687 7688 elsif Present (Underlying_Full_View (Typ)) then 7689 7690 -- We should be called on a type with an underlying full view 7691 -- only by means of the recursive call made in Copy_And_Build 7692 -- through the first call to Build_Derived_Type, or else if 7693 -- the parent scope is being analyzed because we are deriving 7694 -- a completion. 7695 7696 pragma Assert (Is_Completion or else In_Private_Part (Par_Scope)); 7697 7698 return Underlying_Full_View (Typ); 7699 7700 else 7701 return Empty; 7702 end if; 7703 end Available_Full_View; 7704 7705 --------------------------- 7706 -- Build_Full_Derivation -- 7707 --------------------------- 7708 7709 procedure Build_Full_Derivation is 7710 begin 7711 -- If parent scope is not open, install the declarations 7712 7713 if not In_Open_Scopes (Par_Scope) then 7714 Install_Private_Declarations (Par_Scope); 7715 Install_Visible_Declarations (Par_Scope); 7716 Copy_And_Build; 7717 Uninstall_Declarations (Par_Scope); 7718 7719 -- If parent scope is open and in another unit, and parent has a 7720 -- completion, then the derivation is taking place in the visible 7721 -- part of a child unit. In that case retrieve the full view of 7722 -- the parent momentarily. 7723 7724 elsif not In_Same_Source_Unit (N, Parent_Type) 7725 and then Present (Full_View (Parent_Type)) 7726 then 7727 Full_P := Full_View (Parent_Type); 7728 Exchange_Declarations (Parent_Type); 7729 Copy_And_Build; 7730 Exchange_Declarations (Full_P); 7731 7732 -- Otherwise it is a local derivation 7733 7734 else 7735 Copy_And_Build; 7736 end if; 7737 end Build_Full_Derivation; 7738 7739 -------------------- 7740 -- Copy_And_Build -- 7741 -------------------- 7742 7743 procedure Copy_And_Build is 7744 Full_Parent : Entity_Id := Parent_Type; 7745 7746 begin 7747 -- If the parent is itself derived from another private type, 7748 -- installing the private declarations has not affected its 7749 -- privacy status, so use its own full view explicitly. 7750 7751 if Is_Private_Type (Full_Parent) 7752 and then Present (Full_View (Full_Parent)) 7753 then 7754 Full_Parent := Full_View (Full_Parent); 7755 end if; 7756 7757 -- If the full view is itself derived from another private type 7758 -- and has got an underlying full view, and this is done for a 7759 -- completion, i.e. to build the underlying full view of the type, 7760 -- then use this underlying full view. We cannot do that if this 7761 -- is not a completion, i.e. to build the full view of the type, 7762 -- because this would break the privacy of the parent type, except 7763 -- if the parent scope is being analyzed because we are deriving a 7764 -- completion. 7765 7766 if Is_Private_Type (Full_Parent) 7767 and then Present (Underlying_Full_View (Full_Parent)) 7768 and then (Is_Completion or else In_Private_Part (Par_Scope)) 7769 then 7770 Full_Parent := Underlying_Full_View (Full_Parent); 7771 end if; 7772 7773 -- For private, record, concurrent, access and almost all enumeration 7774 -- types, the derivation from the full view requires a fully-fledged 7775 -- declaration. In the other cases, just use an itype. 7776 7777 if Is_Private_Type (Full_Parent) 7778 or else Is_Record_Type (Full_Parent) 7779 or else Is_Concurrent_Type (Full_Parent) 7780 or else Is_Access_Type (Full_Parent) 7781 or else 7782 (Is_Enumeration_Type (Full_Parent) 7783 and then not Is_Standard_Character_Type (Full_Parent) 7784 and then not Is_Generic_Type (Root_Type (Full_Parent))) 7785 then 7786 -- Copy and adjust declaration to provide a completion for what 7787 -- is originally a private declaration. Indicate that full view 7788 -- is internally generated. 7789 7790 Set_Comes_From_Source (Full_N, False); 7791 Set_Comes_From_Source (Full_Der, False); 7792 Set_Parent (Full_Der, Full_N); 7793 Set_Defining_Identifier (Full_N, Full_Der); 7794 7795 -- If there are no constraints, adjust the subtype mark 7796 7797 if Nkind (Subtype_Indication (Type_Definition (Full_N))) /= 7798 N_Subtype_Indication 7799 then 7800 Set_Subtype_Indication 7801 (Type_Definition (Full_N), 7802 New_Occurrence_Of (Full_Parent, Sloc (Full_N))); 7803 end if; 7804 7805 Insert_After (N, Full_N); 7806 7807 -- Build full view of derived type from full view of parent which 7808 -- is now installed. Subprograms have been derived on the partial 7809 -- view, the completion does not derive them anew. 7810 7811 if Is_Record_Type (Full_Parent) then 7812 7813 -- If parent type is tagged, the completion inherits the proper 7814 -- primitive operations. 7815 7816 if Is_Tagged_Type (Parent_Type) then 7817 Build_Derived_Record_Type 7818 (Full_N, Full_Parent, Full_Der, Derive_Subps); 7819 else 7820 Build_Derived_Record_Type 7821 (Full_N, Full_Parent, Full_Der, Derive_Subps => False); 7822 end if; 7823 7824 else 7825 -- If the parent type is private, this is not a completion and 7826 -- we build the full derivation recursively as a completion. 7827 7828 Build_Derived_Type 7829 (Full_N, Full_Parent, Full_Der, 7830 Is_Completion => Is_Private_Type (Full_Parent), 7831 Derive_Subps => False); 7832 end if; 7833 7834 -- The full declaration has been introduced into the tree and 7835 -- processed in the step above. It should not be analyzed again 7836 -- (when encountered later in the current list of declarations) 7837 -- to prevent spurious name conflicts. The full entity remains 7838 -- invisible. 7839 7840 Set_Analyzed (Full_N); 7841 7842 else 7843 Full_Der := 7844 Make_Defining_Identifier (Sloc (Derived_Type), 7845 Chars => Chars (Derived_Type)); 7846 Set_Is_Itype (Full_Der); 7847 Set_Associated_Node_For_Itype (Full_Der, N); 7848 Set_Parent (Full_Der, N); 7849 Build_Derived_Type 7850 (N, Full_Parent, Full_Der, 7851 Is_Completion => False, Derive_Subps => False); 7852 end if; 7853 7854 Set_Has_Private_Declaration (Full_Der); 7855 Set_Has_Private_Declaration (Derived_Type); 7856 7857 Set_Scope (Full_Der, Scope (Derived_Type)); 7858 Set_Is_First_Subtype (Full_Der, Is_First_Subtype (Derived_Type)); 7859 Set_Has_Size_Clause (Full_Der, False); 7860 Set_Has_Alignment_Clause (Full_Der, False); 7861 Set_Has_Delayed_Freeze (Full_Der); 7862 Set_Is_Frozen (Full_Der, False); 7863 Set_Freeze_Node (Full_Der, Empty); 7864 Set_Depends_On_Private (Full_Der, Has_Private_Component (Full_Der)); 7865 Set_Is_Public (Full_Der, Is_Public (Derived_Type)); 7866 7867 -- The convention on the base type may be set in the private part 7868 -- and not propagated to the subtype until later, so we obtain the 7869 -- convention from the base type of the parent. 7870 7871 Set_Convention (Full_Der, Convention (Base_Type (Full_Parent))); 7872 end Copy_And_Build; 7873 7874 -- Start of processing for Build_Derived_Private_Type 7875 7876 begin 7877 if Is_Tagged_Type (Parent_Type) then 7878 Full_P := Full_View (Parent_Type); 7879 7880 -- A type extension of a type with unknown discriminants is an 7881 -- indefinite type that the back-end cannot handle directly. 7882 -- We treat it as a private type, and build a completion that is 7883 -- derived from the full view of the parent, and hopefully has 7884 -- known discriminants. 7885 7886 -- If the full view of the parent type has an underlying record view, 7887 -- use it to generate the underlying record view of this derived type 7888 -- (required for chains of derivations with unknown discriminants). 7889 7890 -- Minor optimization: we avoid the generation of useless underlying 7891 -- record view entities if the private type declaration has unknown 7892 -- discriminants but its corresponding full view has no 7893 -- discriminants. 7894 7895 if Has_Unknown_Discriminants (Parent_Type) 7896 and then Present (Full_P) 7897 and then (Has_Discriminants (Full_P) 7898 or else Present (Underlying_Record_View (Full_P))) 7899 and then not In_Open_Scopes (Par_Scope) 7900 and then Expander_Active 7901 then 7902 declare 7903 Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T'); 7904 New_Ext : constant Node_Id := 7905 Copy_Separate_Tree 7906 (Record_Extension_Part (Type_Definition (N))); 7907 Decl : Node_Id; 7908 7909 begin 7910 Build_Derived_Record_Type 7911 (N, Parent_Type, Derived_Type, Derive_Subps); 7912 7913 -- Build anonymous completion, as a derivation from the full 7914 -- view of the parent. This is not a completion in the usual 7915 -- sense, because the current type is not private. 7916 7917 Decl := 7918 Make_Full_Type_Declaration (Loc, 7919 Defining_Identifier => Full_Der, 7920 Type_Definition => 7921 Make_Derived_Type_Definition (Loc, 7922 Subtype_Indication => 7923 New_Copy_Tree 7924 (Subtype_Indication (Type_Definition (N))), 7925 Record_Extension_Part => New_Ext)); 7926 7927 -- If the parent type has an underlying record view, use it 7928 -- here to build the new underlying record view. 7929 7930 if Present (Underlying_Record_View (Full_P)) then 7931 pragma Assert 7932 (Nkind (Subtype_Indication (Type_Definition (Decl))) 7933 = N_Identifier); 7934 Set_Entity (Subtype_Indication (Type_Definition (Decl)), 7935 Underlying_Record_View (Full_P)); 7936 end if; 7937 7938 Install_Private_Declarations (Par_Scope); 7939 Install_Visible_Declarations (Par_Scope); 7940 Insert_Before (N, Decl); 7941 7942 -- Mark entity as an underlying record view before analysis, 7943 -- to avoid generating the list of its primitive operations 7944 -- (which is not really required for this entity) and thus 7945 -- prevent spurious errors associated with missing overriding 7946 -- of abstract primitives (overridden only for Derived_Type). 7947 7948 Set_Ekind (Full_Der, E_Record_Type); 7949 Set_Is_Underlying_Record_View (Full_Der); 7950 Set_Default_SSO (Full_Der); 7951 Set_No_Reordering (Full_Der, No_Component_Reordering); 7952 7953 Analyze (Decl); 7954 7955 pragma Assert (Has_Discriminants (Full_Der) 7956 and then not Has_Unknown_Discriminants (Full_Der)); 7957 7958 Uninstall_Declarations (Par_Scope); 7959 7960 -- Freeze the underlying record view, to prevent generation of 7961 -- useless dispatching information, which is simply shared with 7962 -- the real derived type. 7963 7964 Set_Is_Frozen (Full_Der); 7965 7966 -- If the derived type has access discriminants, create 7967 -- references to their anonymous types now, to prevent 7968 -- back-end problems when their first use is in generated 7969 -- bodies of primitives. 7970 7971 declare 7972 E : Entity_Id; 7973 7974 begin 7975 E := First_Entity (Full_Der); 7976 7977 while Present (E) loop 7978 if Ekind (E) = E_Discriminant 7979 and then Ekind (Etype (E)) = E_Anonymous_Access_Type 7980 then 7981 Build_Itype_Reference (Etype (E), Decl); 7982 end if; 7983 7984 Next_Entity (E); 7985 end loop; 7986 end; 7987 7988 -- Set up links between real entity and underlying record view 7989 7990 Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der)); 7991 Set_Underlying_Record_View (Base_Type (Full_Der), Derived_Type); 7992 end; 7993 7994 -- If discriminants are known, build derived record 7995 7996 else 7997 Build_Derived_Record_Type 7998 (N, Parent_Type, Derived_Type, Derive_Subps); 7999 end if; 8000 8001 return; 8002 8003 elsif Has_Discriminants (Parent_Type) then 8004 8005 -- Build partial view of derived type from partial view of parent. 8006 -- This must be done before building the full derivation because the 8007 -- second derivation will modify the discriminants of the first and 8008 -- the discriminants are chained with the rest of the components in 8009 -- the full derivation. 8010 8011 Build_Derived_Record_Type 8012 (N, Parent_Type, Derived_Type, Derive_Subps); 8013 8014 -- Build the full derivation if this is not the anonymous derived 8015 -- base type created by Build_Derived_Record_Type in the constrained 8016 -- case (see point 5. of its head comment) since we build it for the 8017 -- derived subtype. 8018 8019 if Present (Available_Full_View (Parent_Type)) 8020 and then not Is_Itype (Derived_Type) 8021 then 8022 declare 8023 Der_Base : constant Entity_Id := Base_Type (Derived_Type); 8024 Discr : Entity_Id; 8025 Last_Discr : Entity_Id; 8026 8027 begin 8028 -- If this is not a completion, construct the implicit full 8029 -- view by deriving from the full view of the parent type. 8030 -- But if this is a completion, the derived private type 8031 -- being built is a full view and the full derivation can 8032 -- only be its underlying full view. 8033 8034 Build_Full_Derivation; 8035 8036 if not Is_Completion then 8037 Set_Full_View (Derived_Type, Full_Der); 8038 else 8039 Set_Underlying_Full_View (Derived_Type, Full_Der); 8040 Set_Is_Underlying_Full_View (Full_Der); 8041 end if; 8042 8043 if not Is_Base_Type (Derived_Type) then 8044 Set_Full_View (Der_Base, Base_Type (Full_Der)); 8045 end if; 8046 8047 -- Copy the discriminant list from full view to the partial 8048 -- view (base type and its subtype). Gigi requires that the 8049 -- partial and full views have the same discriminants. 8050 8051 -- Note that since the partial view points to discriminants 8052 -- in the full view, their scope will be that of the full 8053 -- view. This might cause some front end problems and need 8054 -- adjustment??? 8055 8056 Discr := First_Discriminant (Base_Type (Full_Der)); 8057 Set_First_Entity (Der_Base, Discr); 8058 8059 loop 8060 Last_Discr := Discr; 8061 Next_Discriminant (Discr); 8062 exit when No (Discr); 8063 end loop; 8064 8065 Set_Last_Entity (Der_Base, Last_Discr); 8066 Set_First_Entity (Derived_Type, First_Entity (Der_Base)); 8067 Set_Last_Entity (Derived_Type, Last_Entity (Der_Base)); 8068 end; 8069 end if; 8070 8071 elsif Present (Available_Full_View (Parent_Type)) 8072 and then Has_Discriminants (Available_Full_View (Parent_Type)) 8073 then 8074 if Has_Unknown_Discriminants (Parent_Type) 8075 and then Nkind (Subtype_Indication (Type_Definition (N))) = 8076 N_Subtype_Indication 8077 then 8078 Error_Msg_N 8079 ("cannot constrain type with unknown discriminants", 8080 Subtype_Indication (Type_Definition (N))); 8081 return; 8082 end if; 8083 8084 -- If this is not a completion, construct the implicit full view by 8085 -- deriving from the full view of the parent type. But if this is a 8086 -- completion, the derived private type being built is a full view 8087 -- and the full derivation can only be its underlying full view. 8088 8089 Build_Full_Derivation; 8090 8091 if not Is_Completion then 8092 Set_Full_View (Derived_Type, Full_Der); 8093 else 8094 Set_Underlying_Full_View (Derived_Type, Full_Der); 8095 Set_Is_Underlying_Full_View (Full_Der); 8096 end if; 8097 8098 -- In any case, the primitive operations are inherited from the 8099 -- parent type, not from the internal full view. 8100 8101 Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type)); 8102 8103 if Derive_Subps then 8104 Derive_Subprograms (Parent_Type, Derived_Type); 8105 end if; 8106 8107 Set_Stored_Constraint (Derived_Type, No_Elist); 8108 Set_Is_Constrained 8109 (Derived_Type, Is_Constrained (Available_Full_View (Parent_Type))); 8110 8111 else 8112 -- Untagged type, No discriminants on either view 8113 8114 if Nkind (Subtype_Indication (Type_Definition (N))) = 8115 N_Subtype_Indication 8116 then 8117 Error_Msg_N 8118 ("illegal constraint on type without discriminants", N); 8119 end if; 8120 8121 if Present (Discriminant_Specifications (N)) 8122 and then Present (Available_Full_View (Parent_Type)) 8123 and then not Is_Tagged_Type (Available_Full_View (Parent_Type)) 8124 then 8125 Error_Msg_N ("cannot add discriminants to untagged type", N); 8126 end if; 8127 8128 Set_Stored_Constraint (Derived_Type, No_Elist); 8129 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 8130 8131 Set_Is_Controlled_Active 8132 (Derived_Type, Is_Controlled_Active (Parent_Type)); 8133 8134 Set_Disable_Controlled 8135 (Derived_Type, Disable_Controlled (Parent_Type)); 8136 8137 Set_Has_Controlled_Component 8138 (Derived_Type, Has_Controlled_Component (Parent_Type)); 8139 8140 -- Direct controlled types do not inherit Finalize_Storage_Only flag 8141 8142 if not Is_Controlled (Parent_Type) then 8143 Set_Finalize_Storage_Only 8144 (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type)); 8145 end if; 8146 8147 -- If this is not a completion, construct the implicit full view by 8148 -- deriving from the full view of the parent type. But if this is a 8149 -- completion, the derived private type being built is a full view 8150 -- and the full derivation can only be its underlying full view. 8151 8152 -- ??? If the parent type is untagged private and its completion is 8153 -- tagged, this mechanism will not work because we cannot derive from 8154 -- the tagged full view unless we have an extension. 8155 8156 if Present (Available_Full_View (Parent_Type)) 8157 and then not Is_Tagged_Type (Available_Full_View (Parent_Type)) 8158 and then not Error_Posted (N) 8159 then 8160 Build_Full_Derivation; 8161 8162 if not Is_Completion then 8163 Set_Full_View (Derived_Type, Full_Der); 8164 else 8165 Set_Underlying_Full_View (Derived_Type, Full_Der); 8166 Set_Is_Underlying_Full_View (Full_Der); 8167 end if; 8168 end if; 8169 end if; 8170 8171 Set_Has_Unknown_Discriminants (Derived_Type, 8172 Has_Unknown_Discriminants (Parent_Type)); 8173 8174 if Is_Private_Type (Derived_Type) then 8175 Set_Private_Dependents (Derived_Type, New_Elmt_List); 8176 end if; 8177 8178 -- If the parent base type is in scope, add the derived type to its 8179 -- list of private dependents, because its full view may become 8180 -- visible subsequently (in a nested private part, a body, or in a 8181 -- further child unit). 8182 8183 if Is_Private_Type (Par_Base) and then In_Open_Scopes (Par_Scope) then 8184 Append_Elmt (Derived_Type, Private_Dependents (Parent_Type)); 8185 8186 -- Check for unusual case where a type completed by a private 8187 -- derivation occurs within a package nested in a child unit, and 8188 -- the parent is declared in an ancestor. 8189 8190 if Is_Child_Unit (Scope (Current_Scope)) 8191 and then Is_Completion 8192 and then In_Private_Part (Current_Scope) 8193 and then Scope (Parent_Type) /= Current_Scope 8194 8195 -- Note that if the parent has a completion in the private part, 8196 -- (which is itself a derivation from some other private type) 8197 -- it is that completion that is visible, there is no full view 8198 -- available, and no special processing is needed. 8199 8200 and then Present (Full_View (Parent_Type)) 8201 then 8202 -- In this case, the full view of the parent type will become 8203 -- visible in the body of the enclosing child, and only then will 8204 -- the current type be possibly non-private. Build an underlying 8205 -- full view that will be installed when the enclosing child body 8206 -- is compiled. 8207 8208 if Present (Underlying_Full_View (Derived_Type)) then 8209 Full_Der := Underlying_Full_View (Derived_Type); 8210 else 8211 Build_Full_Derivation; 8212 Set_Underlying_Full_View (Derived_Type, Full_Der); 8213 Set_Is_Underlying_Full_View (Full_Der); 8214 end if; 8215 8216 -- The full view will be used to swap entities on entry/exit to 8217 -- the body, and must appear in the entity list for the package. 8218 8219 Append_Entity (Full_Der, Scope (Derived_Type)); 8220 end if; 8221 end if; 8222 end Build_Derived_Private_Type; 8223 8224 ------------------------------- 8225 -- Build_Derived_Record_Type -- 8226 ------------------------------- 8227 8228 -- 1. INTRODUCTION 8229 8230 -- Ideally we would like to use the same model of type derivation for 8231 -- tagged and untagged record types. Unfortunately this is not quite 8232 -- possible because the semantics of representation clauses is different 8233 -- for tagged and untagged records under inheritance. Consider the 8234 -- following: 8235 8236 -- type R (...) is [tagged] record ... end record; 8237 -- type T (...) is new R (...) [with ...]; 8238 8239 -- The representation clauses for T can specify a completely different 8240 -- record layout from R's. Hence the same component can be placed in two 8241 -- very different positions in objects of type T and R. If R and T are 8242 -- tagged types, representation clauses for T can only specify the layout 8243 -- of non inherited components, thus components that are common in R and T 8244 -- have the same position in objects of type R and T. 8245 8246 -- This has two implications. The first is that the entire tree for R's 8247 -- declaration needs to be copied for T in the untagged case, so that T 8248 -- can be viewed as a record type of its own with its own representation 8249 -- clauses. The second implication is the way we handle discriminants. 8250 -- Specifically, in the untagged case we need a way to communicate to Gigi 8251 -- what are the real discriminants in the record, while for the semantics 8252 -- we need to consider those introduced by the user to rename the 8253 -- discriminants in the parent type. This is handled by introducing the 8254 -- notion of stored discriminants. See below for more. 8255 8256 -- Fortunately the way regular components are inherited can be handled in 8257 -- the same way in tagged and untagged types. 8258 8259 -- To complicate things a bit more the private view of a private extension 8260 -- cannot be handled in the same way as the full view (for one thing the 8261 -- semantic rules are somewhat different). We will explain what differs 8262 -- below. 8263 8264 -- 2. DISCRIMINANTS UNDER INHERITANCE 8265 8266 -- The semantic rules governing the discriminants of derived types are 8267 -- quite subtle. 8268 8269 -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new 8270 -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART] 8271 8272 -- If parent type has discriminants, then the discriminants that are 8273 -- declared in the derived type are [3.4 (11)]: 8274 8275 -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if 8276 -- there is one; 8277 8278 -- o Otherwise, each discriminant of the parent type (implicitly declared 8279 -- in the same order with the same specifications). In this case, the 8280 -- discriminants are said to be "inherited", or if unknown in the parent 8281 -- are also unknown in the derived type. 8282 8283 -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]: 8284 8285 -- o The parent subtype must be constrained; 8286 8287 -- o If the parent type is not a tagged type, then each discriminant of 8288 -- the derived type must be used in the constraint defining a parent 8289 -- subtype. [Implementation note: This ensures that the new discriminant 8290 -- can share storage with an existing discriminant.] 8291 8292 -- For the derived type each discriminant of the parent type is either 8293 -- inherited, constrained to equal some new discriminant of the derived 8294 -- type, or constrained to the value of an expression. 8295 8296 -- When inherited or constrained to equal some new discriminant, the 8297 -- parent discriminant and the discriminant of the derived type are said 8298 -- to "correspond". 8299 8300 -- If a discriminant of the parent type is constrained to a specific value 8301 -- in the derived type definition, then the discriminant is said to be 8302 -- "specified" by that derived type definition. 8303 8304 -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES 8305 8306 -- We have spoken about stored discriminants in point 1 (introduction) 8307 -- above. There are two sorts of stored discriminants: implicit and 8308 -- explicit. As long as the derived type inherits the same discriminants as 8309 -- the root record type, stored discriminants are the same as regular 8310 -- discriminants, and are said to be implicit. However, if any discriminant 8311 -- in the root type was renamed in the derived type, then the derived 8312 -- type will contain explicit stored discriminants. Explicit stored 8313 -- discriminants are discriminants in addition to the semantically visible 8314 -- discriminants defined for the derived type. Stored discriminants are 8315 -- used by Gigi to figure out what are the physical discriminants in 8316 -- objects of the derived type (see precise definition in einfo.ads). 8317 -- As an example, consider the following: 8318 8319 -- type R (D1, D2, D3 : Int) is record ... end record; 8320 -- type T1 is new R; 8321 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1); 8322 -- type T3 is new T2; 8323 -- type T4 (Y : Int) is new T3 (Y, 99); 8324 8325 -- The following table summarizes the discriminants and stored 8326 -- discriminants in R and T1 through T4: 8327 8328 -- Type Discrim Stored Discrim Comment 8329 -- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R 8330 -- T1 (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in T1 8331 -- T2 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T2 8332 -- T3 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T3 8333 -- T4 (Y) (D1, D2, D3) Girder discrims EXPLICIT in T4 8334 8335 -- Field Corresponding_Discriminant (abbreviated CD below) allows us to 8336 -- find the corresponding discriminant in the parent type, while 8337 -- Original_Record_Component (abbreviated ORC below) the actual physical 8338 -- component that is renamed. Finally the field Is_Completely_Hidden 8339 -- (abbreviated ICH below) is set for all explicit stored discriminants 8340 -- (see einfo.ads for more info). For the above example this gives: 8341 8342 -- Discrim CD ORC ICH 8343 -- ^^^^^^^ ^^ ^^^ ^^^ 8344 -- D1 in R empty itself no 8345 -- D2 in R empty itself no 8346 -- D3 in R empty itself no 8347 8348 -- D1 in T1 D1 in R itself no 8349 -- D2 in T1 D2 in R itself no 8350 -- D3 in T1 D3 in R itself no 8351 8352 -- X1 in T2 D3 in T1 D3 in T2 no 8353 -- X2 in T2 D1 in T1 D1 in T2 no 8354 -- D1 in T2 empty itself yes 8355 -- D2 in T2 empty itself yes 8356 -- D3 in T2 empty itself yes 8357 8358 -- X1 in T3 X1 in T2 D3 in T3 no 8359 -- X2 in T3 X2 in T2 D1 in T3 no 8360 -- D1 in T3 empty itself yes 8361 -- D2 in T3 empty itself yes 8362 -- D3 in T3 empty itself yes 8363 8364 -- Y in T4 X1 in T3 D3 in T4 no 8365 -- D1 in T4 empty itself yes 8366 -- D2 in T4 empty itself yes 8367 -- D3 in T4 empty itself yes 8368 8369 -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES 8370 8371 -- Type derivation for tagged types is fairly straightforward. If no 8372 -- discriminants are specified by the derived type, these are inherited 8373 -- from the parent. No explicit stored discriminants are ever necessary. 8374 -- The only manipulation that is done to the tree is that of adding a 8375 -- _parent field with parent type and constrained to the same constraint 8376 -- specified for the parent in the derived type definition. For instance: 8377 8378 -- type R (D1, D2, D3 : Int) is tagged record ... end record; 8379 -- type T1 is new R with null record; 8380 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record; 8381 8382 -- are changed into: 8383 8384 -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record 8385 -- _parent : R (D1, D2, D3); 8386 -- end record; 8387 8388 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record 8389 -- _parent : T1 (X2, 88, X1); 8390 -- end record; 8391 8392 -- The discriminants actually present in R, T1 and T2 as well as their CD, 8393 -- ORC and ICH fields are: 8394 8395 -- Discrim CD ORC ICH 8396 -- ^^^^^^^ ^^ ^^^ ^^^ 8397 -- D1 in R empty itself no 8398 -- D2 in R empty itself no 8399 -- D3 in R empty itself no 8400 8401 -- D1 in T1 D1 in R D1 in R no 8402 -- D2 in T1 D2 in R D2 in R no 8403 -- D3 in T1 D3 in R D3 in R no 8404 8405 -- X1 in T2 D3 in T1 D3 in R no 8406 -- X2 in T2 D1 in T1 D1 in R no 8407 8408 -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS 8409 -- 8410 -- Regardless of whether we dealing with a tagged or untagged type 8411 -- we will transform all derived type declarations of the form 8412 -- 8413 -- type T is new R (...) [with ...]; 8414 -- or 8415 -- subtype S is R (...); 8416 -- type T is new S [with ...]; 8417 -- into 8418 -- type BT is new R [with ...]; 8419 -- subtype T is BT (...); 8420 -- 8421 -- That is, the base derived type is constrained only if it has no 8422 -- discriminants. The reason for doing this is that GNAT's semantic model 8423 -- assumes that a base type with discriminants is unconstrained. 8424 -- 8425 -- Note that, strictly speaking, the above transformation is not always 8426 -- correct. Consider for instance the following excerpt from ACVC b34011a: 8427 -- 8428 -- procedure B34011A is 8429 -- type REC (D : integer := 0) is record 8430 -- I : Integer; 8431 -- end record; 8432 8433 -- package P is 8434 -- type T6 is new Rec; 8435 -- function F return T6; 8436 -- end P; 8437 8438 -- use P; 8439 -- package Q6 is 8440 -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F. 8441 -- end Q6; 8442 -- 8443 -- The definition of Q6.U is illegal. However transforming Q6.U into 8444 8445 -- type BaseU is new T6; 8446 -- subtype U is BaseU (Q6.F.I) 8447 8448 -- turns U into a legal subtype, which is incorrect. To avoid this problem 8449 -- we always analyze the constraint (in this case (Q6.F.I)) before applying 8450 -- the transformation described above. 8451 8452 -- There is another instance where the above transformation is incorrect. 8453 -- Consider: 8454 8455 -- package Pack is 8456 -- type Base (D : Integer) is tagged null record; 8457 -- procedure P (X : Base); 8458 8459 -- type Der is new Base (2) with null record; 8460 -- procedure P (X : Der); 8461 -- end Pack; 8462 8463 -- Then the above transformation turns this into 8464 8465 -- type Der_Base is new Base with null record; 8466 -- -- procedure P (X : Base) is implicitly inherited here 8467 -- -- as procedure P (X : Der_Base). 8468 8469 -- subtype Der is Der_Base (2); 8470 -- procedure P (X : Der); 8471 -- -- The overriding of P (X : Der_Base) is illegal since we 8472 -- -- have a parameter conformance problem. 8473 8474 -- To get around this problem, after having semantically processed Der_Base 8475 -- and the rewritten subtype declaration for Der, we copy Der_Base field 8476 -- Discriminant_Constraint from Der so that when parameter conformance is 8477 -- checked when P is overridden, no semantic errors are flagged. 8478 8479 -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS 8480 8481 -- Regardless of whether we are dealing with a tagged or untagged type 8482 -- we will transform all derived type declarations of the form 8483 8484 -- type R (D1, .., Dn : ...) is [tagged] record ...; 8485 -- type T is new R [with ...]; 8486 -- into 8487 -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...]; 8488 8489 -- The reason for such transformation is that it allows us to implement a 8490 -- very clean form of component inheritance as explained below. 8491 8492 -- Note that this transformation is not achieved by direct tree rewriting 8493 -- and manipulation, but rather by redoing the semantic actions that the 8494 -- above transformation will entail. This is done directly in routine 8495 -- Inherit_Components. 8496 8497 -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE 8498 8499 -- In both tagged and untagged derived types, regular non discriminant 8500 -- components are inherited in the derived type from the parent type. In 8501 -- the absence of discriminants component, inheritance is straightforward 8502 -- as components can simply be copied from the parent. 8503 8504 -- If the parent has discriminants, inheriting components constrained with 8505 -- these discriminants requires caution. Consider the following example: 8506 8507 -- type R (D1, D2 : Positive) is [tagged] record 8508 -- S : String (D1 .. D2); 8509 -- end record; 8510 8511 -- type T1 is new R [with null record]; 8512 -- type T2 (X : positive) is new R (1, X) [with null record]; 8513 8514 -- As explained in 6. above, T1 is rewritten as 8515 -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record]; 8516 -- which makes the treatment for T1 and T2 identical. 8517 8518 -- What we want when inheriting S, is that references to D1 and D2 in R are 8519 -- replaced with references to their correct constraints, i.e. D1 and D2 in 8520 -- T1 and 1 and X in T2. So all R's discriminant references are replaced 8521 -- with either discriminant references in the derived type or expressions. 8522 -- This replacement is achieved as follows: before inheriting R's 8523 -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is 8524 -- created in the scope of T1 (resp. scope of T2) so that discriminants D1 8525 -- and D2 of T1 are visible (resp. discriminant X of T2 is visible). 8526 -- For T2, for instance, this has the effect of replacing String (D1 .. D2) 8527 -- by String (1 .. X). 8528 8529 -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS 8530 8531 -- We explain here the rules governing private type extensions relevant to 8532 -- type derivation. These rules are explained on the following example: 8533 8534 -- type D [(...)] is new A [(...)] with private; <-- partial view 8535 -- type D [(...)] is new P [(...)] with null record; <-- full view 8536 8537 -- Type A is called the ancestor subtype of the private extension. 8538 -- Type P is the parent type of the full view of the private extension. It 8539 -- must be A or a type derived from A. 8540 8541 -- The rules concerning the discriminants of private type extensions are 8542 -- [7.3(10-13)]: 8543 8544 -- o If a private extension inherits known discriminants from the ancestor 8545 -- subtype, then the full view must also inherit its discriminants from 8546 -- the ancestor subtype and the parent subtype of the full view must be 8547 -- constrained if and only if the ancestor subtype is constrained. 8548 8549 -- o If a partial view has unknown discriminants, then the full view may 8550 -- define a definite or an indefinite subtype, with or without 8551 -- discriminants. 8552 8553 -- o If a partial view has neither known nor unknown discriminants, then 8554 -- the full view must define a definite subtype. 8555 8556 -- o If the ancestor subtype of a private extension has constrained 8557 -- discriminants, then the parent subtype of the full view must impose a 8558 -- statically matching constraint on those discriminants. 8559 8560 -- This means that only the following forms of private extensions are 8561 -- allowed: 8562 8563 -- type D is new A with private; <-- partial view 8564 -- type D is new P with null record; <-- full view 8565 8566 -- If A has no discriminants than P has no discriminants, otherwise P must 8567 -- inherit A's discriminants. 8568 8569 -- type D is new A (...) with private; <-- partial view 8570 -- type D is new P (:::) with null record; <-- full view 8571 8572 -- P must inherit A's discriminants and (...) and (:::) must statically 8573 -- match. 8574 8575 -- subtype A is R (...); 8576 -- type D is new A with private; <-- partial view 8577 -- type D is new P with null record; <-- full view 8578 8579 -- P must have inherited R's discriminants and must be derived from A or 8580 -- any of its subtypes. 8581 8582 -- type D (..) is new A with private; <-- partial view 8583 -- type D (..) is new P [(:::)] with null record; <-- full view 8584 8585 -- No specific constraints on P's discriminants or constraint (:::). 8586 -- Note that A can be unconstrained, but the parent subtype P must either 8587 -- be constrained or (:::) must be present. 8588 8589 -- type D (..) is new A [(...)] with private; <-- partial view 8590 -- type D (..) is new P [(:::)] with null record; <-- full view 8591 8592 -- P's constraints on A's discriminants must statically match those 8593 -- imposed by (...). 8594 8595 -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS 8596 8597 -- The full view of a private extension is handled exactly as described 8598 -- above. The model chose for the private view of a private extension is 8599 -- the same for what concerns discriminants (i.e. they receive the same 8600 -- treatment as in the tagged case). However, the private view of the 8601 -- private extension always inherits the components of the parent base, 8602 -- without replacing any discriminant reference. Strictly speaking this is 8603 -- incorrect. However, Gigi never uses this view to generate code so this 8604 -- is a purely semantic issue. In theory, a set of transformations similar 8605 -- to those given in 5. and 6. above could be applied to private views of 8606 -- private extensions to have the same model of component inheritance as 8607 -- for non private extensions. However, this is not done because it would 8608 -- further complicate private type processing. Semantically speaking, this 8609 -- leaves us in an uncomfortable situation. As an example consider: 8610 8611 -- package Pack is 8612 -- type R (D : integer) is tagged record 8613 -- S : String (1 .. D); 8614 -- end record; 8615 -- procedure P (X : R); 8616 -- type T is new R (1) with private; 8617 -- private 8618 -- type T is new R (1) with null record; 8619 -- end; 8620 8621 -- This is transformed into: 8622 8623 -- package Pack is 8624 -- type R (D : integer) is tagged record 8625 -- S : String (1 .. D); 8626 -- end record; 8627 -- procedure P (X : R); 8628 -- type T is new R (1) with private; 8629 -- private 8630 -- type BaseT is new R with null record; 8631 -- subtype T is BaseT (1); 8632 -- end; 8633 8634 -- (strictly speaking the above is incorrect Ada) 8635 8636 -- From the semantic standpoint the private view of private extension T 8637 -- should be flagged as constrained since one can clearly have 8638 -- 8639 -- Obj : T; 8640 -- 8641 -- in a unit withing Pack. However, when deriving subprograms for the 8642 -- private view of private extension T, T must be seen as unconstrained 8643 -- since T has discriminants (this is a constraint of the current 8644 -- subprogram derivation model). Thus, when processing the private view of 8645 -- a private extension such as T, we first mark T as unconstrained, we 8646 -- process it, we perform program derivation and just before returning from 8647 -- Build_Derived_Record_Type we mark T as constrained. 8648 8649 -- ??? Are there are other uncomfortable cases that we will have to 8650 -- deal with. 8651 8652 -- 10. RECORD_TYPE_WITH_PRIVATE complications 8653 8654 -- Types that are derived from a visible record type and have a private 8655 -- extension present other peculiarities. They behave mostly like private 8656 -- types, but if they have primitive operations defined, these will not 8657 -- have the proper signatures for further inheritance, because other 8658 -- primitive operations will use the implicit base that we define for 8659 -- private derivations below. This affect subprogram inheritance (see 8660 -- Derive_Subprograms for details). We also derive the implicit base from 8661 -- the base type of the full view, so that the implicit base is a record 8662 -- type and not another private type, This avoids infinite loops. 8663 8664 procedure Build_Derived_Record_Type 8665 (N : Node_Id; 8666 Parent_Type : Entity_Id; 8667 Derived_Type : Entity_Id; 8668 Derive_Subps : Boolean := True) 8669 is 8670 Discriminant_Specs : constant Boolean := 8671 Present (Discriminant_Specifications (N)); 8672 Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type); 8673 Loc : constant Source_Ptr := Sloc (N); 8674 Private_Extension : constant Boolean := 8675 Nkind (N) = N_Private_Extension_Declaration; 8676 Assoc_List : Elist_Id; 8677 Constraint_Present : Boolean; 8678 Constrs : Elist_Id; 8679 Discrim : Entity_Id; 8680 Indic : Node_Id; 8681 Inherit_Discrims : Boolean := False; 8682 Last_Discrim : Entity_Id; 8683 New_Base : Entity_Id; 8684 New_Decl : Node_Id; 8685 New_Discrs : Elist_Id; 8686 New_Indic : Node_Id; 8687 Parent_Base : Entity_Id; 8688 Save_Etype : Entity_Id; 8689 Save_Discr_Constr : Elist_Id; 8690 Save_Next_Entity : Entity_Id; 8691 Type_Def : Node_Id; 8692 8693 Discs : Elist_Id := New_Elmt_List; 8694 -- An empty Discs list means that there were no constraints in the 8695 -- subtype indication or that there was an error processing it. 8696 8697 procedure Check_Generic_Ancestors; 8698 -- In Ada 2005 (AI-344), the restriction that a derived tagged type 8699 -- cannot be declared at a deeper level than its parent type is 8700 -- removed. The check on derivation within a generic body is also 8701 -- relaxed, but there's a restriction that a derived tagged type 8702 -- cannot be declared in a generic body if it's derived directly 8703 -- or indirectly from a formal type of that generic. This applies 8704 -- to progenitors as well. 8705 8706 ----------------------------- 8707 -- Check_Generic_Ancestors -- 8708 ----------------------------- 8709 8710 procedure Check_Generic_Ancestors is 8711 Ancestor_Type : Entity_Id; 8712 Intf_List : List_Id; 8713 Intf_Name : Node_Id; 8714 8715 procedure Check_Ancestor; 8716 -- For parent and progenitors. 8717 8718 -------------------- 8719 -- Check_Ancestor -- 8720 -------------------- 8721 8722 procedure Check_Ancestor is 8723 begin 8724 -- If the derived type does have a formal type as an ancestor 8725 -- then it's an error if the derived type is declared within 8726 -- the body of the generic unit that declares the formal type 8727 -- in its generic formal part. It's sufficient to check whether 8728 -- the ancestor type is declared inside the same generic body 8729 -- as the derived type (such as within a nested generic spec), 8730 -- in which case the derivation is legal. If the formal type is 8731 -- declared outside of that generic body, then it's certain 8732 -- that the derived type is declared within the generic body 8733 -- of the generic unit declaring the formal type. 8734 8735 if Is_Generic_Type (Ancestor_Type) 8736 and then Enclosing_Generic_Body (Ancestor_Type) /= 8737 Enclosing_Generic_Body (Derived_Type) 8738 then 8739 Error_Msg_NE 8740 ("ancestor type& is formal type of enclosing" 8741 & " generic unit (RM 3.9.1 (4/2))", 8742 Indic, Ancestor_Type); 8743 end if; 8744 end Check_Ancestor; 8745 8746 begin 8747 if Nkind (N) = N_Private_Extension_Declaration then 8748 Intf_List := Interface_List (N); 8749 else 8750 Intf_List := Interface_List (Type_Definition (N)); 8751 end if; 8752 8753 if Present (Enclosing_Generic_Body (Derived_Type)) then 8754 Ancestor_Type := Parent_Type; 8755 8756 while not Is_Generic_Type (Ancestor_Type) 8757 and then Etype (Ancestor_Type) /= Ancestor_Type 8758 loop 8759 Ancestor_Type := Etype (Ancestor_Type); 8760 end loop; 8761 8762 Check_Ancestor; 8763 8764 if Present (Intf_List) then 8765 Intf_Name := First (Intf_List); 8766 while Present (Intf_Name) loop 8767 Ancestor_Type := Entity (Intf_Name); 8768 Check_Ancestor; 8769 Next (Intf_Name); 8770 end loop; 8771 end if; 8772 end if; 8773 end Check_Generic_Ancestors; 8774 8775 -- Start of processing for Build_Derived_Record_Type 8776 8777 begin 8778 if Ekind (Parent_Type) = E_Record_Type_With_Private 8779 and then Present (Full_View (Parent_Type)) 8780 and then Has_Discriminants (Parent_Type) 8781 then 8782 Parent_Base := Base_Type (Full_View (Parent_Type)); 8783 else 8784 Parent_Base := Base_Type (Parent_Type); 8785 end if; 8786 8787 -- If the parent type is declared as a subtype of another private 8788 -- type with inherited discriminants, its generated base type is 8789 -- itself a record subtype. To further inherit the constraint we 8790 -- need to use its own base to have an unconstrained type on which 8791 -- to apply the inherited constraint. 8792 8793 if Ekind (Parent_Base) = E_Record_Subtype then 8794 Parent_Base := Base_Type (Parent_Base); 8795 end if; 8796 8797 -- AI05-0115: if this is a derivation from a private type in some 8798 -- other scope that may lead to invisible components for the derived 8799 -- type, mark it accordingly. 8800 8801 if Is_Private_Type (Parent_Type) then 8802 if Scope (Parent_Base) = Scope (Derived_Type) then 8803 null; 8804 8805 elsif In_Open_Scopes (Scope (Parent_Base)) 8806 and then In_Private_Part (Scope (Parent_Base)) 8807 then 8808 null; 8809 8810 else 8811 Set_Has_Private_Ancestor (Derived_Type); 8812 end if; 8813 8814 else 8815 Set_Has_Private_Ancestor 8816 (Derived_Type, Has_Private_Ancestor (Parent_Type)); 8817 end if; 8818 8819 -- Before we start the previously documented transformations, here is 8820 -- little fix for size and alignment of tagged types. Normally when we 8821 -- derive type D from type P, we copy the size and alignment of P as the 8822 -- default for D, and in the absence of explicit representation clauses 8823 -- for D, the size and alignment are indeed the same as the parent. 8824 8825 -- But this is wrong for tagged types, since fields may be added, and 8826 -- the default size may need to be larger, and the default alignment may 8827 -- need to be larger. 8828 8829 -- We therefore reset the size and alignment fields in the tagged case. 8830 -- Note that the size and alignment will in any case be at least as 8831 -- large as the parent type (since the derived type has a copy of the 8832 -- parent type in the _parent field) 8833 8834 -- The type is also marked as being tagged here, which is needed when 8835 -- processing components with a self-referential anonymous access type 8836 -- in the call to Check_Anonymous_Access_Components below. Note that 8837 -- this flag is also set later on for completeness. 8838 8839 if Is_Tagged then 8840 Set_Is_Tagged_Type (Derived_Type); 8841 Init_Size_Align (Derived_Type); 8842 end if; 8843 8844 -- STEP 0a: figure out what kind of derived type declaration we have 8845 8846 if Private_Extension then 8847 Type_Def := N; 8848 Set_Ekind (Derived_Type, E_Record_Type_With_Private); 8849 Set_Default_SSO (Derived_Type); 8850 Set_No_Reordering (Derived_Type, No_Component_Reordering); 8851 8852 else 8853 Type_Def := Type_Definition (N); 8854 8855 -- Ekind (Parent_Base) is not necessarily E_Record_Type since 8856 -- Parent_Base can be a private type or private extension. However, 8857 -- for tagged types with an extension the newly added fields are 8858 -- visible and hence the Derived_Type is always an E_Record_Type. 8859 -- (except that the parent may have its own private fields). 8860 -- For untagged types we preserve the Ekind of the Parent_Base. 8861 8862 if Present (Record_Extension_Part (Type_Def)) then 8863 Set_Ekind (Derived_Type, E_Record_Type); 8864 Set_Default_SSO (Derived_Type); 8865 Set_No_Reordering (Derived_Type, No_Component_Reordering); 8866 8867 -- Create internal access types for components with anonymous 8868 -- access types. 8869 8870 if Ada_Version >= Ada_2005 then 8871 Check_Anonymous_Access_Components 8872 (N, Derived_Type, Derived_Type, 8873 Component_List (Record_Extension_Part (Type_Def))); 8874 end if; 8875 8876 else 8877 Set_Ekind (Derived_Type, Ekind (Parent_Base)); 8878 end if; 8879 end if; 8880 8881 -- Indic can either be an N_Identifier if the subtype indication 8882 -- contains no constraint or an N_Subtype_Indication if the subtype 8883 -- indication has a constraint. In either case it can include an 8884 -- interface list. 8885 8886 Indic := Subtype_Indication (Type_Def); 8887 Constraint_Present := (Nkind (Indic) = N_Subtype_Indication); 8888 8889 -- Check that the type has visible discriminants. The type may be 8890 -- a private type with unknown discriminants whose full view has 8891 -- discriminants which are invisible. 8892 8893 if Constraint_Present then 8894 if not Has_Discriminants (Parent_Base) 8895 or else 8896 (Has_Unknown_Discriminants (Parent_Base) 8897 and then Is_Private_Type (Parent_Base)) 8898 then 8899 Error_Msg_N 8900 ("invalid constraint: type has no discriminant", 8901 Constraint (Indic)); 8902 8903 Constraint_Present := False; 8904 Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic))); 8905 8906 elsif Is_Constrained (Parent_Type) then 8907 Error_Msg_N 8908 ("invalid constraint: parent type is already constrained", 8909 Constraint (Indic)); 8910 8911 Constraint_Present := False; 8912 Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic))); 8913 end if; 8914 end if; 8915 8916 -- STEP 0b: If needed, apply transformation given in point 5. above 8917 8918 if not Private_Extension 8919 and then Has_Discriminants (Parent_Type) 8920 and then not Discriminant_Specs 8921 and then (Is_Constrained (Parent_Type) or else Constraint_Present) 8922 then 8923 -- First, we must analyze the constraint (see comment in point 5.) 8924 -- The constraint may come from the subtype indication of the full 8925 -- declaration. 8926 8927 if Constraint_Present then 8928 New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic); 8929 8930 -- If there is no explicit constraint, there might be one that is 8931 -- inherited from a constrained parent type. In that case verify that 8932 -- it conforms to the constraint in the partial view. In perverse 8933 -- cases the parent subtypes of the partial and full view can have 8934 -- different constraints. 8935 8936 elsif Present (Stored_Constraint (Parent_Type)) then 8937 New_Discrs := Stored_Constraint (Parent_Type); 8938 8939 else 8940 New_Discrs := No_Elist; 8941 end if; 8942 8943 if Has_Discriminants (Derived_Type) 8944 and then Has_Private_Declaration (Derived_Type) 8945 and then Present (Discriminant_Constraint (Derived_Type)) 8946 and then Present (New_Discrs) 8947 then 8948 -- Verify that constraints of the full view statically match 8949 -- those given in the partial view. 8950 8951 declare 8952 C1, C2 : Elmt_Id; 8953 8954 begin 8955 C1 := First_Elmt (New_Discrs); 8956 C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); 8957 while Present (C1) and then Present (C2) loop 8958 if Fully_Conformant_Expressions (Node (C1), Node (C2)) 8959 or else 8960 (Is_OK_Static_Expression (Node (C1)) 8961 and then Is_OK_Static_Expression (Node (C2)) 8962 and then 8963 Expr_Value (Node (C1)) = Expr_Value (Node (C2))) 8964 then 8965 null; 8966 8967 else 8968 if Constraint_Present then 8969 Error_Msg_N 8970 ("constraint not conformant to previous declaration", 8971 Node (C1)); 8972 else 8973 Error_Msg_N 8974 ("constraint of full view is incompatible " 8975 & "with partial view", N); 8976 end if; 8977 end if; 8978 8979 Next_Elmt (C1); 8980 Next_Elmt (C2); 8981 end loop; 8982 end; 8983 end if; 8984 8985 -- Insert and analyze the declaration for the unconstrained base type 8986 8987 New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B'); 8988 8989 New_Decl := 8990 Make_Full_Type_Declaration (Loc, 8991 Defining_Identifier => New_Base, 8992 Type_Definition => 8993 Make_Derived_Type_Definition (Loc, 8994 Abstract_Present => Abstract_Present (Type_Def), 8995 Limited_Present => Limited_Present (Type_Def), 8996 Subtype_Indication => 8997 New_Occurrence_Of (Parent_Base, Loc), 8998 Record_Extension_Part => 8999 Relocate_Node (Record_Extension_Part (Type_Def)), 9000 Interface_List => Interface_List (Type_Def))); 9001 9002 Set_Parent (New_Decl, Parent (N)); 9003 Mark_Rewrite_Insertion (New_Decl); 9004 Insert_Before (N, New_Decl); 9005 9006 -- In the extension case, make sure ancestor is frozen appropriately 9007 -- (see also non-discriminated case below). 9008 9009 if Present (Record_Extension_Part (Type_Def)) 9010 or else Is_Interface (Parent_Base) 9011 then 9012 Freeze_Before (New_Decl, Parent_Type); 9013 end if; 9014 9015 -- Note that this call passes False for the Derive_Subps parameter 9016 -- because subprogram derivation is deferred until after creating 9017 -- the subtype (see below). 9018 9019 Build_Derived_Type 9020 (New_Decl, Parent_Base, New_Base, 9021 Is_Completion => False, Derive_Subps => False); 9022 9023 -- ??? This needs re-examination to determine whether the 9024 -- above call can simply be replaced by a call to Analyze. 9025 9026 Set_Analyzed (New_Decl); 9027 9028 -- Insert and analyze the declaration for the constrained subtype 9029 9030 if Constraint_Present then 9031 New_Indic := 9032 Make_Subtype_Indication (Loc, 9033 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 9034 Constraint => Relocate_Node (Constraint (Indic))); 9035 9036 else 9037 declare 9038 Constr_List : constant List_Id := New_List; 9039 C : Elmt_Id; 9040 Expr : Node_Id; 9041 9042 begin 9043 C := First_Elmt (Discriminant_Constraint (Parent_Type)); 9044 while Present (C) loop 9045 Expr := Node (C); 9046 9047 -- It is safe here to call New_Copy_Tree since we called 9048 -- Force_Evaluation on each constraint previously 9049 -- in Build_Discriminant_Constraints. 9050 9051 Append (New_Copy_Tree (Expr), To => Constr_List); 9052 9053 Next_Elmt (C); 9054 end loop; 9055 9056 New_Indic := 9057 Make_Subtype_Indication (Loc, 9058 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 9059 Constraint => 9060 Make_Index_Or_Discriminant_Constraint (Loc, Constr_List)); 9061 end; 9062 end if; 9063 9064 Rewrite (N, 9065 Make_Subtype_Declaration (Loc, 9066 Defining_Identifier => Derived_Type, 9067 Subtype_Indication => New_Indic)); 9068 9069 Analyze (N); 9070 9071 -- Derivation of subprograms must be delayed until the full subtype 9072 -- has been established, to ensure proper overriding of subprograms 9073 -- inherited by full types. If the derivations occurred as part of 9074 -- the call to Build_Derived_Type above, then the check for type 9075 -- conformance would fail because earlier primitive subprograms 9076 -- could still refer to the full type prior the change to the new 9077 -- subtype and hence would not match the new base type created here. 9078 -- Subprograms are not derived, however, when Derive_Subps is False 9079 -- (since otherwise there could be redundant derivations). 9080 9081 if Derive_Subps then 9082 Derive_Subprograms (Parent_Type, Derived_Type); 9083 end if; 9084 9085 -- For tagged types the Discriminant_Constraint of the new base itype 9086 -- is inherited from the first subtype so that no subtype conformance 9087 -- problem arise when the first subtype overrides primitive 9088 -- operations inherited by the implicit base type. 9089 9090 if Is_Tagged then 9091 Set_Discriminant_Constraint 9092 (New_Base, Discriminant_Constraint (Derived_Type)); 9093 end if; 9094 9095 return; 9096 end if; 9097 9098 -- If we get here Derived_Type will have no discriminants or it will be 9099 -- a discriminated unconstrained base type. 9100 9101 -- STEP 1a: perform preliminary actions/checks for derived tagged types 9102 9103 if Is_Tagged then 9104 9105 -- The parent type is frozen for non-private extensions (RM 13.14(7)) 9106 -- The declaration of a specific descendant of an interface type 9107 -- freezes the interface type (RM 13.14). 9108 9109 if not Private_Extension or else Is_Interface (Parent_Base) then 9110 Freeze_Before (N, Parent_Type); 9111 end if; 9112 9113 if Ada_Version >= Ada_2005 then 9114 Check_Generic_Ancestors; 9115 9116 elsif Type_Access_Level (Derived_Type) /= 9117 Type_Access_Level (Parent_Type) 9118 and then not Is_Generic_Type (Derived_Type) 9119 then 9120 if Is_Controlled (Parent_Type) then 9121 Error_Msg_N 9122 ("controlled type must be declared at the library level", 9123 Indic); 9124 else 9125 Error_Msg_N 9126 ("type extension at deeper accessibility level than parent", 9127 Indic); 9128 end if; 9129 9130 else 9131 declare 9132 GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type); 9133 begin 9134 if Present (GB) 9135 and then GB /= Enclosing_Generic_Body (Parent_Base) 9136 then 9137 Error_Msg_NE 9138 ("parent type of& must not be outside generic body" 9139 & " (RM 3.9.1(4))", 9140 Indic, Derived_Type); 9141 end if; 9142 end; 9143 end if; 9144 end if; 9145 9146 -- Ada 2005 (AI-251) 9147 9148 if Ada_Version >= Ada_2005 and then Is_Tagged then 9149 9150 -- "The declaration of a specific descendant of an interface type 9151 -- freezes the interface type" (RM 13.14). 9152 9153 declare 9154 Iface : Node_Id; 9155 begin 9156 if Is_Non_Empty_List (Interface_List (Type_Def)) then 9157 Iface := First (Interface_List (Type_Def)); 9158 while Present (Iface) loop 9159 Freeze_Before (N, Etype (Iface)); 9160 Next (Iface); 9161 end loop; 9162 end if; 9163 end; 9164 end if; 9165 9166 -- STEP 1b : preliminary cleanup of the full view of private types 9167 9168 -- If the type is already marked as having discriminants, then it's the 9169 -- completion of a private type or private extension and we need to 9170 -- retain the discriminants from the partial view if the current 9171 -- declaration has Discriminant_Specifications so that we can verify 9172 -- conformance. However, we must remove any existing components that 9173 -- were inherited from the parent (and attached in Copy_And_Swap) 9174 -- because the full type inherits all appropriate components anyway, and 9175 -- we do not want the partial view's components interfering. 9176 9177 if Has_Discriminants (Derived_Type) and then Discriminant_Specs then 9178 Discrim := First_Discriminant (Derived_Type); 9179 loop 9180 Last_Discrim := Discrim; 9181 Next_Discriminant (Discrim); 9182 exit when No (Discrim); 9183 end loop; 9184 9185 Set_Last_Entity (Derived_Type, Last_Discrim); 9186 9187 -- In all other cases wipe out the list of inherited components (even 9188 -- inherited discriminants), it will be properly rebuilt here. 9189 9190 else 9191 Set_First_Entity (Derived_Type, Empty); 9192 Set_Last_Entity (Derived_Type, Empty); 9193 end if; 9194 9195 -- STEP 1c: Initialize some flags for the Derived_Type 9196 9197 -- The following flags must be initialized here so that 9198 -- Process_Discriminants can check that discriminants of tagged types do 9199 -- not have a default initial value and that access discriminants are 9200 -- only specified for limited records. For completeness, these flags are 9201 -- also initialized along with all the other flags below. 9202 9203 -- AI-419: Limitedness is not inherited from an interface parent, so to 9204 -- be limited in that case the type must be explicitly declared as 9205 -- limited. However, task and protected interfaces are always limited. 9206 9207 if Limited_Present (Type_Def) then 9208 Set_Is_Limited_Record (Derived_Type); 9209 9210 elsif Is_Limited_Record (Parent_Type) 9211 or else (Present (Full_View (Parent_Type)) 9212 and then Is_Limited_Record (Full_View (Parent_Type))) 9213 then 9214 if not Is_Interface (Parent_Type) 9215 or else Is_Synchronized_Interface (Parent_Type) 9216 or else Is_Protected_Interface (Parent_Type) 9217 or else Is_Task_Interface (Parent_Type) 9218 then 9219 Set_Is_Limited_Record (Derived_Type); 9220 end if; 9221 end if; 9222 9223 -- STEP 2a: process discriminants of derived type if any 9224 9225 Push_Scope (Derived_Type); 9226 9227 if Discriminant_Specs then 9228 Set_Has_Unknown_Discriminants (Derived_Type, False); 9229 9230 -- The following call initializes fields Has_Discriminants and 9231 -- Discriminant_Constraint, unless we are processing the completion 9232 -- of a private type declaration. 9233 9234 Check_Or_Process_Discriminants (N, Derived_Type); 9235 9236 -- For untagged types, the constraint on the Parent_Type must be 9237 -- present and is used to rename the discriminants. 9238 9239 if not Is_Tagged and then not Has_Discriminants (Parent_Type) then 9240 Error_Msg_N ("untagged parent must have discriminants", Indic); 9241 9242 elsif not Is_Tagged and then not Constraint_Present then 9243 Error_Msg_N 9244 ("discriminant constraint needed for derived untagged records", 9245 Indic); 9246 9247 -- Otherwise the parent subtype must be constrained unless we have a 9248 -- private extension. 9249 9250 elsif not Constraint_Present 9251 and then not Private_Extension 9252 and then not Is_Constrained (Parent_Type) 9253 then 9254 Error_Msg_N 9255 ("unconstrained type not allowed in this context", Indic); 9256 9257 elsif Constraint_Present then 9258 -- The following call sets the field Corresponding_Discriminant 9259 -- for the discriminants in the Derived_Type. 9260 9261 Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True); 9262 9263 -- For untagged types all new discriminants must rename 9264 -- discriminants in the parent. For private extensions new 9265 -- discriminants cannot rename old ones (implied by [7.3(13)]). 9266 9267 Discrim := First_Discriminant (Derived_Type); 9268 while Present (Discrim) loop 9269 if not Is_Tagged 9270 and then No (Corresponding_Discriminant (Discrim)) 9271 then 9272 Error_Msg_N 9273 ("new discriminants must constrain old ones", Discrim); 9274 9275 elsif Private_Extension 9276 and then Present (Corresponding_Discriminant (Discrim)) 9277 then 9278 Error_Msg_N 9279 ("only static constraints allowed for parent" 9280 & " discriminants in the partial view", Indic); 9281 exit; 9282 end if; 9283 9284 -- If a new discriminant is used in the constraint, then its 9285 -- subtype must be statically compatible with the subtype of 9286 -- the parent discriminant (RM 3.7(15)). 9287 9288 if Present (Corresponding_Discriminant (Discrim)) then 9289 Check_Constraining_Discriminant 9290 (Discrim, Corresponding_Discriminant (Discrim)); 9291 end if; 9292 9293 Next_Discriminant (Discrim); 9294 end loop; 9295 9296 -- Check whether the constraints of the full view statically 9297 -- match those imposed by the parent subtype [7.3(13)]. 9298 9299 if Present (Stored_Constraint (Derived_Type)) then 9300 declare 9301 C1, C2 : Elmt_Id; 9302 9303 begin 9304 C1 := First_Elmt (Discs); 9305 C2 := First_Elmt (Stored_Constraint (Derived_Type)); 9306 while Present (C1) and then Present (C2) loop 9307 if not 9308 Fully_Conformant_Expressions (Node (C1), Node (C2)) 9309 then 9310 Error_Msg_N 9311 ("not conformant with previous declaration", 9312 Node (C1)); 9313 end if; 9314 9315 Next_Elmt (C1); 9316 Next_Elmt (C2); 9317 end loop; 9318 end; 9319 end if; 9320 end if; 9321 9322 -- STEP 2b: No new discriminants, inherit discriminants if any 9323 9324 else 9325 if Private_Extension then 9326 Set_Has_Unknown_Discriminants 9327 (Derived_Type, 9328 Has_Unknown_Discriminants (Parent_Type) 9329 or else Unknown_Discriminants_Present (N)); 9330 9331 -- The partial view of the parent may have unknown discriminants, 9332 -- but if the full view has discriminants and the parent type is 9333 -- in scope they must be inherited. 9334 9335 elsif Has_Unknown_Discriminants (Parent_Type) 9336 and then 9337 (not Has_Discriminants (Parent_Type) 9338 or else not In_Open_Scopes (Scope (Parent_Base))) 9339 then 9340 Set_Has_Unknown_Discriminants (Derived_Type); 9341 end if; 9342 9343 if not Has_Unknown_Discriminants (Derived_Type) 9344 and then not Has_Unknown_Discriminants (Parent_Base) 9345 and then Has_Discriminants (Parent_Type) 9346 then 9347 Inherit_Discrims := True; 9348 Set_Has_Discriminants 9349 (Derived_Type, True); 9350 Set_Discriminant_Constraint 9351 (Derived_Type, Discriminant_Constraint (Parent_Base)); 9352 end if; 9353 9354 -- The following test is true for private types (remember 9355 -- transformation 5. is not applied to those) and in an error 9356 -- situation. 9357 9358 if Constraint_Present then 9359 Discs := Build_Discriminant_Constraints (Parent_Type, Indic); 9360 end if; 9361 9362 -- For now mark a new derived type as constrained only if it has no 9363 -- discriminants. At the end of Build_Derived_Record_Type we properly 9364 -- set this flag in the case of private extensions. See comments in 9365 -- point 9. just before body of Build_Derived_Record_Type. 9366 9367 Set_Is_Constrained 9368 (Derived_Type, 9369 not (Inherit_Discrims 9370 or else Has_Unknown_Discriminants (Derived_Type))); 9371 end if; 9372 9373 -- STEP 3: initialize fields of derived type 9374 9375 Set_Is_Tagged_Type (Derived_Type, Is_Tagged); 9376 Set_Stored_Constraint (Derived_Type, No_Elist); 9377 9378 -- Ada 2005 (AI-251): Private type-declarations can implement interfaces 9379 -- but cannot be interfaces 9380 9381 if not Private_Extension 9382 and then Ekind (Derived_Type) /= E_Private_Type 9383 and then Ekind (Derived_Type) /= E_Limited_Private_Type 9384 then 9385 if Interface_Present (Type_Def) then 9386 Analyze_Interface_Declaration (Derived_Type, Type_Def); 9387 end if; 9388 9389 Set_Interfaces (Derived_Type, No_Elist); 9390 end if; 9391 9392 -- Fields inherited from the Parent_Type 9393 9394 Set_Has_Specified_Layout 9395 (Derived_Type, Has_Specified_Layout (Parent_Type)); 9396 Set_Is_Limited_Composite 9397 (Derived_Type, Is_Limited_Composite (Parent_Type)); 9398 Set_Is_Private_Composite 9399 (Derived_Type, Is_Private_Composite (Parent_Type)); 9400 9401 if Is_Tagged_Type (Parent_Type) then 9402 Set_No_Tagged_Streams_Pragma 9403 (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type)); 9404 end if; 9405 9406 -- Fields inherited from the Parent_Base 9407 9408 Set_Has_Controlled_Component 9409 (Derived_Type, Has_Controlled_Component (Parent_Base)); 9410 Set_Has_Non_Standard_Rep 9411 (Derived_Type, Has_Non_Standard_Rep (Parent_Base)); 9412 Set_Has_Primitive_Operations 9413 (Derived_Type, Has_Primitive_Operations (Parent_Base)); 9414 9415 -- Set fields for private derived types 9416 9417 if Is_Private_Type (Derived_Type) then 9418 Set_Depends_On_Private (Derived_Type, True); 9419 Set_Private_Dependents (Derived_Type, New_Elmt_List); 9420 end if; 9421 9422 -- Inherit fields for non-private types. If this is the completion of a 9423 -- derivation from a private type, the parent itself is private and the 9424 -- attributes come from its full view, which must be present. 9425 9426 if Is_Record_Type (Derived_Type) then 9427 declare 9428 Parent_Full : Entity_Id; 9429 9430 begin 9431 if Is_Private_Type (Parent_Base) 9432 and then not Is_Record_Type (Parent_Base) 9433 then 9434 Parent_Full := Full_View (Parent_Base); 9435 else 9436 Parent_Full := Parent_Base; 9437 end if; 9438 9439 Set_Component_Alignment 9440 (Derived_Type, Component_Alignment (Parent_Full)); 9441 Set_C_Pass_By_Copy 9442 (Derived_Type, C_Pass_By_Copy (Parent_Full)); 9443 Set_Has_Complex_Representation 9444 (Derived_Type, Has_Complex_Representation (Parent_Full)); 9445 9446 -- For untagged types, inherit the layout by default to avoid 9447 -- costly changes of representation for type conversions. 9448 9449 if not Is_Tagged then 9450 Set_Is_Packed (Derived_Type, Is_Packed (Parent_Full)); 9451 Set_No_Reordering (Derived_Type, No_Reordering (Parent_Full)); 9452 end if; 9453 end; 9454 end if; 9455 9456 -- Set fields for tagged types 9457 9458 if Is_Tagged then 9459 Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); 9460 9461 -- All tagged types defined in Ada.Finalization are controlled 9462 9463 if Chars (Scope (Derived_Type)) = Name_Finalization 9464 and then Chars (Scope (Scope (Derived_Type))) = Name_Ada 9465 and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard 9466 then 9467 Set_Is_Controlled_Active (Derived_Type); 9468 else 9469 Set_Is_Controlled_Active 9470 (Derived_Type, Is_Controlled_Active (Parent_Base)); 9471 end if; 9472 9473 -- Minor optimization: there is no need to generate the class-wide 9474 -- entity associated with an underlying record view. 9475 9476 if not Is_Underlying_Record_View (Derived_Type) then 9477 Make_Class_Wide_Type (Derived_Type); 9478 end if; 9479 9480 Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def)); 9481 9482 if Has_Discriminants (Derived_Type) 9483 and then Constraint_Present 9484 then 9485 Set_Stored_Constraint 9486 (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs)); 9487 end if; 9488 9489 if Ada_Version >= Ada_2005 then 9490 declare 9491 Ifaces_List : Elist_Id; 9492 9493 begin 9494 -- Checks rules 3.9.4 (13/2 and 14/2) 9495 9496 if Comes_From_Source (Derived_Type) 9497 and then not Is_Private_Type (Derived_Type) 9498 and then Is_Interface (Parent_Type) 9499 and then not Is_Interface (Derived_Type) 9500 then 9501 if Is_Task_Interface (Parent_Type) then 9502 Error_Msg_N 9503 ("(Ada 2005) task type required (RM 3.9.4 (13.2))", 9504 Derived_Type); 9505 9506 elsif Is_Protected_Interface (Parent_Type) then 9507 Error_Msg_N 9508 ("(Ada 2005) protected type required (RM 3.9.4 (14.2))", 9509 Derived_Type); 9510 end if; 9511 end if; 9512 9513 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) 9514 9515 Check_Interfaces (N, Type_Def); 9516 9517 -- Ada 2005 (AI-251): Collect the list of progenitors that are 9518 -- not already in the parents. 9519 9520 Collect_Interfaces 9521 (T => Derived_Type, 9522 Ifaces_List => Ifaces_List, 9523 Exclude_Parents => True); 9524 9525 Set_Interfaces (Derived_Type, Ifaces_List); 9526 9527 -- If the derived type is the anonymous type created for 9528 -- a declaration whose parent has a constraint, propagate 9529 -- the interface list to the source type. This must be done 9530 -- prior to the completion of the analysis of the source type 9531 -- because the components in the extension may contain current 9532 -- instances whose legality depends on some ancestor. 9533 9534 if Is_Itype (Derived_Type) then 9535 declare 9536 Def : constant Node_Id := 9537 Associated_Node_For_Itype (Derived_Type); 9538 begin 9539 if Present (Def) 9540 and then Nkind (Def) = N_Full_Type_Declaration 9541 then 9542 Set_Interfaces 9543 (Defining_Identifier (Def), Ifaces_List); 9544 end if; 9545 end; 9546 end if; 9547 9548 -- A type extension is automatically Ghost when one of its 9549 -- progenitors is Ghost (SPARK RM 6.9(9)). This property is 9550 -- also inherited when the parent type is Ghost, but this is 9551 -- done in Build_Derived_Type as the mechanism also handles 9552 -- untagged derivations. 9553 9554 if Implements_Ghost_Interface (Derived_Type) then 9555 Set_Is_Ghost_Entity (Derived_Type); 9556 end if; 9557 end; 9558 end if; 9559 end if; 9560 9561 -- STEP 4: Inherit components from the parent base and constrain them. 9562 -- Apply the second transformation described in point 6. above. 9563 9564 if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims) 9565 or else not Has_Discriminants (Parent_Type) 9566 or else not Is_Constrained (Parent_Type) 9567 then 9568 Constrs := Discs; 9569 else 9570 Constrs := Discriminant_Constraint (Parent_Type); 9571 end if; 9572 9573 Assoc_List := 9574 Inherit_Components 9575 (N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs); 9576 9577 -- STEP 5a: Copy the parent record declaration for untagged types 9578 9579 Set_Has_Implicit_Dereference 9580 (Derived_Type, Has_Implicit_Dereference (Parent_Type)); 9581 9582 if not Is_Tagged then 9583 9584 -- Discriminant_Constraint (Derived_Type) has been properly 9585 -- constructed. Save it and temporarily set it to Empty because we 9586 -- do not want the call to New_Copy_Tree below to mess this list. 9587 9588 if Has_Discriminants (Derived_Type) then 9589 Save_Discr_Constr := Discriminant_Constraint (Derived_Type); 9590 Set_Discriminant_Constraint (Derived_Type, No_Elist); 9591 else 9592 Save_Discr_Constr := No_Elist; 9593 end if; 9594 9595 -- Save the Etype field of Derived_Type. It is correctly set now, 9596 -- but the call to New_Copy tree may remap it to point to itself, 9597 -- which is not what we want. Ditto for the Next_Entity field. 9598 9599 Save_Etype := Etype (Derived_Type); 9600 Save_Next_Entity := Next_Entity (Derived_Type); 9601 9602 -- Assoc_List maps all stored discriminants in the Parent_Base to 9603 -- stored discriminants in the Derived_Type. It is fundamental that 9604 -- no types or itypes with discriminants other than the stored 9605 -- discriminants appear in the entities declared inside 9606 -- Derived_Type, since the back end cannot deal with it. 9607 9608 New_Decl := 9609 New_Copy_Tree 9610 (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc); 9611 Copy_Dimensions_Of_Components (Derived_Type); 9612 9613 -- Restore the fields saved prior to the New_Copy_Tree call 9614 -- and compute the stored constraint. 9615 9616 Set_Etype (Derived_Type, Save_Etype); 9617 Link_Entities (Derived_Type, Save_Next_Entity); 9618 9619 if Has_Discriminants (Derived_Type) then 9620 Set_Discriminant_Constraint 9621 (Derived_Type, Save_Discr_Constr); 9622 Set_Stored_Constraint 9623 (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs)); 9624 9625 Replace_Discriminants (Derived_Type, New_Decl); 9626 end if; 9627 9628 -- Insert the new derived type declaration 9629 9630 Rewrite (N, New_Decl); 9631 9632 -- STEP 5b: Complete the processing for record extensions in generics 9633 9634 -- There is no completion for record extensions declared in the 9635 -- parameter part of a generic, so we need to complete processing for 9636 -- these generic record extensions here. The Record_Type_Definition call 9637 -- will change the Ekind of the components from E_Void to E_Component. 9638 9639 elsif Private_Extension and then Is_Generic_Type (Derived_Type) then 9640 Record_Type_Definition (Empty, Derived_Type); 9641 9642 -- STEP 5c: Process the record extension for non private tagged types 9643 9644 elsif not Private_Extension then 9645 Expand_Record_Extension (Derived_Type, Type_Def); 9646 9647 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the 9648 -- implemented interfaces if we are in expansion mode 9649 9650 if Expander_Active 9651 and then Has_Interfaces (Derived_Type) 9652 then 9653 Add_Interface_Tag_Components (N, Derived_Type); 9654 end if; 9655 9656 -- Analyze the record extension 9657 9658 Record_Type_Definition 9659 (Record_Extension_Part (Type_Def), Derived_Type); 9660 end if; 9661 9662 End_Scope; 9663 9664 -- Nothing else to do if there is an error in the derivation. 9665 -- An unusual case: the full view may be derived from a type in an 9666 -- instance, when the partial view was used illegally as an actual 9667 -- in that instance, leading to a circular definition. 9668 9669 if Etype (Derived_Type) = Any_Type 9670 or else Etype (Parent_Type) = Derived_Type 9671 then 9672 return; 9673 end if; 9674 9675 -- Set delayed freeze and then derive subprograms, we need to do 9676 -- this in this order so that derived subprograms inherit the 9677 -- derived freeze if necessary. 9678 9679 Set_Has_Delayed_Freeze (Derived_Type); 9680 9681 if Derive_Subps then 9682 Derive_Subprograms (Parent_Type, Derived_Type); 9683 end if; 9684 9685 -- If we have a private extension which defines a constrained derived 9686 -- type mark as constrained here after we have derived subprograms. See 9687 -- comment on point 9. just above the body of Build_Derived_Record_Type. 9688 9689 if Private_Extension and then Inherit_Discrims then 9690 if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then 9691 Set_Is_Constrained (Derived_Type, True); 9692 Set_Discriminant_Constraint (Derived_Type, Discs); 9693 9694 elsif Is_Constrained (Parent_Type) then 9695 Set_Is_Constrained 9696 (Derived_Type, True); 9697 Set_Discriminant_Constraint 9698 (Derived_Type, Discriminant_Constraint (Parent_Type)); 9699 end if; 9700 end if; 9701 9702 -- Update the class-wide type, which shares the now-completed entity 9703 -- list with its specific type. In case of underlying record views, 9704 -- we do not generate the corresponding class wide entity. 9705 9706 if Is_Tagged 9707 and then not Is_Underlying_Record_View (Derived_Type) 9708 then 9709 Set_First_Entity 9710 (Class_Wide_Type (Derived_Type), First_Entity (Derived_Type)); 9711 Set_Last_Entity 9712 (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type)); 9713 end if; 9714 9715 Check_Function_Writable_Actuals (N); 9716 end Build_Derived_Record_Type; 9717 9718 ------------------------ 9719 -- Build_Derived_Type -- 9720 ------------------------ 9721 9722 procedure Build_Derived_Type 9723 (N : Node_Id; 9724 Parent_Type : Entity_Id; 9725 Derived_Type : Entity_Id; 9726 Is_Completion : Boolean; 9727 Derive_Subps : Boolean := True) 9728 is 9729 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 9730 9731 begin 9732 -- Set common attributes 9733 9734 Set_Scope (Derived_Type, Current_Scope); 9735 Set_Etype (Derived_Type, Parent_Base); 9736 Set_Ekind (Derived_Type, Ekind (Parent_Base)); 9737 Propagate_Concurrent_Flags (Derived_Type, Parent_Base); 9738 9739 Set_Size_Info (Derived_Type, Parent_Type); 9740 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 9741 9742 Set_Is_Controlled_Active 9743 (Derived_Type, Is_Controlled_Active (Parent_Type)); 9744 9745 Set_Disable_Controlled (Derived_Type, Disable_Controlled (Parent_Type)); 9746 Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); 9747 Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type)); 9748 9749 if Is_Tagged_Type (Derived_Type) then 9750 Set_No_Tagged_Streams_Pragma 9751 (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type)); 9752 end if; 9753 9754 -- If the parent has primitive routines and may have not-seen-yet aspect 9755 -- specifications (e.g., a Pack pragma), then set the derived type link 9756 -- in order to later diagnose "early derivation" issues. If in different 9757 -- compilation units, then "early derivation" cannot be an issue (and we 9758 -- don't like interunit references that go in the opposite direction of 9759 -- semantic dependencies). 9760 9761 if Has_Primitive_Operations (Parent_Type) 9762 and then Enclosing_Comp_Unit_Node (Parent_Type) = 9763 Enclosing_Comp_Unit_Node (Derived_Type) 9764 then 9765 Set_Derived_Type_Link (Parent_Base, Derived_Type); 9766 end if; 9767 9768 -- If the parent type is a private subtype, the convention on the base 9769 -- type may be set in the private part, and not propagated to the 9770 -- subtype until later, so we obtain the convention from the base type. 9771 9772 Set_Convention (Derived_Type, Convention (Parent_Base)); 9773 9774 if Is_Tagged_Type (Derived_Type) 9775 and then Present (Class_Wide_Type (Derived_Type)) 9776 then 9777 Set_Convention (Class_Wide_Type (Derived_Type), 9778 Convention (Class_Wide_Type (Parent_Base))); 9779 end if; 9780 9781 -- Set SSO default for record or array type 9782 9783 if (Is_Array_Type (Derived_Type) or else Is_Record_Type (Derived_Type)) 9784 and then Is_Base_Type (Derived_Type) 9785 then 9786 Set_Default_SSO (Derived_Type); 9787 end if; 9788 9789 -- A derived type inherits the Default_Initial_Condition pragma coming 9790 -- from any parent type within the derivation chain. 9791 9792 if Has_DIC (Parent_Type) then 9793 Set_Has_Inherited_DIC (Derived_Type); 9794 end if; 9795 9796 -- A derived type inherits any class-wide invariants coming from a 9797 -- parent type or an interface. Note that the invariant procedure of 9798 -- the parent type should not be inherited because the derived type may 9799 -- define invariants of its own. 9800 9801 if not Is_Interface (Derived_Type) then 9802 if Has_Inherited_Invariants (Parent_Type) 9803 or else Has_Inheritable_Invariants (Parent_Type) 9804 then 9805 Set_Has_Inherited_Invariants (Derived_Type); 9806 9807 elsif Is_Concurrent_Type (Derived_Type) 9808 or else Is_Tagged_Type (Derived_Type) 9809 then 9810 declare 9811 Iface : Entity_Id; 9812 Ifaces : Elist_Id; 9813 Iface_Elmt : Elmt_Id; 9814 9815 begin 9816 Collect_Interfaces 9817 (T => Derived_Type, 9818 Ifaces_List => Ifaces, 9819 Exclude_Parents => True); 9820 9821 if Present (Ifaces) then 9822 Iface_Elmt := First_Elmt (Ifaces); 9823 while Present (Iface_Elmt) loop 9824 Iface := Node (Iface_Elmt); 9825 9826 if Has_Inheritable_Invariants (Iface) then 9827 Set_Has_Inherited_Invariants (Derived_Type); 9828 exit; 9829 end if; 9830 9831 Next_Elmt (Iface_Elmt); 9832 end loop; 9833 end if; 9834 end; 9835 end if; 9836 end if; 9837 9838 -- We similarly inherit predicates. Note that for scalar derived types 9839 -- the predicate is inherited from the first subtype, and not from its 9840 -- (anonymous) base type. 9841 9842 if Has_Predicates (Parent_Type) 9843 or else Has_Predicates (First_Subtype (Parent_Type)) 9844 then 9845 Set_Has_Predicates (Derived_Type); 9846 end if; 9847 9848 -- The derived type inherits representation clauses from the parent 9849 -- type, and from any interfaces. 9850 9851 Inherit_Rep_Item_Chain (Derived_Type, Parent_Type); 9852 9853 declare 9854 Iface : Node_Id := First (Abstract_Interface_List (Derived_Type)); 9855 begin 9856 while Present (Iface) loop 9857 Inherit_Rep_Item_Chain (Derived_Type, Entity (Iface)); 9858 Next (Iface); 9859 end loop; 9860 end; 9861 9862 -- If the parent type has delayed rep aspects, then mark the derived 9863 -- type as possibly inheriting a delayed rep aspect. 9864 9865 if Has_Delayed_Rep_Aspects (Parent_Type) then 9866 Set_May_Inherit_Delayed_Rep_Aspects (Derived_Type); 9867 end if; 9868 9869 -- A derived type becomes Ghost when its parent type is also Ghost 9870 -- (SPARK RM 6.9(9)). Note that the Ghost-related attributes are not 9871 -- directly inherited because the Ghost policy in effect may differ. 9872 9873 if Is_Ghost_Entity (Parent_Type) then 9874 Set_Is_Ghost_Entity (Derived_Type); 9875 end if; 9876 9877 -- Type dependent processing 9878 9879 case Ekind (Parent_Type) is 9880 when Numeric_Kind => 9881 Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type); 9882 9883 when Array_Kind => 9884 Build_Derived_Array_Type (N, Parent_Type, Derived_Type); 9885 9886 when Class_Wide_Kind 9887 | E_Record_Subtype 9888 | E_Record_Type 9889 => 9890 Build_Derived_Record_Type 9891 (N, Parent_Type, Derived_Type, Derive_Subps); 9892 return; 9893 9894 when Enumeration_Kind => 9895 Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type); 9896 9897 when Access_Kind => 9898 Build_Derived_Access_Type (N, Parent_Type, Derived_Type); 9899 9900 when Incomplete_Or_Private_Kind => 9901 Build_Derived_Private_Type 9902 (N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps); 9903 9904 -- For discriminated types, the derivation includes deriving 9905 -- primitive operations. For others it is done below. 9906 9907 if Is_Tagged_Type (Parent_Type) 9908 or else Has_Discriminants (Parent_Type) 9909 or else (Present (Full_View (Parent_Type)) 9910 and then Has_Discriminants (Full_View (Parent_Type))) 9911 then 9912 return; 9913 end if; 9914 9915 when Concurrent_Kind => 9916 Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type); 9917 9918 when others => 9919 raise Program_Error; 9920 end case; 9921 9922 -- Nothing more to do if some error occurred 9923 9924 if Etype (Derived_Type) = Any_Type then 9925 return; 9926 end if; 9927 9928 -- Set delayed freeze and then derive subprograms, we need to do this 9929 -- in this order so that derived subprograms inherit the derived freeze 9930 -- if necessary. 9931 9932 Set_Has_Delayed_Freeze (Derived_Type); 9933 9934 if Derive_Subps then 9935 Derive_Subprograms (Parent_Type, Derived_Type); 9936 end if; 9937 9938 Set_Has_Primitive_Operations 9939 (Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type)); 9940 end Build_Derived_Type; 9941 9942 ----------------------- 9943 -- Build_Discriminal -- 9944 ----------------------- 9945 9946 procedure Build_Discriminal (Discrim : Entity_Id) is 9947 D_Minal : Entity_Id; 9948 CR_Disc : Entity_Id; 9949 9950 begin 9951 -- A discriminal has the same name as the discriminant 9952 9953 D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); 9954 9955 Set_Ekind (D_Minal, E_In_Parameter); 9956 Set_Mechanism (D_Minal, Default_Mechanism); 9957 Set_Etype (D_Minal, Etype (Discrim)); 9958 Set_Scope (D_Minal, Current_Scope); 9959 Set_Parent (D_Minal, Parent (Discrim)); 9960 9961 Set_Discriminal (Discrim, D_Minal); 9962 Set_Discriminal_Link (D_Minal, Discrim); 9963 9964 -- For task types, build at once the discriminants of the corresponding 9965 -- record, which are needed if discriminants are used in entry defaults 9966 -- and in family bounds. 9967 9968 if Is_Concurrent_Type (Current_Scope) 9969 or else 9970 Is_Limited_Type (Current_Scope) 9971 then 9972 CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); 9973 9974 Set_Ekind (CR_Disc, E_In_Parameter); 9975 Set_Mechanism (CR_Disc, Default_Mechanism); 9976 Set_Etype (CR_Disc, Etype (Discrim)); 9977 Set_Scope (CR_Disc, Current_Scope); 9978 Set_Discriminal_Link (CR_Disc, Discrim); 9979 Set_CR_Discriminant (Discrim, CR_Disc); 9980 end if; 9981 end Build_Discriminal; 9982 9983 ------------------------------------ 9984 -- Build_Discriminant_Constraints -- 9985 ------------------------------------ 9986 9987 function Build_Discriminant_Constraints 9988 (T : Entity_Id; 9989 Def : Node_Id; 9990 Derived_Def : Boolean := False) return Elist_Id 9991 is 9992 C : constant Node_Id := Constraint (Def); 9993 Nb_Discr : constant Nat := Number_Discriminants (T); 9994 9995 Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty); 9996 -- Saves the expression corresponding to a given discriminant in T 9997 9998 function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat; 9999 -- Return the Position number within array Discr_Expr of a discriminant 10000 -- D within the discriminant list of the discriminated type T. 10001 10002 procedure Process_Discriminant_Expression 10003 (Expr : Node_Id; 10004 D : Entity_Id); 10005 -- If this is a discriminant constraint on a partial view, do not 10006 -- generate an overflow check on the discriminant expression. The check 10007 -- will be generated when constraining the full view. Otherwise the 10008 -- backend creates duplicate symbols for the temporaries corresponding 10009 -- to the expressions to be checked, causing spurious assembler errors. 10010 10011 ------------------ 10012 -- Pos_Of_Discr -- 10013 ------------------ 10014 10015 function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is 10016 Disc : Entity_Id; 10017 10018 begin 10019 Disc := First_Discriminant (T); 10020 for J in Discr_Expr'Range loop 10021 if Disc = D then 10022 return J; 10023 end if; 10024 10025 Next_Discriminant (Disc); 10026 end loop; 10027 10028 -- Note: Since this function is called on discriminants that are 10029 -- known to belong to the discriminated type, falling through the 10030 -- loop with no match signals an internal compiler error. 10031 10032 raise Program_Error; 10033 end Pos_Of_Discr; 10034 10035 ------------------------------------- 10036 -- Process_Discriminant_Expression -- 10037 ------------------------------------- 10038 10039 procedure Process_Discriminant_Expression 10040 (Expr : Node_Id; 10041 D : Entity_Id) 10042 is 10043 BDT : constant Entity_Id := Base_Type (Etype (D)); 10044 10045 begin 10046 -- If this is a discriminant constraint on a partial view, do 10047 -- not generate an overflow on the discriminant expression. The 10048 -- check will be generated when constraining the full view. 10049 10050 if Is_Private_Type (T) 10051 and then Present (Full_View (T)) 10052 then 10053 Analyze_And_Resolve (Expr, BDT, Suppress => Overflow_Check); 10054 else 10055 Analyze_And_Resolve (Expr, BDT); 10056 end if; 10057 end Process_Discriminant_Expression; 10058 10059 -- Declarations local to Build_Discriminant_Constraints 10060 10061 Discr : Entity_Id; 10062 E : Entity_Id; 10063 Elist : constant Elist_Id := New_Elmt_List; 10064 10065 Constr : Node_Id; 10066 Expr : Node_Id; 10067 Id : Node_Id; 10068 Position : Nat; 10069 Found : Boolean; 10070 10071 Discrim_Present : Boolean := False; 10072 10073 -- Start of processing for Build_Discriminant_Constraints 10074 10075 begin 10076 -- The following loop will process positional associations only. 10077 -- For a positional association, the (single) discriminant is 10078 -- implicitly specified by position, in textual order (RM 3.7.2). 10079 10080 Discr := First_Discriminant (T); 10081 Constr := First (Constraints (C)); 10082 for D in Discr_Expr'Range loop 10083 exit when Nkind (Constr) = N_Discriminant_Association; 10084 10085 if No (Constr) then 10086 Error_Msg_N ("too few discriminants given in constraint", C); 10087 return New_Elmt_List; 10088 10089 elsif Nkind (Constr) = N_Range 10090 or else (Nkind (Constr) = N_Attribute_Reference 10091 and then Attribute_Name (Constr) = Name_Range) 10092 then 10093 Error_Msg_N 10094 ("a range is not a valid discriminant constraint", Constr); 10095 Discr_Expr (D) := Error; 10096 10097 elsif Nkind (Constr) = N_Subtype_Indication then 10098 Error_Msg_N 10099 ("a subtype indication is not a valid discriminant constraint", 10100 Constr); 10101 Discr_Expr (D) := Error; 10102 10103 else 10104 Process_Discriminant_Expression (Constr, Discr); 10105 Discr_Expr (D) := Constr; 10106 end if; 10107 10108 Next_Discriminant (Discr); 10109 Next (Constr); 10110 end loop; 10111 10112 if No (Discr) and then Present (Constr) then 10113 Error_Msg_N ("too many discriminants given in constraint", Constr); 10114 return New_Elmt_List; 10115 end if; 10116 10117 -- Named associations can be given in any order, but if both positional 10118 -- and named associations are used in the same discriminant constraint, 10119 -- then positional associations must occur first, at their normal 10120 -- position. Hence once a named association is used, the rest of the 10121 -- discriminant constraint must use only named associations. 10122 10123 while Present (Constr) loop 10124 10125 -- Positional association forbidden after a named association 10126 10127 if Nkind (Constr) /= N_Discriminant_Association then 10128 Error_Msg_N ("positional association follows named one", Constr); 10129 return New_Elmt_List; 10130 10131 -- Otherwise it is a named association 10132 10133 else 10134 -- E records the type of the discriminants in the named 10135 -- association. All the discriminants specified in the same name 10136 -- association must have the same type. 10137 10138 E := Empty; 10139 10140 -- Search the list of discriminants in T to see if the simple name 10141 -- given in the constraint matches any of them. 10142 10143 Id := First (Selector_Names (Constr)); 10144 while Present (Id) loop 10145 Found := False; 10146 10147 -- If Original_Discriminant is present, we are processing a 10148 -- generic instantiation and this is an instance node. We need 10149 -- to find the name of the corresponding discriminant in the 10150 -- actual record type T and not the name of the discriminant in 10151 -- the generic formal. Example: 10152 10153 -- generic 10154 -- type G (D : int) is private; 10155 -- package P is 10156 -- subtype W is G (D => 1); 10157 -- end package; 10158 -- type Rec (X : int) is record ... end record; 10159 -- package Q is new P (G => Rec); 10160 10161 -- At the point of the instantiation, formal type G is Rec 10162 -- and therefore when reanalyzing "subtype W is G (D => 1);" 10163 -- which really looks like "subtype W is Rec (D => 1);" at 10164 -- the point of instantiation, we want to find the discriminant 10165 -- that corresponds to D in Rec, i.e. X. 10166 10167 if Present (Original_Discriminant (Id)) 10168 and then In_Instance 10169 then 10170 Discr := Find_Corresponding_Discriminant (Id, T); 10171 Found := True; 10172 10173 else 10174 Discr := First_Discriminant (T); 10175 while Present (Discr) loop 10176 if Chars (Discr) = Chars (Id) then 10177 Found := True; 10178 exit; 10179 end if; 10180 10181 Next_Discriminant (Discr); 10182 end loop; 10183 10184 if not Found then 10185 Error_Msg_N ("& does not match any discriminant", Id); 10186 return New_Elmt_List; 10187 10188 -- If the parent type is a generic formal, preserve the 10189 -- name of the discriminant for subsequent instances. 10190 -- see comment at the beginning of this if statement. 10191 10192 elsif Is_Generic_Type (Root_Type (T)) then 10193 Set_Original_Discriminant (Id, Discr); 10194 end if; 10195 end if; 10196 10197 Position := Pos_Of_Discr (T, Discr); 10198 10199 if Present (Discr_Expr (Position)) then 10200 Error_Msg_N ("duplicate constraint for discriminant&", Id); 10201 10202 else 10203 -- Each discriminant specified in the same named association 10204 -- must be associated with a separate copy of the 10205 -- corresponding expression. 10206 10207 if Present (Next (Id)) then 10208 Expr := New_Copy_Tree (Expression (Constr)); 10209 Set_Parent (Expr, Parent (Expression (Constr))); 10210 else 10211 Expr := Expression (Constr); 10212 end if; 10213 10214 Discr_Expr (Position) := Expr; 10215 Process_Discriminant_Expression (Expr, Discr); 10216 end if; 10217 10218 -- A discriminant association with more than one discriminant 10219 -- name is only allowed if the named discriminants are all of 10220 -- the same type (RM 3.7.1(8)). 10221 10222 if E = Empty then 10223 E := Base_Type (Etype (Discr)); 10224 10225 elsif Base_Type (Etype (Discr)) /= E then 10226 Error_Msg_N 10227 ("all discriminants in an association " & 10228 "must have the same type", Id); 10229 end if; 10230 10231 Next (Id); 10232 end loop; 10233 end if; 10234 10235 Next (Constr); 10236 end loop; 10237 10238 -- A discriminant constraint must provide exactly one value for each 10239 -- discriminant of the type (RM 3.7.1(8)). 10240 10241 for J in Discr_Expr'Range loop 10242 if No (Discr_Expr (J)) then 10243 Error_Msg_N ("too few discriminants given in constraint", C); 10244 return New_Elmt_List; 10245 end if; 10246 end loop; 10247 10248 -- Determine if there are discriminant expressions in the constraint 10249 10250 for J in Discr_Expr'Range loop 10251 if Denotes_Discriminant 10252 (Discr_Expr (J), Check_Concurrent => True) 10253 then 10254 Discrim_Present := True; 10255 end if; 10256 end loop; 10257 10258 -- Build an element list consisting of the expressions given in the 10259 -- discriminant constraint and apply the appropriate checks. The list 10260 -- is constructed after resolving any named discriminant associations 10261 -- and therefore the expressions appear in the textual order of the 10262 -- discriminants. 10263 10264 Discr := First_Discriminant (T); 10265 for J in Discr_Expr'Range loop 10266 if Discr_Expr (J) /= Error then 10267 Append_Elmt (Discr_Expr (J), Elist); 10268 10269 -- If any of the discriminant constraints is given by a 10270 -- discriminant and we are in a derived type declaration we 10271 -- have a discriminant renaming. Establish link between new 10272 -- and old discriminant. The new discriminant has an implicit 10273 -- dereference if the old one does. 10274 10275 if Denotes_Discriminant (Discr_Expr (J)) then 10276 if Derived_Def then 10277 declare 10278 New_Discr : constant Entity_Id := Entity (Discr_Expr (J)); 10279 10280 begin 10281 Set_Corresponding_Discriminant (New_Discr, Discr); 10282 Set_Has_Implicit_Dereference (New_Discr, 10283 Has_Implicit_Dereference (Discr)); 10284 end; 10285 end if; 10286 10287 -- Force the evaluation of non-discriminant expressions. 10288 -- If we have found a discriminant in the constraint 3.4(26) 10289 -- and 3.8(18) demand that no range checks are performed are 10290 -- after evaluation. If the constraint is for a component 10291 -- definition that has a per-object constraint, expressions are 10292 -- evaluated but not checked either. In all other cases perform 10293 -- a range check. 10294 10295 else 10296 if Discrim_Present then 10297 null; 10298 10299 elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration 10300 and then Has_Per_Object_Constraint 10301 (Defining_Identifier (Parent (Parent (Def)))) 10302 then 10303 null; 10304 10305 elsif Is_Access_Type (Etype (Discr)) then 10306 Apply_Constraint_Check (Discr_Expr (J), Etype (Discr)); 10307 10308 else 10309 Apply_Range_Check (Discr_Expr (J), Etype (Discr)); 10310 end if; 10311 10312 Force_Evaluation (Discr_Expr (J)); 10313 end if; 10314 10315 -- Check that the designated type of an access discriminant's 10316 -- expression is not a class-wide type unless the discriminant's 10317 -- designated type is also class-wide. 10318 10319 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type 10320 and then not Is_Class_Wide_Type 10321 (Designated_Type (Etype (Discr))) 10322 and then Etype (Discr_Expr (J)) /= Any_Type 10323 and then Is_Class_Wide_Type 10324 (Designated_Type (Etype (Discr_Expr (J)))) 10325 then 10326 Wrong_Type (Discr_Expr (J), Etype (Discr)); 10327 10328 elsif Is_Access_Type (Etype (Discr)) 10329 and then not Is_Access_Constant (Etype (Discr)) 10330 and then Is_Access_Type (Etype (Discr_Expr (J))) 10331 and then Is_Access_Constant (Etype (Discr_Expr (J))) 10332 then 10333 Error_Msg_NE 10334 ("constraint for discriminant& must be access to variable", 10335 Def, Discr); 10336 end if; 10337 end if; 10338 10339 Next_Discriminant (Discr); 10340 end loop; 10341 10342 return Elist; 10343 end Build_Discriminant_Constraints; 10344 10345 --------------------------------- 10346 -- Build_Discriminated_Subtype -- 10347 --------------------------------- 10348 10349 procedure Build_Discriminated_Subtype 10350 (T : Entity_Id; 10351 Def_Id : Entity_Id; 10352 Elist : Elist_Id; 10353 Related_Nod : Node_Id; 10354 For_Access : Boolean := False) 10355 is 10356 Has_Discrs : constant Boolean := Has_Discriminants (T); 10357 Constrained : constant Boolean := 10358 (Has_Discrs 10359 and then not Is_Empty_Elmt_List (Elist) 10360 and then not Is_Class_Wide_Type (T)) 10361 or else Is_Constrained (T); 10362 10363 begin 10364 if Ekind (T) = E_Record_Type then 10365 Set_Ekind (Def_Id, E_Record_Subtype); 10366 10367 -- Inherit preelaboration flag from base, for types for which it 10368 -- may have been set: records, private types, protected types. 10369 10370 Set_Known_To_Have_Preelab_Init 10371 (Def_Id, Known_To_Have_Preelab_Init (T)); 10372 10373 elsif Ekind (T) = E_Task_Type then 10374 Set_Ekind (Def_Id, E_Task_Subtype); 10375 10376 elsif Ekind (T) = E_Protected_Type then 10377 Set_Ekind (Def_Id, E_Protected_Subtype); 10378 Set_Known_To_Have_Preelab_Init 10379 (Def_Id, Known_To_Have_Preelab_Init (T)); 10380 10381 elsif Is_Private_Type (T) then 10382 Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); 10383 Set_Known_To_Have_Preelab_Init 10384 (Def_Id, Known_To_Have_Preelab_Init (T)); 10385 10386 -- Private subtypes may have private dependents 10387 10388 Set_Private_Dependents (Def_Id, New_Elmt_List); 10389 10390 elsif Is_Class_Wide_Type (T) then 10391 Set_Ekind (Def_Id, E_Class_Wide_Subtype); 10392 10393 else 10394 -- Incomplete type. Attach subtype to list of dependents, to be 10395 -- completed with full view of parent type, unless is it the 10396 -- designated subtype of a record component within an init_proc. 10397 -- This last case arises for a component of an access type whose 10398 -- designated type is incomplete (e.g. a Taft Amendment type). 10399 -- The designated subtype is within an inner scope, and needs no 10400 -- elaboration, because only the access type is needed in the 10401 -- initialization procedure. 10402 10403 if Ekind (T) = E_Incomplete_Type then 10404 Set_Ekind (Def_Id, E_Incomplete_Subtype); 10405 else 10406 Set_Ekind (Def_Id, Ekind (T)); 10407 end if; 10408 10409 if For_Access and then Within_Init_Proc then 10410 null; 10411 else 10412 Append_Elmt (Def_Id, Private_Dependents (T)); 10413 end if; 10414 end if; 10415 10416 Set_Etype (Def_Id, T); 10417 Init_Size_Align (Def_Id); 10418 Set_Has_Discriminants (Def_Id, Has_Discrs); 10419 Set_Is_Constrained (Def_Id, Constrained); 10420 10421 Set_First_Entity (Def_Id, First_Entity (T)); 10422 Set_Last_Entity (Def_Id, Last_Entity (T)); 10423 Set_Has_Implicit_Dereference 10424 (Def_Id, Has_Implicit_Dereference (T)); 10425 Set_Has_Pragma_Unreferenced_Objects 10426 (Def_Id, Has_Pragma_Unreferenced_Objects (T)); 10427 10428 -- If the subtype is the completion of a private declaration, there may 10429 -- have been representation clauses for the partial view, and they must 10430 -- be preserved. Build_Derived_Type chains the inherited clauses with 10431 -- the ones appearing on the extension. If this comes from a subtype 10432 -- declaration, all clauses are inherited. 10433 10434 if No (First_Rep_Item (Def_Id)) then 10435 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 10436 end if; 10437 10438 if Is_Tagged_Type (T) then 10439 Set_Is_Tagged_Type (Def_Id); 10440 Set_No_Tagged_Streams_Pragma (Def_Id, No_Tagged_Streams_Pragma (T)); 10441 Make_Class_Wide_Type (Def_Id); 10442 end if; 10443 10444 Set_Stored_Constraint (Def_Id, No_Elist); 10445 10446 if Has_Discrs then 10447 Set_Discriminant_Constraint (Def_Id, Elist); 10448 Set_Stored_Constraint_From_Discriminant_Constraint (Def_Id); 10449 end if; 10450 10451 if Is_Tagged_Type (T) then 10452 10453 -- Ada 2005 (AI-251): In case of concurrent types we inherit the 10454 -- concurrent record type (which has the list of primitive 10455 -- operations). 10456 10457 if Ada_Version >= Ada_2005 10458 and then Is_Concurrent_Type (T) 10459 then 10460 Set_Corresponding_Record_Type (Def_Id, 10461 Corresponding_Record_Type (T)); 10462 else 10463 Set_Direct_Primitive_Operations (Def_Id, 10464 Direct_Primitive_Operations (T)); 10465 end if; 10466 10467 Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T)); 10468 end if; 10469 10470 -- Subtypes introduced by component declarations do not need to be 10471 -- marked as delayed, and do not get freeze nodes, because the semantics 10472 -- verifies that the parents of the subtypes are frozen before the 10473 -- enclosing record is frozen. 10474 10475 if not Is_Type (Scope (Def_Id)) then 10476 Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); 10477 10478 if Is_Private_Type (T) 10479 and then Present (Full_View (T)) 10480 then 10481 Conditional_Delay (Def_Id, Full_View (T)); 10482 else 10483 Conditional_Delay (Def_Id, T); 10484 end if; 10485 end if; 10486 10487 if Is_Record_Type (T) then 10488 Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T)); 10489 10490 if Has_Discrs 10491 and then not Is_Empty_Elmt_List (Elist) 10492 and then not For_Access 10493 then 10494 Create_Constrained_Components (Def_Id, Related_Nod, T, Elist); 10495 10496 elsif not Is_Private_Type (T) then 10497 Set_Cloned_Subtype (Def_Id, T); 10498 end if; 10499 end if; 10500 end Build_Discriminated_Subtype; 10501 10502 --------------------------- 10503 -- Build_Itype_Reference -- 10504 --------------------------- 10505 10506 procedure Build_Itype_Reference 10507 (Ityp : Entity_Id; 10508 Nod : Node_Id) 10509 is 10510 IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod)); 10511 begin 10512 10513 -- Itype references are only created for use by the back-end 10514 10515 if Inside_A_Generic then 10516 return; 10517 else 10518 Set_Itype (IR, Ityp); 10519 10520 -- If Nod is a library unit entity, then Insert_After won't work, 10521 -- because Nod is not a member of any list. Therefore, we use 10522 -- Add_Global_Declaration in this case. This can happen if we have a 10523 -- build-in-place library function, child unit or not. 10524 10525 if (Nkind (Nod) in N_Entity and then Is_Compilation_Unit (Nod)) 10526 or else (Nkind (Nod) in 10527 N_Defining_Program_Unit_Name | N_Subprogram_Declaration 10528 and then Is_Compilation_Unit (Defining_Entity (Nod))) 10529 then 10530 Add_Global_Declaration (IR); 10531 else 10532 Insert_After (Nod, IR); 10533 end if; 10534 end if; 10535 end Build_Itype_Reference; 10536 10537 ------------------------ 10538 -- Build_Scalar_Bound -- 10539 ------------------------ 10540 10541 function Build_Scalar_Bound 10542 (Bound : Node_Id; 10543 Par_T : Entity_Id; 10544 Der_T : Entity_Id) return Node_Id 10545 is 10546 New_Bound : Entity_Id; 10547 10548 begin 10549 -- Note: not clear why this is needed, how can the original bound 10550 -- be unanalyzed at this point? and if it is, what business do we 10551 -- have messing around with it? and why is the base type of the 10552 -- parent type the right type for the resolution. It probably is 10553 -- not. It is OK for the new bound we are creating, but not for 10554 -- the old one??? Still if it never happens, no problem. 10555 10556 Analyze_And_Resolve (Bound, Base_Type (Par_T)); 10557 10558 if Nkind (Bound) in N_Integer_Literal | N_Real_Literal then 10559 New_Bound := New_Copy (Bound); 10560 Set_Etype (New_Bound, Der_T); 10561 Set_Analyzed (New_Bound); 10562 10563 elsif Is_Entity_Name (Bound) then 10564 New_Bound := OK_Convert_To (Der_T, New_Copy (Bound)); 10565 10566 -- The following is almost certainly wrong. What business do we have 10567 -- relocating a node (Bound) that is presumably still attached to 10568 -- the tree elsewhere??? 10569 10570 else 10571 New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound)); 10572 end if; 10573 10574 Set_Etype (New_Bound, Der_T); 10575 return New_Bound; 10576 end Build_Scalar_Bound; 10577 10578 ------------------------------- 10579 -- Check_Abstract_Overriding -- 10580 ------------------------------- 10581 10582 procedure Check_Abstract_Overriding (T : Entity_Id) is 10583 Alias_Subp : Entity_Id; 10584 Elmt : Elmt_Id; 10585 Op_List : Elist_Id; 10586 Subp : Entity_Id; 10587 Type_Def : Node_Id; 10588 10589 procedure Check_Pragma_Implemented (Subp : Entity_Id); 10590 -- Ada 2012 (AI05-0030): Subprogram Subp overrides an interface routine 10591 -- which has pragma Implemented already set. Check whether Subp's entity 10592 -- kind conforms to the implementation kind of the overridden routine. 10593 10594 procedure Check_Pragma_Implemented 10595 (Subp : Entity_Id; 10596 Iface_Subp : Entity_Id); 10597 -- Ada 2012 (AI05-0030): Subprogram Subp overrides interface routine 10598 -- Iface_Subp and both entities have pragma Implemented already set on 10599 -- them. Check whether the two implementation kinds are conforming. 10600 10601 procedure Inherit_Pragma_Implemented 10602 (Subp : Entity_Id; 10603 Iface_Subp : Entity_Id); 10604 -- Ada 2012 (AI05-0030): Interface primitive Subp overrides interface 10605 -- subprogram Iface_Subp which has been marked by pragma Implemented. 10606 -- Propagate the implementation kind of Iface_Subp to Subp. 10607 10608 ------------------------------ 10609 -- Check_Pragma_Implemented -- 10610 ------------------------------ 10611 10612 procedure Check_Pragma_Implemented (Subp : Entity_Id) is 10613 Iface_Alias : constant Entity_Id := Interface_Alias (Subp); 10614 Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias); 10615 Subp_Alias : constant Entity_Id := Alias (Subp); 10616 Contr_Typ : Entity_Id; 10617 Impl_Subp : Entity_Id; 10618 10619 begin 10620 -- Subp must have an alias since it is a hidden entity used to link 10621 -- an interface subprogram to its overriding counterpart. 10622 10623 pragma Assert (Present (Subp_Alias)); 10624 10625 -- Handle aliases to synchronized wrappers 10626 10627 Impl_Subp := Subp_Alias; 10628 10629 if Is_Primitive_Wrapper (Impl_Subp) then 10630 Impl_Subp := Wrapped_Entity (Impl_Subp); 10631 end if; 10632 10633 -- Extract the type of the controlling formal 10634 10635 Contr_Typ := Etype (First_Formal (Subp_Alias)); 10636 10637 if Is_Concurrent_Record_Type (Contr_Typ) then 10638 Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ); 10639 end if; 10640 10641 -- An interface subprogram whose implementation kind is By_Entry must 10642 -- be implemented by an entry. 10643 10644 if Impl_Kind = Name_By_Entry 10645 and then Ekind (Impl_Subp) /= E_Entry 10646 then 10647 Error_Msg_Node_2 := Iface_Alias; 10648 Error_Msg_NE 10649 ("type & must implement abstract subprogram & with an entry", 10650 Subp_Alias, Contr_Typ); 10651 10652 elsif Impl_Kind = Name_By_Protected_Procedure then 10653 10654 -- An interface subprogram whose implementation kind is By_ 10655 -- Protected_Procedure cannot be implemented by a primitive 10656 -- procedure of a task type. 10657 10658 if Ekind (Contr_Typ) /= E_Protected_Type then 10659 Error_Msg_Node_2 := Contr_Typ; 10660 Error_Msg_NE 10661 ("interface subprogram & cannot be implemented by a " 10662 & "primitive procedure of task type &", 10663 Subp_Alias, Iface_Alias); 10664 10665 -- An interface subprogram whose implementation kind is By_ 10666 -- Protected_Procedure must be implemented by a procedure. 10667 10668 elsif Ekind (Impl_Subp) /= E_Procedure then 10669 Error_Msg_Node_2 := Iface_Alias; 10670 Error_Msg_NE 10671 ("type & must implement abstract subprogram & with a " 10672 & "procedure", Subp_Alias, Contr_Typ); 10673 10674 elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented)) 10675 and then Implementation_Kind (Impl_Subp) /= Impl_Kind 10676 then 10677 Error_Msg_Name_1 := Impl_Kind; 10678 Error_Msg_N 10679 ("overriding operation& must have synchronization%", 10680 Subp_Alias); 10681 end if; 10682 10683 -- If primitive has Optional synchronization, overriding operation 10684 -- must match if it has an explicit synchronization. 10685 10686 elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented)) 10687 and then Implementation_Kind (Impl_Subp) /= Impl_Kind 10688 then 10689 Error_Msg_Name_1 := Impl_Kind; 10690 Error_Msg_N 10691 ("overriding operation& must have synchronization%", Subp_Alias); 10692 end if; 10693 end Check_Pragma_Implemented; 10694 10695 ------------------------------ 10696 -- Check_Pragma_Implemented -- 10697 ------------------------------ 10698 10699 procedure Check_Pragma_Implemented 10700 (Subp : Entity_Id; 10701 Iface_Subp : Entity_Id) 10702 is 10703 Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); 10704 Subp_Kind : constant Name_Id := Implementation_Kind (Subp); 10705 10706 begin 10707 -- Ada 2012 (AI05-0030): The implementation kinds of an overridden 10708 -- and overriding subprogram are different. In general this is an 10709 -- error except when the implementation kind of the overridden 10710 -- subprograms is By_Any or Optional. 10711 10712 if Iface_Kind /= Subp_Kind 10713 and then Iface_Kind /= Name_By_Any 10714 and then Iface_Kind /= Name_Optional 10715 then 10716 if Iface_Kind = Name_By_Entry then 10717 Error_Msg_N 10718 ("incompatible implementation kind, overridden subprogram " & 10719 "is marked By_Entry", Subp); 10720 else 10721 Error_Msg_N 10722 ("incompatible implementation kind, overridden subprogram " & 10723 "is marked By_Protected_Procedure", Subp); 10724 end if; 10725 end if; 10726 end Check_Pragma_Implemented; 10727 10728 -------------------------------- 10729 -- Inherit_Pragma_Implemented -- 10730 -------------------------------- 10731 10732 procedure Inherit_Pragma_Implemented 10733 (Subp : Entity_Id; 10734 Iface_Subp : Entity_Id) 10735 is 10736 Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); 10737 Loc : constant Source_Ptr := Sloc (Subp); 10738 Impl_Prag : Node_Id; 10739 10740 begin 10741 -- Since the implementation kind is stored as a representation item 10742 -- rather than a flag, create a pragma node. 10743 10744 Impl_Prag := 10745 Make_Pragma (Loc, 10746 Chars => Name_Implemented, 10747 Pragma_Argument_Associations => New_List ( 10748 Make_Pragma_Argument_Association (Loc, 10749 Expression => New_Occurrence_Of (Subp, Loc)), 10750 10751 Make_Pragma_Argument_Association (Loc, 10752 Expression => Make_Identifier (Loc, Iface_Kind)))); 10753 10754 -- The pragma doesn't need to be analyzed because it is internally 10755 -- built. It is safe to directly register it as a rep item since we 10756 -- are only interested in the characters of the implementation kind. 10757 10758 Record_Rep_Item (Subp, Impl_Prag); 10759 end Inherit_Pragma_Implemented; 10760 10761 -- Start of processing for Check_Abstract_Overriding 10762 10763 begin 10764 Op_List := Primitive_Operations (T); 10765 10766 -- Loop to check primitive operations 10767 10768 Elmt := First_Elmt (Op_List); 10769 while Present (Elmt) loop 10770 Subp := Node (Elmt); 10771 Alias_Subp := Alias (Subp); 10772 10773 -- Inherited subprograms are identified by the fact that they do not 10774 -- come from source, and the associated source location is the 10775 -- location of the first subtype of the derived type. 10776 10777 -- Ada 2005 (AI-228): Apply the rules of RM-3.9.3(6/2) for 10778 -- subprograms that "require overriding". 10779 10780 -- Special exception, do not complain about failure to override the 10781 -- stream routines _Input and _Output, as well as the primitive 10782 -- operations used in dispatching selects since we always provide 10783 -- automatic overridings for these subprograms. 10784 10785 -- The partial view of T may have been a private extension, for 10786 -- which inherited functions dispatching on result are abstract. 10787 -- If the full view is a null extension, there is no need for 10788 -- overriding in Ada 2005, but wrappers need to be built for them 10789 -- (see exp_ch3, Build_Controlling_Function_Wrappers). 10790 10791 if Is_Null_Extension (T) 10792 and then Has_Controlling_Result (Subp) 10793 and then Ada_Version >= Ada_2005 10794 and then Present (Alias_Subp) 10795 and then not Comes_From_Source (Subp) 10796 and then not Is_Abstract_Subprogram (Alias_Subp) 10797 and then not Is_Access_Type (Etype (Subp)) 10798 then 10799 null; 10800 10801 -- Ada 2005 (AI-251): Internal entities of interfaces need no 10802 -- processing because this check is done with the aliased 10803 -- entity 10804 10805 elsif Present (Interface_Alias (Subp)) then 10806 null; 10807 10808 -- AI12-0042: Test for rule in 7.3.2(6.1/4), that requires overriding 10809 -- of a visible private primitive inherited from an ancestor with 10810 -- the aspect Type_Invariant'Class, unless the inherited primitive 10811 -- is abstract. 10812 10813 elsif not Is_Abstract_Subprogram (Subp) 10814 and then not Comes_From_Source (Subp) -- An inherited subprogram 10815 and then Requires_Overriding (Subp) 10816 and then Present (Alias_Subp) 10817 and then Has_Invariants (Etype (T)) 10818 and then Present (Get_Pragma (Etype (T), Pragma_Invariant)) 10819 and then Class_Present (Get_Pragma (Etype (T), Pragma_Invariant)) 10820 and then Is_Private_Primitive (Alias_Subp) 10821 then 10822 Error_Msg_NE 10823 ("inherited private primitive & must be overridden", T, Subp); 10824 Error_Msg_N 10825 ("\because ancestor type has 'Type_'Invariant''Class " & 10826 "(RM 7.3.2(6.1))", T); 10827 10828 elsif (Is_Abstract_Subprogram (Subp) 10829 or else Requires_Overriding (Subp) 10830 or else 10831 (Has_Controlling_Result (Subp) 10832 and then Present (Alias_Subp) 10833 and then not Comes_From_Source (Subp) 10834 and then Sloc (Subp) = Sloc (First_Subtype (T)))) 10835 and then not Is_TSS (Subp, TSS_Stream_Input) 10836 and then not Is_TSS (Subp, TSS_Stream_Output) 10837 and then not Is_Abstract_Type (T) 10838 and then not Is_Predefined_Interface_Primitive (Subp) 10839 10840 -- Ada 2005 (AI-251): Do not consider hidden entities associated 10841 -- with abstract interface types because the check will be done 10842 -- with the aliased entity (otherwise we generate a duplicated 10843 -- error message). 10844 10845 and then not Present (Interface_Alias (Subp)) 10846 then 10847 if Present (Alias_Subp) then 10848 10849 -- Only perform the check for a derived subprogram when the 10850 -- type has an explicit record extension. This avoids incorrect 10851 -- flagging of abstract subprograms for the case of a type 10852 -- without an extension that is derived from a formal type 10853 -- with a tagged actual (can occur within a private part). 10854 10855 -- Ada 2005 (AI-391): In the case of an inherited function with 10856 -- a controlling result of the type, the rule does not apply if 10857 -- the type is a null extension (unless the parent function 10858 -- itself is abstract, in which case the function must still be 10859 -- be overridden). The expander will generate an overriding 10860 -- wrapper function calling the parent subprogram (see 10861 -- Exp_Ch3.Make_Controlling_Wrapper_Functions). 10862 10863 Type_Def := Type_Definition (Parent (T)); 10864 10865 if Nkind (Type_Def) = N_Derived_Type_Definition 10866 and then Present (Record_Extension_Part (Type_Def)) 10867 and then 10868 (Ada_Version < Ada_2005 10869 or else not Is_Null_Extension (T) 10870 or else Ekind (Subp) = E_Procedure 10871 or else not Has_Controlling_Result (Subp) 10872 or else Is_Abstract_Subprogram (Alias_Subp) 10873 or else Requires_Overriding (Subp) 10874 or else Is_Access_Type (Etype (Subp))) 10875 then 10876 -- Avoid reporting error in case of abstract predefined 10877 -- primitive inherited from interface type because the 10878 -- body of internally generated predefined primitives 10879 -- of tagged types are generated later by Freeze_Type 10880 10881 if Is_Interface (Root_Type (T)) 10882 and then Is_Abstract_Subprogram (Subp) 10883 and then Is_Predefined_Dispatching_Operation (Subp) 10884 and then not Comes_From_Source (Ultimate_Alias (Subp)) 10885 then 10886 null; 10887 10888 -- A null extension is not obliged to override an inherited 10889 -- procedure subject to pragma Extensions_Visible with value 10890 -- False and at least one controlling OUT parameter 10891 -- (SPARK RM 6.1.7(6)). 10892 10893 elsif Is_Null_Extension (T) 10894 and then Is_EVF_Procedure (Subp) 10895 then 10896 null; 10897 10898 -- Subprogram renamings cannot be overridden 10899 10900 elsif Comes_From_Source (Subp) 10901 and then Present (Alias (Subp)) 10902 then 10903 null; 10904 10905 else 10906 Error_Msg_NE 10907 ("type must be declared abstract or & overridden", 10908 T, Subp); 10909 10910 -- Traverse the whole chain of aliased subprograms to 10911 -- complete the error notification. This is especially 10912 -- useful for traceability of the chain of entities when 10913 -- the subprogram corresponds with an interface 10914 -- subprogram (which may be defined in another package). 10915 10916 if Present (Alias_Subp) then 10917 declare 10918 E : Entity_Id; 10919 10920 begin 10921 E := Subp; 10922 while Present (Alias (E)) loop 10923 10924 -- Avoid reporting redundant errors on entities 10925 -- inherited from interfaces 10926 10927 if Sloc (E) /= Sloc (T) then 10928 Error_Msg_Sloc := Sloc (E); 10929 Error_Msg_NE 10930 ("\& has been inherited #", T, Subp); 10931 end if; 10932 10933 E := Alias (E); 10934 end loop; 10935 10936 Error_Msg_Sloc := Sloc (E); 10937 10938 -- AI05-0068: report if there is an overriding 10939 -- non-abstract subprogram that is invisible. 10940 10941 if Is_Hidden (E) 10942 and then not Is_Abstract_Subprogram (E) 10943 then 10944 Error_Msg_NE 10945 ("\& subprogram# is not visible", 10946 T, Subp); 10947 10948 -- Clarify the case where a non-null extension must 10949 -- override inherited procedure subject to pragma 10950 -- Extensions_Visible with value False and at least 10951 -- one controlling OUT param. 10952 10953 elsif Is_EVF_Procedure (E) then 10954 Error_Msg_NE 10955 ("\& # is subject to Extensions_Visible False", 10956 T, Subp); 10957 10958 else 10959 Error_Msg_NE 10960 ("\& has been inherited from subprogram #", 10961 T, Subp); 10962 end if; 10963 end; 10964 end if; 10965 end if; 10966 10967 -- Ada 2005 (AI-345): Protected or task type implementing 10968 -- abstract interfaces. 10969 10970 elsif Is_Concurrent_Record_Type (T) 10971 and then Present (Interfaces (T)) 10972 then 10973 -- There is no need to check here RM 9.4(11.9/3) since we 10974 -- are processing the corresponding record type and the 10975 -- mode of the overriding subprograms was verified by 10976 -- Check_Conformance when the corresponding concurrent 10977 -- type declaration was analyzed. 10978 10979 Error_Msg_NE 10980 ("interface subprogram & must be overridden", T, Subp); 10981 10982 -- Examine primitive operations of synchronized type to find 10983 -- homonyms that have the wrong profile. 10984 10985 declare 10986 Prim : Entity_Id; 10987 10988 begin 10989 Prim := First_Entity (Corresponding_Concurrent_Type (T)); 10990 while Present (Prim) loop 10991 if Chars (Prim) = Chars (Subp) then 10992 Error_Msg_NE 10993 ("profile is not type conformant with prefixed " 10994 & "view profile of inherited operation&", 10995 Prim, Subp); 10996 end if; 10997 10998 Next_Entity (Prim); 10999 end loop; 11000 end; 11001 end if; 11002 11003 else 11004 Error_Msg_Node_2 := T; 11005 Error_Msg_N 11006 ("abstract subprogram& not allowed for type&", Subp); 11007 11008 -- Also post unconditional warning on the type (unconditional 11009 -- so that if there are more than one of these cases, we get 11010 -- them all, and not just the first one). 11011 11012 Error_Msg_Node_2 := Subp; 11013 Error_Msg_N ("nonabstract type& has abstract subprogram&!", T); 11014 end if; 11015 11016 -- A subprogram subject to pragma Extensions_Visible with value 11017 -- "True" cannot override a subprogram subject to the same pragma 11018 -- with value "False" (SPARK RM 6.1.7(5)). 11019 11020 elsif Extensions_Visible_Status (Subp) = Extensions_Visible_True 11021 and then Present (Overridden_Operation (Subp)) 11022 and then Extensions_Visible_Status (Overridden_Operation (Subp)) = 11023 Extensions_Visible_False 11024 then 11025 Error_Msg_Sloc := Sloc (Overridden_Operation (Subp)); 11026 Error_Msg_N 11027 ("subprogram & with Extensions_Visible True cannot override " 11028 & "subprogram # with Extensions_Visible False", Subp); 11029 end if; 11030 11031 -- Ada 2012 (AI05-0030): Perform checks related to pragma Implemented 11032 11033 -- Subp is an expander-generated procedure which maps an interface 11034 -- alias to a protected wrapper. The interface alias is flagged by 11035 -- pragma Implemented. Ensure that Subp is a procedure when the 11036 -- implementation kind is By_Protected_Procedure or an entry when 11037 -- By_Entry. 11038 11039 if Ada_Version >= Ada_2012 11040 and then Is_Hidden (Subp) 11041 and then Present (Interface_Alias (Subp)) 11042 and then Has_Rep_Pragma (Interface_Alias (Subp), Name_Implemented) 11043 then 11044 Check_Pragma_Implemented (Subp); 11045 end if; 11046 11047 -- Subp is an interface primitive which overrides another interface 11048 -- primitive marked with pragma Implemented. 11049 11050 if Ada_Version >= Ada_2012 11051 and then Present (Overridden_Operation (Subp)) 11052 and then Has_Rep_Pragma 11053 (Overridden_Operation (Subp), Name_Implemented) 11054 then 11055 -- If the overriding routine is also marked by Implemented, check 11056 -- that the two implementation kinds are conforming. 11057 11058 if Has_Rep_Pragma (Subp, Name_Implemented) then 11059 Check_Pragma_Implemented 11060 (Subp => Subp, 11061 Iface_Subp => Overridden_Operation (Subp)); 11062 11063 -- Otherwise the overriding routine inherits the implementation 11064 -- kind from the overridden subprogram. 11065 11066 else 11067 Inherit_Pragma_Implemented 11068 (Subp => Subp, 11069 Iface_Subp => Overridden_Operation (Subp)); 11070 end if; 11071 end if; 11072 11073 -- Ada 2005 (AI95-0414) and Ada 2020 (AI12-0269): Diagnose failure to 11074 -- match No_Return in parent, but do it unconditionally in Ada 95 too 11075 -- for procedures, since this is our pragma. 11076 11077 if Present (Overridden_Operation (Subp)) 11078 and then No_Return (Overridden_Operation (Subp)) 11079 and then not No_Return (Subp) 11080 then 11081 Error_Msg_N ("overriding subprogram & must be No_Return", Subp); 11082 Error_Msg_N 11083 ("\since overridden subprogram is No_Return (RM 6.5.1(6/2))", 11084 Subp); 11085 end if; 11086 11087 -- If the operation is a wrapper for a synchronized primitive, it 11088 -- may be called indirectly through a dispatching select. We assume 11089 -- that it will be referenced elsewhere indirectly, and suppress 11090 -- warnings about an unused entity. 11091 11092 if Is_Primitive_Wrapper (Subp) 11093 and then Present (Wrapped_Entity (Subp)) 11094 then 11095 Set_Referenced (Wrapped_Entity (Subp)); 11096 end if; 11097 11098 Next_Elmt (Elmt); 11099 end loop; 11100 end Check_Abstract_Overriding; 11101 11102 ------------------------------------------------ 11103 -- Check_Access_Discriminant_Requires_Limited -- 11104 ------------------------------------------------ 11105 11106 procedure Check_Access_Discriminant_Requires_Limited 11107 (D : Node_Id; 11108 Loc : Node_Id) 11109 is 11110 begin 11111 -- A discriminant_specification for an access discriminant shall appear 11112 -- only in the declaration for a task or protected type, or for a type 11113 -- with the reserved word 'limited' in its definition or in one of its 11114 -- ancestors (RM 3.7(10)). 11115 11116 -- AI-0063: The proper condition is that type must be immutably limited, 11117 -- or else be a partial view. 11118 11119 if Nkind (Discriminant_Type (D)) = N_Access_Definition then 11120 if Is_Limited_View (Current_Scope) 11121 or else 11122 (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration 11123 and then Limited_Present (Parent (Current_Scope))) 11124 then 11125 null; 11126 11127 else 11128 Error_Msg_N 11129 ("access discriminants allowed only for limited types", Loc); 11130 end if; 11131 end if; 11132 end Check_Access_Discriminant_Requires_Limited; 11133 11134 ----------------------------------- 11135 -- Check_Aliased_Component_Types -- 11136 ----------------------------------- 11137 11138 procedure Check_Aliased_Component_Types (T : Entity_Id) is 11139 C : Entity_Id; 11140 11141 begin 11142 -- ??? Also need to check components of record extensions, but not 11143 -- components of protected types (which are always limited). 11144 11145 -- Ada 2005: AI-363 relaxes this rule, to allow heap objects of such 11146 -- types to be unconstrained. This is safe because it is illegal to 11147 -- create access subtypes to such types with explicit discriminant 11148 -- constraints. 11149 11150 if not Is_Limited_Type (T) then 11151 if Ekind (T) = E_Record_Type then 11152 C := First_Component (T); 11153 while Present (C) loop 11154 if Is_Aliased (C) 11155 and then Has_Discriminants (Etype (C)) 11156 and then not Is_Constrained (Etype (C)) 11157 and then not In_Instance_Body 11158 and then Ada_Version < Ada_2005 11159 then 11160 Error_Msg_N 11161 ("aliased component must be constrained (RM 3.6(11))", 11162 C); 11163 end if; 11164 11165 Next_Component (C); 11166 end loop; 11167 11168 elsif Ekind (T) = E_Array_Type then 11169 if Has_Aliased_Components (T) 11170 and then Has_Discriminants (Component_Type (T)) 11171 and then not Is_Constrained (Component_Type (T)) 11172 and then not In_Instance_Body 11173 and then Ada_Version < Ada_2005 11174 then 11175 Error_Msg_N 11176 ("aliased component type must be constrained (RM 3.6(11))", 11177 T); 11178 end if; 11179 end if; 11180 end if; 11181 end Check_Aliased_Component_Types; 11182 11183 --------------------------------------- 11184 -- Check_Anonymous_Access_Components -- 11185 --------------------------------------- 11186 11187 procedure Check_Anonymous_Access_Components 11188 (Typ_Decl : Node_Id; 11189 Typ : Entity_Id; 11190 Prev : Entity_Id; 11191 Comp_List : Node_Id) 11192 is 11193 Loc : constant Source_Ptr := Sloc (Typ_Decl); 11194 Anon_Access : Entity_Id; 11195 Acc_Def : Node_Id; 11196 Comp : Node_Id; 11197 Comp_Def : Node_Id; 11198 Decl : Node_Id; 11199 Type_Def : Node_Id; 11200 11201 procedure Build_Incomplete_Type_Declaration; 11202 -- If the record type contains components that include an access to the 11203 -- current record, then create an incomplete type declaration for the 11204 -- record, to be used as the designated type of the anonymous access. 11205 -- This is done only once, and only if there is no previous partial 11206 -- view of the type. 11207 11208 function Designates_T (Subt : Node_Id) return Boolean; 11209 -- Check whether a node designates the enclosing record type, or 'Class 11210 -- of that type 11211 11212 function Mentions_T (Acc_Def : Node_Id) return Boolean; 11213 -- Check whether an access definition includes a reference to 11214 -- the enclosing record type. The reference can be a subtype mark 11215 -- in the access definition itself, a 'Class attribute reference, or 11216 -- recursively a reference appearing in a parameter specification 11217 -- or result definition of an access_to_subprogram definition. 11218 11219 -------------------------------------- 11220 -- Build_Incomplete_Type_Declaration -- 11221 -------------------------------------- 11222 11223 procedure Build_Incomplete_Type_Declaration is 11224 Decl : Node_Id; 11225 Inc_T : Entity_Id; 11226 H : Entity_Id; 11227 11228 -- Is_Tagged indicates whether the type is tagged. It is tagged if 11229 -- it's "is new ... with record" or else "is tagged record ...". 11230 11231 Is_Tagged : constant Boolean := 11232 (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition 11233 and then 11234 Present (Record_Extension_Part (Type_Definition (Typ_Decl)))) 11235 or else 11236 (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition 11237 and then Tagged_Present (Type_Definition (Typ_Decl))); 11238 11239 begin 11240 -- If there is a previous partial view, no need to create a new one 11241 -- If the partial view, given by Prev, is incomplete, If Prev is 11242 -- a private declaration, full declaration is flagged accordingly. 11243 11244 if Prev /= Typ then 11245 if Is_Tagged then 11246 Make_Class_Wide_Type (Prev); 11247 Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); 11248 Set_Etype (Class_Wide_Type (Typ), Typ); 11249 end if; 11250 11251 return; 11252 11253 elsif Has_Private_Declaration (Typ) then 11254 11255 -- If we refer to T'Class inside T, and T is the completion of a 11256 -- private type, then make sure the class-wide type exists. 11257 11258 if Is_Tagged then 11259 Make_Class_Wide_Type (Typ); 11260 end if; 11261 11262 return; 11263 11264 -- If there was a previous anonymous access type, the incomplete 11265 -- type declaration will have been created already. 11266 11267 elsif Present (Current_Entity (Typ)) 11268 and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type 11269 and then Full_View (Current_Entity (Typ)) = Typ 11270 then 11271 if Is_Tagged 11272 and then Comes_From_Source (Current_Entity (Typ)) 11273 and then not Is_Tagged_Type (Current_Entity (Typ)) 11274 then 11275 Make_Class_Wide_Type (Typ); 11276 Error_Msg_N 11277 ("incomplete view of tagged type should be declared tagged??", 11278 Parent (Current_Entity (Typ))); 11279 end if; 11280 return; 11281 11282 else 11283 Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); 11284 Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); 11285 11286 -- Type has already been inserted into the current scope. Remove 11287 -- it, and add incomplete declaration for type, so that subsequent 11288 -- anonymous access types can use it. The entity is unchained from 11289 -- the homonym list and from immediate visibility. After analysis, 11290 -- the entity in the incomplete declaration becomes immediately 11291 -- visible in the record declaration that follows. 11292 11293 H := Current_Entity (Typ); 11294 11295 if H = Typ then 11296 Set_Name_Entity_Id (Chars (Typ), Homonym (Typ)); 11297 else 11298 while Present (H) 11299 and then Homonym (H) /= Typ 11300 loop 11301 H := Homonym (Typ); 11302 end loop; 11303 11304 Set_Homonym (H, Homonym (Typ)); 11305 end if; 11306 11307 Insert_Before (Typ_Decl, Decl); 11308 Analyze (Decl); 11309 Set_Full_View (Inc_T, Typ); 11310 11311 if Is_Tagged then 11312 11313 -- Create a common class-wide type for both views, and set the 11314 -- Etype of the class-wide type to the full view. 11315 11316 Make_Class_Wide_Type (Inc_T); 11317 Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); 11318 Set_Etype (Class_Wide_Type (Typ), Typ); 11319 end if; 11320 end if; 11321 end Build_Incomplete_Type_Declaration; 11322 11323 ------------------ 11324 -- Designates_T -- 11325 ------------------ 11326 11327 function Designates_T (Subt : Node_Id) return Boolean is 11328 Type_Id : constant Name_Id := Chars (Typ); 11329 11330 function Names_T (Nam : Node_Id) return Boolean; 11331 -- The record type has not been introduced in the current scope 11332 -- yet, so we must examine the name of the type itself, either 11333 -- an identifier T, or an expanded name of the form P.T, where 11334 -- P denotes the current scope. 11335 11336 ------------- 11337 -- Names_T -- 11338 ------------- 11339 11340 function Names_T (Nam : Node_Id) return Boolean is 11341 begin 11342 if Nkind (Nam) = N_Identifier then 11343 return Chars (Nam) = Type_Id; 11344 11345 elsif Nkind (Nam) = N_Selected_Component then 11346 if Chars (Selector_Name (Nam)) = Type_Id then 11347 if Nkind (Prefix (Nam)) = N_Identifier then 11348 return Chars (Prefix (Nam)) = Chars (Current_Scope); 11349 11350 elsif Nkind (Prefix (Nam)) = N_Selected_Component then 11351 return Chars (Selector_Name (Prefix (Nam))) = 11352 Chars (Current_Scope); 11353 else 11354 return False; 11355 end if; 11356 11357 else 11358 return False; 11359 end if; 11360 11361 else 11362 return False; 11363 end if; 11364 end Names_T; 11365 11366 -- Start of processing for Designates_T 11367 11368 begin 11369 if Nkind (Subt) = N_Identifier then 11370 return Chars (Subt) = Type_Id; 11371 11372 -- Reference can be through an expanded name which has not been 11373 -- analyzed yet, and which designates enclosing scopes. 11374 11375 elsif Nkind (Subt) = N_Selected_Component then 11376 if Names_T (Subt) then 11377 return True; 11378 11379 -- Otherwise it must denote an entity that is already visible. 11380 -- The access definition may name a subtype of the enclosing 11381 -- type, if there is a previous incomplete declaration for it. 11382 11383 else 11384 Find_Selected_Component (Subt); 11385 return 11386 Is_Entity_Name (Subt) 11387 and then Scope (Entity (Subt)) = Current_Scope 11388 and then 11389 (Chars (Base_Type (Entity (Subt))) = Type_Id 11390 or else 11391 (Is_Class_Wide_Type (Entity (Subt)) 11392 and then 11393 Chars (Etype (Base_Type (Entity (Subt)))) = 11394 Type_Id)); 11395 end if; 11396 11397 -- A reference to the current type may appear as the prefix of 11398 -- a 'Class attribute. 11399 11400 elsif Nkind (Subt) = N_Attribute_Reference 11401 and then Attribute_Name (Subt) = Name_Class 11402 then 11403 return Names_T (Prefix (Subt)); 11404 11405 else 11406 return False; 11407 end if; 11408 end Designates_T; 11409 11410 ---------------- 11411 -- Mentions_T -- 11412 ---------------- 11413 11414 function Mentions_T (Acc_Def : Node_Id) return Boolean is 11415 Param_Spec : Node_Id; 11416 11417 Acc_Subprg : constant Node_Id := 11418 Access_To_Subprogram_Definition (Acc_Def); 11419 11420 begin 11421 if No (Acc_Subprg) then 11422 return Designates_T (Subtype_Mark (Acc_Def)); 11423 end if; 11424 11425 -- Component is an access_to_subprogram: examine its formals, 11426 -- and result definition in the case of an access_to_function. 11427 11428 Param_Spec := First (Parameter_Specifications (Acc_Subprg)); 11429 while Present (Param_Spec) loop 11430 if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition 11431 and then Mentions_T (Parameter_Type (Param_Spec)) 11432 then 11433 return True; 11434 11435 elsif Designates_T (Parameter_Type (Param_Spec)) then 11436 return True; 11437 end if; 11438 11439 Next (Param_Spec); 11440 end loop; 11441 11442 if Nkind (Acc_Subprg) = N_Access_Function_Definition then 11443 if Nkind (Result_Definition (Acc_Subprg)) = 11444 N_Access_Definition 11445 then 11446 return Mentions_T (Result_Definition (Acc_Subprg)); 11447 else 11448 return Designates_T (Result_Definition (Acc_Subprg)); 11449 end if; 11450 end if; 11451 11452 return False; 11453 end Mentions_T; 11454 11455 -- Start of processing for Check_Anonymous_Access_Components 11456 11457 begin 11458 if No (Comp_List) then 11459 return; 11460 end if; 11461 11462 Comp := First (Component_Items (Comp_List)); 11463 while Present (Comp) loop 11464 if Nkind (Comp) = N_Component_Declaration 11465 and then Present 11466 (Access_Definition (Component_Definition (Comp))) 11467 and then 11468 Mentions_T (Access_Definition (Component_Definition (Comp))) 11469 then 11470 Comp_Def := Component_Definition (Comp); 11471 Acc_Def := 11472 Access_To_Subprogram_Definition (Access_Definition (Comp_Def)); 11473 11474 Build_Incomplete_Type_Declaration; 11475 Anon_Access := Make_Temporary (Loc, 'S'); 11476 11477 -- Create a declaration for the anonymous access type: either 11478 -- an access_to_object or an access_to_subprogram. 11479 11480 if Present (Acc_Def) then 11481 if Nkind (Acc_Def) = N_Access_Function_Definition then 11482 Type_Def := 11483 Make_Access_Function_Definition (Loc, 11484 Parameter_Specifications => 11485 Parameter_Specifications (Acc_Def), 11486 Result_Definition => Result_Definition (Acc_Def)); 11487 else 11488 Type_Def := 11489 Make_Access_Procedure_Definition (Loc, 11490 Parameter_Specifications => 11491 Parameter_Specifications (Acc_Def)); 11492 end if; 11493 11494 else 11495 Type_Def := 11496 Make_Access_To_Object_Definition (Loc, 11497 Subtype_Indication => 11498 Relocate_Node 11499 (Subtype_Mark (Access_Definition (Comp_Def)))); 11500 11501 Set_Constant_Present 11502 (Type_Def, Constant_Present (Access_Definition (Comp_Def))); 11503 Set_All_Present 11504 (Type_Def, All_Present (Access_Definition (Comp_Def))); 11505 end if; 11506 11507 Set_Null_Exclusion_Present 11508 (Type_Def, 11509 Null_Exclusion_Present (Access_Definition (Comp_Def))); 11510 11511 Decl := 11512 Make_Full_Type_Declaration (Loc, 11513 Defining_Identifier => Anon_Access, 11514 Type_Definition => Type_Def); 11515 11516 Insert_Before (Typ_Decl, Decl); 11517 Analyze (Decl); 11518 11519 -- If an access to subprogram, create the extra formals 11520 11521 if Present (Acc_Def) then 11522 Create_Extra_Formals (Designated_Type (Anon_Access)); 11523 end if; 11524 11525 Rewrite (Comp_Def, 11526 Make_Component_Definition (Loc, 11527 Subtype_Indication => 11528 New_Occurrence_Of (Anon_Access, Loc))); 11529 11530 if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then 11531 Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); 11532 else 11533 Set_Ekind (Anon_Access, E_Anonymous_Access_Type); 11534 end if; 11535 11536 Set_Is_Local_Anonymous_Access (Anon_Access); 11537 end if; 11538 11539 Next (Comp); 11540 end loop; 11541 11542 if Present (Variant_Part (Comp_List)) then 11543 declare 11544 V : Node_Id; 11545 begin 11546 V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 11547 while Present (V) loop 11548 Check_Anonymous_Access_Components 11549 (Typ_Decl, Typ, Prev, Component_List (V)); 11550 Next_Non_Pragma (V); 11551 end loop; 11552 end; 11553 end if; 11554 end Check_Anonymous_Access_Components; 11555 11556 ---------------------- 11557 -- Check_Completion -- 11558 ---------------------- 11559 11560 procedure Check_Completion (Body_Id : Node_Id := Empty) is 11561 E : Entity_Id; 11562 11563 procedure Post_Error; 11564 -- Post error message for lack of completion for entity E 11565 11566 ---------------- 11567 -- Post_Error -- 11568 ---------------- 11569 11570 procedure Post_Error is 11571 procedure Missing_Body; 11572 -- Output missing body message 11573 11574 ------------------ 11575 -- Missing_Body -- 11576 ------------------ 11577 11578 procedure Missing_Body is 11579 begin 11580 -- Spec is in same unit, so we can post on spec 11581 11582 if In_Same_Source_Unit (Body_Id, E) then 11583 Error_Msg_N ("missing body for &", E); 11584 11585 -- Spec is in a separate unit, so we have to post on the body 11586 11587 else 11588 Error_Msg_NE ("missing body for & declared#!", Body_Id, E); 11589 end if; 11590 end Missing_Body; 11591 11592 -- Start of processing for Post_Error 11593 11594 begin 11595 if not Comes_From_Source (E) then 11596 if Ekind (E) in E_Task_Type | E_Protected_Type then 11597 11598 -- It may be an anonymous protected type created for a 11599 -- single variable. Post error on variable, if present. 11600 11601 declare 11602 Var : Entity_Id; 11603 11604 begin 11605 Var := First_Entity (Current_Scope); 11606 while Present (Var) loop 11607 exit when Etype (Var) = E 11608 and then Comes_From_Source (Var); 11609 11610 Next_Entity (Var); 11611 end loop; 11612 11613 if Present (Var) then 11614 E := Var; 11615 end if; 11616 end; 11617 end if; 11618 end if; 11619 11620 -- If a generated entity has no completion, then either previous 11621 -- semantic errors have disabled the expansion phase, or else we had 11622 -- missing subunits, or else we are compiling without expansion, 11623 -- or else something is very wrong. 11624 11625 if not Comes_From_Source (E) then 11626 pragma Assert 11627 (Serious_Errors_Detected > 0 11628 or else Configurable_Run_Time_Violations > 0 11629 or else Subunits_Missing 11630 or else not Expander_Active); 11631 return; 11632 11633 -- Here for source entity 11634 11635 else 11636 -- Here if no body to post the error message, so we post the error 11637 -- on the declaration that has no completion. This is not really 11638 -- the right place to post it, think about this later ??? 11639 11640 if No (Body_Id) then 11641 if Is_Type (E) then 11642 Error_Msg_NE 11643 ("missing full declaration for }", Parent (E), E); 11644 else 11645 Error_Msg_NE ("missing body for &", Parent (E), E); 11646 end if; 11647 11648 -- Package body has no completion for a declaration that appears 11649 -- in the corresponding spec. Post error on the body, with a 11650 -- reference to the non-completed declaration. 11651 11652 else 11653 Error_Msg_Sloc := Sloc (E); 11654 11655 if Is_Type (E) then 11656 Error_Msg_NE ("missing full declaration for }!", Body_Id, E); 11657 11658 elsif Is_Overloadable (E) 11659 and then Current_Entity_In_Scope (E) /= E 11660 then 11661 -- It may be that the completion is mistyped and appears as 11662 -- a distinct overloading of the entity. 11663 11664 declare 11665 Candidate : constant Entity_Id := 11666 Current_Entity_In_Scope (E); 11667 Decl : constant Node_Id := 11668 Unit_Declaration_Node (Candidate); 11669 11670 begin 11671 if Is_Overloadable (Candidate) 11672 and then Ekind (Candidate) = Ekind (E) 11673 and then Nkind (Decl) = N_Subprogram_Body 11674 and then Acts_As_Spec (Decl) 11675 then 11676 Check_Type_Conformant (Candidate, E); 11677 11678 else 11679 Missing_Body; 11680 end if; 11681 end; 11682 11683 else 11684 Missing_Body; 11685 end if; 11686 end if; 11687 end if; 11688 end Post_Error; 11689 11690 -- Local variables 11691 11692 Pack_Id : constant Entity_Id := Current_Scope; 11693 11694 -- Start of processing for Check_Completion 11695 11696 begin 11697 E := First_Entity (Pack_Id); 11698 while Present (E) loop 11699 if Is_Intrinsic_Subprogram (E) then 11700 null; 11701 11702 -- The following situation requires special handling: a child unit 11703 -- that appears in the context clause of the body of its parent: 11704 11705 -- procedure Parent.Child (...); 11706 11707 -- with Parent.Child; 11708 -- package body Parent is 11709 11710 -- Here Parent.Child appears as a local entity, but should not be 11711 -- flagged as requiring completion, because it is a compilation 11712 -- unit. 11713 11714 -- Ignore missing completion for a subprogram that does not come from 11715 -- source (including the _Call primitive operation of RAS types, 11716 -- which has to have the flag Comes_From_Source for other purposes): 11717 -- we assume that the expander will provide the missing completion. 11718 -- In case of previous errors, other expansion actions that provide 11719 -- bodies for null procedures with not be invoked, so inhibit message 11720 -- in those cases. 11721 11722 -- Note that E_Operator is not in the list that follows, because 11723 -- this kind is reserved for predefined operators, that are 11724 -- intrinsic and do not need completion. 11725 11726 elsif Ekind (E) in E_Function 11727 | E_Procedure 11728 | E_Generic_Function 11729 | E_Generic_Procedure 11730 then 11731 if Has_Completion (E) then 11732 null; 11733 11734 elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then 11735 null; 11736 11737 elsif Is_Subprogram (E) 11738 and then (not Comes_From_Source (E) 11739 or else Chars (E) = Name_uCall) 11740 then 11741 null; 11742 11743 elsif 11744 Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit 11745 then 11746 null; 11747 11748 elsif Nkind (Parent (E)) = N_Procedure_Specification 11749 and then Null_Present (Parent (E)) 11750 and then Serious_Errors_Detected > 0 11751 then 11752 null; 11753 11754 else 11755 Post_Error; 11756 end if; 11757 11758 elsif Is_Entry (E) then 11759 if not Has_Completion (E) 11760 and then Ekind (Scope (E)) = E_Protected_Type 11761 then 11762 Post_Error; 11763 end if; 11764 11765 elsif Is_Package_Or_Generic_Package (E) then 11766 if Unit_Requires_Body (E) then 11767 if not Has_Completion (E) 11768 and then Nkind (Parent (Unit_Declaration_Node (E))) /= 11769 N_Compilation_Unit 11770 then 11771 Post_Error; 11772 end if; 11773 11774 elsif not Is_Child_Unit (E) then 11775 May_Need_Implicit_Body (E); 11776 end if; 11777 11778 -- A formal incomplete type (Ada 2012) does not require a completion; 11779 -- other incomplete type declarations do. 11780 11781 elsif Ekind (E) = E_Incomplete_Type then 11782 if No (Underlying_Type (E)) 11783 and then not Is_Generic_Type (E) 11784 then 11785 Post_Error; 11786 end if; 11787 11788 elsif Ekind (E) in E_Task_Type | E_Protected_Type then 11789 if not Has_Completion (E) then 11790 Post_Error; 11791 end if; 11792 11793 -- A single task declared in the current scope is a constant, verify 11794 -- that the body of its anonymous type is in the same scope. If the 11795 -- task is defined elsewhere, this may be a renaming declaration for 11796 -- which no completion is needed. 11797 11798 elsif Ekind (E) = E_Constant then 11799 if Ekind (Etype (E)) = E_Task_Type 11800 and then not Has_Completion (Etype (E)) 11801 and then Scope (Etype (E)) = Current_Scope 11802 then 11803 Post_Error; 11804 end if; 11805 11806 elsif Ekind (E) = E_Record_Type then 11807 if Is_Tagged_Type (E) then 11808 Check_Abstract_Overriding (E); 11809 Check_Conventions (E); 11810 end if; 11811 11812 Check_Aliased_Component_Types (E); 11813 11814 elsif Ekind (E) = E_Array_Type then 11815 Check_Aliased_Component_Types (E); 11816 11817 end if; 11818 11819 Next_Entity (E); 11820 end loop; 11821 end Check_Completion; 11822 11823 ------------------------------------- 11824 -- Check_Constraining_Discriminant -- 11825 ------------------------------------- 11826 11827 procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id) 11828 is 11829 New_Type : constant Entity_Id := Etype (New_Disc); 11830 Old_Type : Entity_Id; 11831 11832 begin 11833 -- If the record type contains an array constrained by the discriminant 11834 -- but with some different bound, the compiler tries to create a smaller 11835 -- range for the discriminant type (see exp_ch3.Adjust_Discriminants). 11836 -- In this case, where the discriminant type is a scalar type, the check 11837 -- must use the original discriminant type in the parent declaration. 11838 11839 if Is_Scalar_Type (New_Type) then 11840 Old_Type := Entity (Discriminant_Type (Parent (Old_Disc))); 11841 else 11842 Old_Type := Etype (Old_Disc); 11843 end if; 11844 11845 if not Subtypes_Statically_Compatible (New_Type, Old_Type) then 11846 Error_Msg_N 11847 ("subtype must be statically compatible with parent discriminant", 11848 New_Disc); 11849 11850 if not Predicates_Compatible (New_Type, Old_Type) then 11851 Error_Msg_N 11852 ("\subtype predicate is not compatible with parent discriminant", 11853 New_Disc); 11854 end if; 11855 end if; 11856 end Check_Constraining_Discriminant; 11857 11858 ------------------------------------ 11859 -- Check_CPP_Type_Has_No_Defaults -- 11860 ------------------------------------ 11861 11862 procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is 11863 Tdef : constant Node_Id := Type_Definition (Declaration_Node (T)); 11864 Clist : Node_Id; 11865 Comp : Node_Id; 11866 11867 begin 11868 -- Obtain the component list 11869 11870 if Nkind (Tdef) = N_Record_Definition then 11871 Clist := Component_List (Tdef); 11872 else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); 11873 Clist := Component_List (Record_Extension_Part (Tdef)); 11874 end if; 11875 11876 -- Check all components to ensure no default expressions 11877 11878 if Present (Clist) then 11879 Comp := First (Component_Items (Clist)); 11880 while Present (Comp) loop 11881 if Present (Expression (Comp)) then 11882 Error_Msg_N 11883 ("component of imported 'C'P'P type cannot have " 11884 & "default expression", Expression (Comp)); 11885 end if; 11886 11887 Next (Comp); 11888 end loop; 11889 end if; 11890 end Check_CPP_Type_Has_No_Defaults; 11891 11892 ---------------------------- 11893 -- Check_Delta_Expression -- 11894 ---------------------------- 11895 11896 procedure Check_Delta_Expression (E : Node_Id) is 11897 begin 11898 if not (Is_Real_Type (Etype (E))) then 11899 Wrong_Type (E, Any_Real); 11900 11901 elsif not Is_OK_Static_Expression (E) then 11902 Flag_Non_Static_Expr 11903 ("non-static expression used for delta value!", E); 11904 11905 elsif not UR_Is_Positive (Expr_Value_R (E)) then 11906 Error_Msg_N ("delta expression must be positive", E); 11907 11908 else 11909 return; 11910 end if; 11911 11912 -- If any of above errors occurred, then replace the incorrect 11913 -- expression by the real 0.1, which should prevent further errors. 11914 11915 Rewrite (E, 11916 Make_Real_Literal (Sloc (E), Ureal_Tenth)); 11917 Analyze_And_Resolve (E, Standard_Float); 11918 end Check_Delta_Expression; 11919 11920 ----------------------------- 11921 -- Check_Digits_Expression -- 11922 ----------------------------- 11923 11924 procedure Check_Digits_Expression (E : Node_Id) is 11925 begin 11926 if not (Is_Integer_Type (Etype (E))) then 11927 Wrong_Type (E, Any_Integer); 11928 11929 elsif not Is_OK_Static_Expression (E) then 11930 Flag_Non_Static_Expr 11931 ("non-static expression used for digits value!", E); 11932 11933 elsif Expr_Value (E) <= 0 then 11934 Error_Msg_N ("digits value must be greater than zero", E); 11935 11936 else 11937 return; 11938 end if; 11939 11940 -- If any of above errors occurred, then replace the incorrect 11941 -- expression by the integer 1, which should prevent further errors. 11942 11943 Rewrite (E, Make_Integer_Literal (Sloc (E), 1)); 11944 Analyze_And_Resolve (E, Standard_Integer); 11945 11946 end Check_Digits_Expression; 11947 11948 -------------------------- 11949 -- Check_Initialization -- 11950 -------------------------- 11951 11952 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is 11953 begin 11954 -- Special processing for limited types 11955 11956 if Is_Limited_Type (T) 11957 and then not In_Instance 11958 and then not In_Inlined_Body 11959 then 11960 if not OK_For_Limited_Init (T, Exp) then 11961 11962 -- In GNAT mode, this is just a warning, to allow it to be evilly 11963 -- turned off. Otherwise it is a real error. 11964 11965 if GNAT_Mode then 11966 Error_Msg_N 11967 ("??cannot initialize entities of limited type!", Exp); 11968 11969 elsif Ada_Version < Ada_2005 then 11970 11971 -- The side effect removal machinery may generate illegal Ada 11972 -- code to avoid the usage of access types and 'reference in 11973 -- SPARK mode. Since this is legal code with respect to theorem 11974 -- proving, do not emit the error. 11975 11976 if GNATprove_Mode 11977 and then Nkind (Exp) = N_Function_Call 11978 and then Nkind (Parent (Exp)) = N_Object_Declaration 11979 and then not Comes_From_Source 11980 (Defining_Identifier (Parent (Exp))) 11981 then 11982 null; 11983 11984 else 11985 Error_Msg_N 11986 ("cannot initialize entities of limited type", Exp); 11987 Explain_Limited_Type (T, Exp); 11988 end if; 11989 11990 else 11991 -- Specialize error message according to kind of illegal 11992 -- initial expression. We check the Original_Node to cover 11993 -- cases where the initialization expression of an object 11994 -- declaration generated by the compiler has been rewritten 11995 -- (such as for dispatching calls). 11996 11997 if Nkind (Original_Node (Exp)) = N_Type_Conversion 11998 and then 11999 Nkind (Expression (Original_Node (Exp))) = N_Function_Call 12000 then 12001 -- No error for internally-generated object declarations, 12002 -- which can come from build-in-place assignment statements. 12003 12004 if Nkind (Parent (Exp)) = N_Object_Declaration 12005 and then not Comes_From_Source 12006 (Defining_Identifier (Parent (Exp))) 12007 then 12008 null; 12009 12010 else 12011 Error_Msg_N 12012 ("illegal context for call to function with limited " 12013 & "result", Exp); 12014 end if; 12015 12016 else 12017 Error_Msg_N 12018 ("initialization of limited object requires aggregate or " 12019 & "function call", Exp); 12020 end if; 12021 end if; 12022 end if; 12023 end if; 12024 12025 -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets 12026 -- set unless we can be sure that no range check is required. 12027 12028 if not Expander_Active 12029 and then Is_Scalar_Type (T) 12030 and then not Is_In_Range (Exp, T, Assume_Valid => True) 12031 then 12032 Set_Do_Range_Check (Exp); 12033 end if; 12034 end Check_Initialization; 12035 12036 ---------------------- 12037 -- Check_Interfaces -- 12038 ---------------------- 12039 12040 procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is 12041 Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); 12042 12043 Iface : Node_Id; 12044 Iface_Def : Node_Id; 12045 Iface_Typ : Entity_Id; 12046 Parent_Node : Node_Id; 12047 12048 Is_Task : Boolean := False; 12049 -- Set True if parent type or any progenitor is a task interface 12050 12051 Is_Protected : Boolean := False; 12052 -- Set True if parent type or any progenitor is a protected interface 12053 12054 procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); 12055 -- Check that a progenitor is compatible with declaration. If an error 12056 -- message is output, it is posted on Error_Node. 12057 12058 ------------------ 12059 -- Check_Ifaces -- 12060 ------------------ 12061 12062 procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is 12063 Iface_Id : constant Entity_Id := 12064 Defining_Identifier (Parent (Iface_Def)); 12065 Type_Def : Node_Id; 12066 12067 begin 12068 if Nkind (N) = N_Private_Extension_Declaration then 12069 Type_Def := N; 12070 else 12071 Type_Def := Type_Definition (N); 12072 end if; 12073 12074 if Is_Task_Interface (Iface_Id) then 12075 Is_Task := True; 12076 12077 elsif Is_Protected_Interface (Iface_Id) then 12078 Is_Protected := True; 12079 end if; 12080 12081 if Is_Synchronized_Interface (Iface_Id) then 12082 12083 -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private 12084 -- extension derived from a synchronized interface must explicitly 12085 -- be declared synchronized, because the full view will be a 12086 -- synchronized type. 12087 12088 if Nkind (N) = N_Private_Extension_Declaration then 12089 if not Synchronized_Present (N) then 12090 Error_Msg_NE 12091 ("private extension of& must be explicitly synchronized", 12092 N, Iface_Id); 12093 end if; 12094 12095 -- However, by 3.9.4(16/2), a full type that is a record extension 12096 -- is never allowed to derive from a synchronized interface (note 12097 -- that interfaces must be excluded from this check, because those 12098 -- are represented by derived type definitions in some cases). 12099 12100 elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition 12101 and then not Interface_Present (Type_Definition (N)) 12102 then 12103 Error_Msg_N ("record extension cannot derive from synchronized " 12104 & "interface", Error_Node); 12105 end if; 12106 end if; 12107 12108 -- Check that the characteristics of the progenitor are compatible 12109 -- with the explicit qualifier in the declaration. 12110 -- The check only applies to qualifiers that come from source. 12111 -- Limited_Present also appears in the declaration of corresponding 12112 -- records, and the check does not apply to them. 12113 12114 if Limited_Present (Type_Def) 12115 and then not 12116 Is_Concurrent_Record_Type (Defining_Identifier (N)) 12117 then 12118 if Is_Limited_Interface (Parent_Type) 12119 and then not Is_Limited_Interface (Iface_Id) 12120 then 12121 Error_Msg_NE 12122 ("progenitor & must be limited interface", 12123 Error_Node, Iface_Id); 12124 12125 elsif 12126 (Task_Present (Iface_Def) 12127 or else Protected_Present (Iface_Def) 12128 or else Synchronized_Present (Iface_Def)) 12129 and then Nkind (N) /= N_Private_Extension_Declaration 12130 and then not Error_Posted (N) 12131 then 12132 Error_Msg_NE 12133 ("progenitor & must be limited interface", 12134 Error_Node, Iface_Id); 12135 end if; 12136 12137 -- Protected interfaces can only inherit from limited, synchronized 12138 -- or protected interfaces. 12139 12140 elsif Nkind (N) = N_Full_Type_Declaration 12141 and then Protected_Present (Type_Def) 12142 then 12143 if Limited_Present (Iface_Def) 12144 or else Synchronized_Present (Iface_Def) 12145 or else Protected_Present (Iface_Def) 12146 then 12147 null; 12148 12149 elsif Task_Present (Iface_Def) then 12150 Error_Msg_N ("(Ada 2005) protected interface cannot inherit " 12151 & "from task interface", Error_Node); 12152 12153 else 12154 Error_Msg_N ("(Ada 2005) protected interface cannot inherit " 12155 & "from non-limited interface", Error_Node); 12156 end if; 12157 12158 -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from 12159 -- limited and synchronized. 12160 12161 elsif Synchronized_Present (Type_Def) then 12162 if Limited_Present (Iface_Def) 12163 or else Synchronized_Present (Iface_Def) 12164 then 12165 null; 12166 12167 elsif Protected_Present (Iface_Def) 12168 and then Nkind (N) /= N_Private_Extension_Declaration 12169 then 12170 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " 12171 & "from protected interface", Error_Node); 12172 12173 elsif Task_Present (Iface_Def) 12174 and then Nkind (N) /= N_Private_Extension_Declaration 12175 then 12176 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " 12177 & "from task interface", Error_Node); 12178 12179 elsif not Is_Limited_Interface (Iface_Id) then 12180 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " 12181 & "from non-limited interface", Error_Node); 12182 end if; 12183 12184 -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, 12185 -- synchronized or task interfaces. 12186 12187 elsif Nkind (N) = N_Full_Type_Declaration 12188 and then Task_Present (Type_Def) 12189 then 12190 if Limited_Present (Iface_Def) 12191 or else Synchronized_Present (Iface_Def) 12192 or else Task_Present (Iface_Def) 12193 then 12194 null; 12195 12196 elsif Protected_Present (Iface_Def) then 12197 Error_Msg_N ("(Ada 2005) task interface cannot inherit from " 12198 & "protected interface", Error_Node); 12199 12200 else 12201 Error_Msg_N ("(Ada 2005) task interface cannot inherit from " 12202 & "non-limited interface", Error_Node); 12203 end if; 12204 end if; 12205 end Check_Ifaces; 12206 12207 -- Start of processing for Check_Interfaces 12208 12209 begin 12210 if Is_Interface (Parent_Type) then 12211 if Is_Task_Interface (Parent_Type) then 12212 Is_Task := True; 12213 12214 elsif Is_Protected_Interface (Parent_Type) then 12215 Is_Protected := True; 12216 end if; 12217 end if; 12218 12219 if Nkind (N) = N_Private_Extension_Declaration then 12220 12221 -- Check that progenitors are compatible with declaration 12222 12223 Iface := First (Interface_List (Def)); 12224 while Present (Iface) loop 12225 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 12226 12227 Parent_Node := Parent (Base_Type (Iface_Typ)); 12228 Iface_Def := Type_Definition (Parent_Node); 12229 12230 if not Is_Interface (Iface_Typ) then 12231 Diagnose_Interface (Iface, Iface_Typ); 12232 else 12233 Check_Ifaces (Iface_Def, Iface); 12234 end if; 12235 12236 Next (Iface); 12237 end loop; 12238 12239 if Is_Task and Is_Protected then 12240 Error_Msg_N 12241 ("type cannot derive from task and protected interface", N); 12242 end if; 12243 12244 return; 12245 end if; 12246 12247 -- Full type declaration of derived type. 12248 -- Check compatibility with parent if it is interface type 12249 12250 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition 12251 and then Is_Interface (Parent_Type) 12252 then 12253 Parent_Node := Parent (Parent_Type); 12254 12255 -- More detailed checks for interface varieties 12256 12257 Check_Ifaces 12258 (Iface_Def => Type_Definition (Parent_Node), 12259 Error_Node => Subtype_Indication (Type_Definition (N))); 12260 end if; 12261 12262 Iface := First (Interface_List (Def)); 12263 while Present (Iface) loop 12264 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 12265 12266 Parent_Node := Parent (Base_Type (Iface_Typ)); 12267 Iface_Def := Type_Definition (Parent_Node); 12268 12269 if not Is_Interface (Iface_Typ) then 12270 Diagnose_Interface (Iface, Iface_Typ); 12271 12272 else 12273 -- "The declaration of a specific descendant of an interface 12274 -- type freezes the interface type" RM 13.14 12275 12276 Freeze_Before (N, Iface_Typ); 12277 Check_Ifaces (Iface_Def, Error_Node => Iface); 12278 end if; 12279 12280 Next (Iface); 12281 end loop; 12282 12283 if Is_Task and Is_Protected then 12284 Error_Msg_N 12285 ("type cannot derive from task and protected interface", N); 12286 end if; 12287 end Check_Interfaces; 12288 12289 ------------------------------------ 12290 -- Check_Or_Process_Discriminants -- 12291 ------------------------------------ 12292 12293 -- If an incomplete or private type declaration was already given for the 12294 -- type, the discriminants may have already been processed if they were 12295 -- present on the incomplete declaration. In this case a full conformance 12296 -- check has been performed in Find_Type_Name, and we then recheck here 12297 -- some properties that can't be checked on the partial view alone. 12298 -- Otherwise we call Process_Discriminants. 12299 12300 procedure Check_Or_Process_Discriminants 12301 (N : Node_Id; 12302 T : Entity_Id; 12303 Prev : Entity_Id := Empty) 12304 is 12305 begin 12306 if Has_Discriminants (T) then 12307 12308 -- Discriminants are already set on T if they were already present 12309 -- on the partial view. Make them visible to component declarations. 12310 12311 declare 12312 D : Entity_Id; 12313 -- Discriminant on T (full view) referencing expr on partial view 12314 12315 Prev_D : Entity_Id; 12316 -- Entity of corresponding discriminant on partial view 12317 12318 New_D : Node_Id; 12319 -- Discriminant specification for full view, expression is 12320 -- the syntactic copy on full view (which has been checked for 12321 -- conformance with partial view), only used here to post error 12322 -- message. 12323 12324 begin 12325 D := First_Discriminant (T); 12326 New_D := First (Discriminant_Specifications (N)); 12327 while Present (D) loop 12328 Prev_D := Current_Entity (D); 12329 Set_Current_Entity (D); 12330 Set_Is_Immediately_Visible (D); 12331 Set_Homonym (D, Prev_D); 12332 12333 -- Handle the case where there is an untagged partial view and 12334 -- the full view is tagged: must disallow discriminants with 12335 -- defaults, unless compiling for Ada 2012, which allows a 12336 -- limited tagged type to have defaulted discriminants (see 12337 -- AI05-0214). However, suppress error here if it was already 12338 -- reported on the default expression of the partial view. 12339 12340 if Is_Tagged_Type (T) 12341 and then Present (Expression (Parent (D))) 12342 and then (not Is_Limited_Type (Current_Scope) 12343 or else Ada_Version < Ada_2012) 12344 and then not Error_Posted (Expression (Parent (D))) 12345 then 12346 if Ada_Version >= Ada_2012 then 12347 Error_Msg_N 12348 ("discriminants of nonlimited tagged type cannot have " 12349 & "defaults", 12350 Expression (New_D)); 12351 else 12352 Error_Msg_N 12353 ("discriminants of tagged type cannot have defaults", 12354 Expression (New_D)); 12355 end if; 12356 end if; 12357 12358 -- Ada 2005 (AI-230): Access discriminant allowed in 12359 -- non-limited record types. 12360 12361 if Ada_Version < Ada_2005 then 12362 12363 -- This restriction gets applied to the full type here. It 12364 -- has already been applied earlier to the partial view. 12365 12366 Check_Access_Discriminant_Requires_Limited (Parent (D), N); 12367 end if; 12368 12369 Next_Discriminant (D); 12370 Next (New_D); 12371 end loop; 12372 end; 12373 12374 elsif Present (Discriminant_Specifications (N)) then 12375 Process_Discriminants (N, Prev); 12376 end if; 12377 end Check_Or_Process_Discriminants; 12378 12379 ---------------------- 12380 -- Check_Real_Bound -- 12381 ---------------------- 12382 12383 procedure Check_Real_Bound (Bound : Node_Id) is 12384 begin 12385 if not Is_Real_Type (Etype (Bound)) then 12386 Error_Msg_N 12387 ("bound in real type definition must be of real type", Bound); 12388 12389 elsif not Is_OK_Static_Expression (Bound) then 12390 Flag_Non_Static_Expr 12391 ("non-static expression used for real type bound!", Bound); 12392 12393 else 12394 return; 12395 end if; 12396 12397 Rewrite 12398 (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0)); 12399 Analyze (Bound); 12400 Resolve (Bound, Standard_Float); 12401 end Check_Real_Bound; 12402 12403 ------------------------------ 12404 -- Complete_Private_Subtype -- 12405 ------------------------------ 12406 12407 procedure Complete_Private_Subtype 12408 (Priv : Entity_Id; 12409 Full : Entity_Id; 12410 Full_Base : Entity_Id; 12411 Related_Nod : Node_Id) 12412 is 12413 Save_Next_Entity : Entity_Id; 12414 Save_Homonym : Entity_Id; 12415 12416 begin 12417 -- Set semantic attributes for (implicit) private subtype completion. 12418 -- If the full type has no discriminants, then it is a copy of the 12419 -- full view of the base. Otherwise, it is a subtype of the base with 12420 -- a possible discriminant constraint. Save and restore the original 12421 -- Next_Entity field of full to ensure that the calls to Copy_Node do 12422 -- not corrupt the entity chain. 12423 12424 Save_Next_Entity := Next_Entity (Full); 12425 Save_Homonym := Homonym (Priv); 12426 12427 if Is_Private_Type (Full_Base) 12428 or else Is_Record_Type (Full_Base) 12429 or else Is_Concurrent_Type (Full_Base) 12430 then 12431 Copy_Node (Priv, Full); 12432 12433 -- Note that the Etype of the full view is the same as the Etype of 12434 -- the partial view. In this fashion, the subtype has access to the 12435 -- correct view of the parent. 12436 12437 Set_Has_Discriminants (Full, Has_Discriminants (Full_Base)); 12438 Set_Has_Unknown_Discriminants 12439 (Full, Has_Unknown_Discriminants (Full_Base)); 12440 Set_First_Entity (Full, First_Entity (Full_Base)); 12441 Set_Last_Entity (Full, Last_Entity (Full_Base)); 12442 12443 -- If the underlying base type is constrained, we know that the 12444 -- full view of the subtype is constrained as well (the converse 12445 -- is not necessarily true). 12446 12447 if Is_Constrained (Full_Base) then 12448 Set_Is_Constrained (Full); 12449 end if; 12450 12451 else 12452 Copy_Node (Full_Base, Full); 12453 12454 -- The following subtlety with the Etype of the full view needs to be 12455 -- taken into account here. One could think that it must naturally be 12456 -- set to the base type of the full base: 12457 12458 -- Set_Etype (Full, Base_Type (Full_Base)); 12459 12460 -- so that the full view becomes a subtype of the full base when the 12461 -- latter is a base type, which must for example happen when the full 12462 -- base is declared as derived type. That's also correct if the full 12463 -- base is declared as an array type, or a floating-point type, or a 12464 -- fixed-point type, or a signed integer type, as these declarations 12465 -- create an implicit base type and a first subtype so the Etype of 12466 -- the full views must be the implicit base type. But that's wrong 12467 -- if the full base is declared as an access type, or an enumeration 12468 -- type, or a modular integer type, as these declarations directly 12469 -- create a base type, i.e. with Etype pointing to itself. Moreover 12470 -- the full base being declared in the private part, i.e. when the 12471 -- views are swapped, the end result is that the Etype of the full 12472 -- base is set to its private view in this case and that we need to 12473 -- propagate this setting to the full view in order for the subtype 12474 -- to be compatible with the base type. 12475 12476 if Is_Base_Type (Full_Base) 12477 and then (Is_Derived_Type (Full_Base) 12478 or else Ekind (Full_Base) in Array_Kind 12479 or else Ekind (Full_Base) in Fixed_Point_Kind 12480 or else Ekind (Full_Base) in Float_Kind 12481 or else Ekind (Full_Base) in Signed_Integer_Kind) 12482 then 12483 Set_Etype (Full, Full_Base); 12484 end if; 12485 12486 Set_Chars (Full, Chars (Priv)); 12487 Set_Sloc (Full, Sloc (Priv)); 12488 Conditional_Delay (Full, Priv); 12489 end if; 12490 12491 Link_Entities (Full, Save_Next_Entity); 12492 Set_Homonym (Full, Save_Homonym); 12493 Set_Associated_Node_For_Itype (Full, Related_Nod); 12494 12495 -- Set common attributes for all subtypes: kind, convention, etc. 12496 12497 Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); 12498 Set_Convention (Full, Convention (Full_Base)); 12499 Set_Is_First_Subtype (Full, False); 12500 Set_Scope (Full, Scope (Priv)); 12501 Set_Size_Info (Full, Full_Base); 12502 Set_RM_Size (Full, RM_Size (Full_Base)); 12503 Set_Is_Itype (Full); 12504 12505 -- A subtype of a private-type-without-discriminants, whose full-view 12506 -- has discriminants with default expressions, is not constrained. 12507 12508 if not Has_Discriminants (Priv) then 12509 Set_Is_Constrained (Full, Is_Constrained (Full_Base)); 12510 12511 if Has_Discriminants (Full_Base) then 12512 Set_Discriminant_Constraint 12513 (Full, Discriminant_Constraint (Full_Base)); 12514 12515 -- The partial view may have been indefinite, the full view 12516 -- might not be. 12517 12518 Set_Has_Unknown_Discriminants 12519 (Full, Has_Unknown_Discriminants (Full_Base)); 12520 end if; 12521 end if; 12522 12523 Set_First_Rep_Item (Full, First_Rep_Item (Full_Base)); 12524 Set_Depends_On_Private (Full, Has_Private_Component (Full)); 12525 12526 -- Freeze the private subtype entity if its parent is delayed, and not 12527 -- already frozen. We skip this processing if the type is an anonymous 12528 -- subtype of a record component, or is the corresponding record of a 12529 -- protected type, since these are processed when the enclosing type 12530 -- is frozen. If the parent type is declared in a nested package then 12531 -- the freezing of the private and full views also happens later. 12532 12533 if not Is_Type (Scope (Full)) then 12534 if Is_Itype (Priv) 12535 and then In_Same_Source_Unit (Full, Full_Base) 12536 and then Scope (Full_Base) /= Scope (Full) 12537 then 12538 Set_Has_Delayed_Freeze (Full); 12539 Set_Has_Delayed_Freeze (Priv); 12540 12541 else 12542 Set_Has_Delayed_Freeze (Full, 12543 Has_Delayed_Freeze (Full_Base) 12544 and then not Is_Frozen (Full_Base)); 12545 end if; 12546 end if; 12547 12548 Set_Freeze_Node (Full, Empty); 12549 Set_Is_Frozen (Full, False); 12550 12551 if Has_Discriminants (Full) then 12552 Set_Stored_Constraint_From_Discriminant_Constraint (Full); 12553 Set_Stored_Constraint (Priv, Stored_Constraint (Full)); 12554 12555 if Has_Unknown_Discriminants (Full) then 12556 Set_Discriminant_Constraint (Full, No_Elist); 12557 end if; 12558 end if; 12559 12560 if Ekind (Full_Base) = E_Record_Type 12561 and then Has_Discriminants (Full_Base) 12562 and then Has_Discriminants (Priv) -- might not, if errors 12563 and then not Has_Unknown_Discriminants (Priv) 12564 and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv)) 12565 then 12566 Create_Constrained_Components 12567 (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv)); 12568 12569 -- If the full base is itself derived from private, build a congruent 12570 -- subtype of its underlying full view, for use by the back end. 12571 12572 elsif Is_Private_Type (Full_Base) 12573 and then Present (Underlying_Full_View (Full_Base)) 12574 then 12575 declare 12576 Underlying_Full_Base : constant Entity_Id 12577 := Underlying_Full_View (Full_Base); 12578 Underlying_Full : constant Entity_Id 12579 := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); 12580 begin 12581 Set_Is_Itype (Underlying_Full); 12582 Set_Associated_Node_For_Itype (Underlying_Full, Related_Nod); 12583 Complete_Private_Subtype 12584 (Priv, Underlying_Full, Underlying_Full_Base, Related_Nod); 12585 Set_Underlying_Full_View (Full, Underlying_Full); 12586 Set_Is_Underlying_Full_View (Underlying_Full); 12587 end; 12588 12589 elsif Is_Record_Type (Full_Base) then 12590 12591 -- Show Full is simply a renaming of Full_Base 12592 12593 Set_Cloned_Subtype (Full, Full_Base); 12594 Set_Is_Limited_Record (Full, Is_Limited_Record (Full_Base)); 12595 12596 -- Propagate predicates 12597 12598 Propagate_Predicate_Attributes (Full, Full_Base); 12599 end if; 12600 12601 -- It is unsafe to share the bounds of a scalar type, because the Itype 12602 -- is elaborated on demand, and if a bound is nonstatic, then different 12603 -- orders of elaboration in different units will lead to different 12604 -- external symbols. 12605 12606 if Is_Scalar_Type (Full_Base) then 12607 Set_Scalar_Range (Full, 12608 Make_Range (Sloc (Related_Nod), 12609 Low_Bound => 12610 Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)), 12611 High_Bound => 12612 Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base)))); 12613 12614 -- This completion inherits the bounds of the full parent, but if 12615 -- the parent is an unconstrained floating point type, so is the 12616 -- completion. 12617 12618 if Is_Floating_Point_Type (Full_Base) then 12619 Set_Includes_Infinities 12620 (Scalar_Range (Full), Has_Infinities (Full_Base)); 12621 end if; 12622 end if; 12623 12624 -- ??? It seems that a lot of fields are missing that should be copied 12625 -- from Full_Base to Full. Here are some that are introduced in a 12626 -- non-disruptive way but a cleanup is necessary. 12627 12628 if Is_Tagged_Type (Full_Base) then 12629 Set_Is_Tagged_Type (Full); 12630 Set_Is_Limited_Record (Full, Is_Limited_Record (Full_Base)); 12631 12632 Set_Direct_Primitive_Operations 12633 (Full, Direct_Primitive_Operations (Full_Base)); 12634 Set_No_Tagged_Streams_Pragma 12635 (Full, No_Tagged_Streams_Pragma (Full_Base)); 12636 12637 if Is_Interface (Full_Base) then 12638 Set_Is_Interface (Full); 12639 Set_Is_Limited_Interface (Full, Is_Limited_Interface (Full_Base)); 12640 end if; 12641 12642 -- Inherit class_wide type of full_base in case the partial view was 12643 -- not tagged. Otherwise it has already been created when the private 12644 -- subtype was analyzed. 12645 12646 if No (Class_Wide_Type (Full)) then 12647 Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); 12648 end if; 12649 12650 -- If this is a subtype of a protected or task type, constrain its 12651 -- corresponding record, unless this is a subtype without constraints, 12652 -- i.e. a simple renaming as with an actual subtype in an instance. 12653 12654 elsif Is_Concurrent_Type (Full_Base) then 12655 if Has_Discriminants (Full) 12656 and then Present (Corresponding_Record_Type (Full_Base)) 12657 and then 12658 not Is_Empty_Elmt_List (Discriminant_Constraint (Full)) 12659 then 12660 Set_Corresponding_Record_Type (Full, 12661 Constrain_Corresponding_Record 12662 (Full, Corresponding_Record_Type (Full_Base), Related_Nod)); 12663 12664 else 12665 Set_Corresponding_Record_Type (Full, 12666 Corresponding_Record_Type (Full_Base)); 12667 end if; 12668 end if; 12669 12670 -- Link rep item chain, and also setting of Has_Predicates from private 12671 -- subtype to full subtype, since we will need these on the full subtype 12672 -- to create the predicate function. Note that the full subtype may 12673 -- already have rep items, inherited from the full view of the base 12674 -- type, so we must be sure not to overwrite these entries. 12675 12676 declare 12677 Append : Boolean; 12678 Item : Node_Id; 12679 Next_Item : Node_Id; 12680 Priv_Item : Node_Id; 12681 12682 begin 12683 Item := First_Rep_Item (Full); 12684 Priv_Item := First_Rep_Item (Priv); 12685 12686 -- If no existing rep items on full type, we can just link directly 12687 -- to the list of items on the private type, if any exist.. Same if 12688 -- the rep items are only those inherited from the base 12689 12690 if (No (Item) 12691 or else Nkind (Item) /= N_Aspect_Specification 12692 or else Entity (Item) = Full_Base) 12693 and then Present (First_Rep_Item (Priv)) 12694 then 12695 Set_First_Rep_Item (Full, Priv_Item); 12696 12697 -- Otherwise, search to the end of items currently linked to the full 12698 -- subtype and append the private items to the end. However, if Priv 12699 -- and Full already have the same list of rep items, then the append 12700 -- is not done, as that would create a circularity. 12701 -- 12702 -- The partial view may have a predicate and the rep item lists of 12703 -- both views agree when inherited from the same ancestor. In that 12704 -- case, simply propagate the list from one view to the other. 12705 -- A more complex analysis needed here ??? 12706 12707 elsif Present (Priv_Item) 12708 and then Item = Next_Rep_Item (Priv_Item) 12709 then 12710 Set_First_Rep_Item (Full, Priv_Item); 12711 12712 elsif Item /= Priv_Item then 12713 Append := True; 12714 loop 12715 Next_Item := Next_Rep_Item (Item); 12716 exit when No (Next_Item); 12717 Item := Next_Item; 12718 12719 -- If the private view has aspect specifications, the full view 12720 -- inherits them. Since these aspects may already have been 12721 -- attached to the full view during derivation, do not append 12722 -- them if already present. 12723 12724 if Item = First_Rep_Item (Priv) then 12725 Append := False; 12726 exit; 12727 end if; 12728 end loop; 12729 12730 -- And link the private type items at the end of the chain 12731 12732 if Append then 12733 Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); 12734 end if; 12735 end if; 12736 end; 12737 12738 -- Make sure Has_Predicates is set on full type if it is set on the 12739 -- private type. Note that it may already be set on the full type and 12740 -- if so, we don't want to unset it. Similarly, propagate information 12741 -- about delayed aspects, because the corresponding pragmas must be 12742 -- analyzed when one of the views is frozen. This last step is needed 12743 -- in particular when the full type is a scalar type for which an 12744 -- anonymous base type is constructed. 12745 12746 -- The predicate functions are generated either at the freeze point 12747 -- of the type or at the end of the visible part, and we must avoid 12748 -- generating them twice. 12749 12750 Propagate_Predicate_Attributes (Full, Priv); 12751 12752 if Has_Delayed_Aspects (Priv) then 12753 Set_Has_Delayed_Aspects (Full); 12754 end if; 12755 end Complete_Private_Subtype; 12756 12757 ---------------------------- 12758 -- Constant_Redeclaration -- 12759 ---------------------------- 12760 12761 procedure Constant_Redeclaration 12762 (Id : Entity_Id; 12763 N : Node_Id; 12764 T : out Entity_Id) 12765 is 12766 Prev : constant Entity_Id := Current_Entity_In_Scope (Id); 12767 Obj_Def : constant Node_Id := Object_Definition (N); 12768 New_T : Entity_Id; 12769 12770 procedure Check_Possible_Deferred_Completion 12771 (Prev_Id : Entity_Id; 12772 Prev_Obj_Def : Node_Id; 12773 Curr_Obj_Def : Node_Id); 12774 -- Determine whether the two object definitions describe the partial 12775 -- and the full view of a constrained deferred constant. Generate 12776 -- a subtype for the full view and verify that it statically matches 12777 -- the subtype of the partial view. 12778 12779 procedure Check_Recursive_Declaration (Typ : Entity_Id); 12780 -- If deferred constant is an access type initialized with an allocator, 12781 -- check whether there is an illegal recursion in the definition, 12782 -- through a default value of some record subcomponent. This is normally 12783 -- detected when generating init procs, but requires this additional 12784 -- mechanism when expansion is disabled. 12785 12786 ---------------------------------------- 12787 -- Check_Possible_Deferred_Completion -- 12788 ---------------------------------------- 12789 12790 procedure Check_Possible_Deferred_Completion 12791 (Prev_Id : Entity_Id; 12792 Prev_Obj_Def : Node_Id; 12793 Curr_Obj_Def : Node_Id) 12794 is 12795 begin 12796 if Nkind (Prev_Obj_Def) = N_Subtype_Indication 12797 and then Present (Constraint (Prev_Obj_Def)) 12798 and then Nkind (Curr_Obj_Def) = N_Subtype_Indication 12799 and then Present (Constraint (Curr_Obj_Def)) 12800 then 12801 declare 12802 Loc : constant Source_Ptr := Sloc (N); 12803 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); 12804 Decl : constant Node_Id := 12805 Make_Subtype_Declaration (Loc, 12806 Defining_Identifier => Def_Id, 12807 Subtype_Indication => 12808 Relocate_Node (Curr_Obj_Def)); 12809 12810 begin 12811 Insert_Before_And_Analyze (N, Decl); 12812 Set_Etype (Id, Def_Id); 12813 12814 if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then 12815 Error_Msg_Sloc := Sloc (Prev_Id); 12816 Error_Msg_N ("subtype does not statically match deferred " 12817 & "declaration #", N); 12818 end if; 12819 end; 12820 end if; 12821 end Check_Possible_Deferred_Completion; 12822 12823 --------------------------------- 12824 -- Check_Recursive_Declaration -- 12825 --------------------------------- 12826 12827 procedure Check_Recursive_Declaration (Typ : Entity_Id) is 12828 Comp : Entity_Id; 12829 12830 begin 12831 if Is_Record_Type (Typ) then 12832 Comp := First_Component (Typ); 12833 while Present (Comp) loop 12834 if Comes_From_Source (Comp) then 12835 if Present (Expression (Parent (Comp))) 12836 and then Is_Entity_Name (Expression (Parent (Comp))) 12837 and then Entity (Expression (Parent (Comp))) = Prev 12838 then 12839 Error_Msg_Sloc := Sloc (Parent (Comp)); 12840 Error_Msg_NE 12841 ("illegal circularity with declaration for & #", 12842 N, Comp); 12843 return; 12844 12845 elsif Is_Record_Type (Etype (Comp)) then 12846 Check_Recursive_Declaration (Etype (Comp)); 12847 end if; 12848 end if; 12849 12850 Next_Component (Comp); 12851 end loop; 12852 end if; 12853 end Check_Recursive_Declaration; 12854 12855 -- Start of processing for Constant_Redeclaration 12856 12857 begin 12858 if Nkind (Parent (Prev)) = N_Object_Declaration then 12859 if Nkind (Object_Definition 12860 (Parent (Prev))) = N_Subtype_Indication 12861 then 12862 -- Find type of new declaration. The constraints of the two 12863 -- views must match statically, but there is no point in 12864 -- creating an itype for the full view. 12865 12866 if Nkind (Obj_Def) = N_Subtype_Indication then 12867 Find_Type (Subtype_Mark (Obj_Def)); 12868 New_T := Entity (Subtype_Mark (Obj_Def)); 12869 12870 else 12871 Find_Type (Obj_Def); 12872 New_T := Entity (Obj_Def); 12873 end if; 12874 12875 T := Etype (Prev); 12876 12877 else 12878 -- The full view may impose a constraint, even if the partial 12879 -- view does not, so construct the subtype. 12880 12881 New_T := Find_Type_Of_Object (Obj_Def, N); 12882 T := New_T; 12883 end if; 12884 12885 else 12886 -- Current declaration is illegal, diagnosed below in Enter_Name 12887 12888 T := Empty; 12889 New_T := Any_Type; 12890 end if; 12891 12892 -- If previous full declaration or a renaming declaration exists, or if 12893 -- a homograph is present, let Enter_Name handle it, either with an 12894 -- error or with the removal of an overridden implicit subprogram. 12895 -- The previous one is a full declaration if it has an expression 12896 -- (which in the case of an aggregate is indicated by the Init flag). 12897 12898 if Ekind (Prev) /= E_Constant 12899 or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration 12900 or else Present (Expression (Parent (Prev))) 12901 or else Has_Init_Expression (Parent (Prev)) 12902 or else Present (Full_View (Prev)) 12903 then 12904 Enter_Name (Id); 12905 12906 -- Verify that types of both declarations match, or else that both types 12907 -- are anonymous access types whose designated subtypes statically match 12908 -- (as allowed in Ada 2005 by AI-385). 12909 12910 elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) 12911 and then 12912 (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type 12913 or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type 12914 or else Is_Access_Constant (Etype (New_T)) /= 12915 Is_Access_Constant (Etype (Prev)) 12916 or else Can_Never_Be_Null (Etype (New_T)) /= 12917 Can_Never_Be_Null (Etype (Prev)) 12918 or else Null_Exclusion_Present (Parent (Prev)) /= 12919 Null_Exclusion_Present (Parent (Id)) 12920 or else not Subtypes_Statically_Match 12921 (Designated_Type (Etype (Prev)), 12922 Designated_Type (Etype (New_T)))) 12923 then 12924 Error_Msg_Sloc := Sloc (Prev); 12925 Error_Msg_N ("type does not match declaration#", N); 12926 Set_Full_View (Prev, Id); 12927 Set_Etype (Id, Any_Type); 12928 12929 -- A deferred constant whose type is an anonymous array is always 12930 -- illegal (unless imported). A detailed error message might be 12931 -- helpful for Ada beginners. 12932 12933 if Nkind (Object_Definition (Parent (Prev))) 12934 = N_Constrained_Array_Definition 12935 and then Nkind (Object_Definition (N)) 12936 = N_Constrained_Array_Definition 12937 then 12938 Error_Msg_N ("\each anonymous array is a distinct type", N); 12939 Error_Msg_N ("a deferred constant must have a named type", 12940 Object_Definition (Parent (Prev))); 12941 end if; 12942 12943 elsif 12944 Null_Exclusion_Present (Parent (Prev)) 12945 and then not Null_Exclusion_Present (N) 12946 then 12947 Error_Msg_Sloc := Sloc (Prev); 12948 Error_Msg_N ("null-exclusion does not match declaration#", N); 12949 Set_Full_View (Prev, Id); 12950 Set_Etype (Id, Any_Type); 12951 12952 -- If so, process the full constant declaration 12953 12954 else 12955 -- RM 7.4 (6): If the subtype defined by the subtype_indication in 12956 -- the deferred declaration is constrained, then the subtype defined 12957 -- by the subtype_indication in the full declaration shall match it 12958 -- statically. 12959 12960 Check_Possible_Deferred_Completion 12961 (Prev_Id => Prev, 12962 Prev_Obj_Def => Object_Definition (Parent (Prev)), 12963 Curr_Obj_Def => Obj_Def); 12964 12965 Set_Full_View (Prev, Id); 12966 Set_Is_Public (Id, Is_Public (Prev)); 12967 Set_Is_Internal (Id); 12968 Append_Entity (Id, Current_Scope); 12969 12970 -- Check ALIASED present if present before (RM 7.4(7)) 12971 12972 if Is_Aliased (Prev) 12973 and then not Aliased_Present (N) 12974 then 12975 Error_Msg_Sloc := Sloc (Prev); 12976 Error_Msg_N ("ALIASED required (see declaration #)", N); 12977 end if; 12978 12979 -- Check that placement is in private part and that the incomplete 12980 -- declaration appeared in the visible part. 12981 12982 if Ekind (Current_Scope) = E_Package 12983 and then not In_Private_Part (Current_Scope) 12984 then 12985 Error_Msg_Sloc := Sloc (Prev); 12986 Error_Msg_N 12987 ("full constant for declaration # must be in private part", N); 12988 12989 elsif Ekind (Current_Scope) = E_Package 12990 and then 12991 List_Containing (Parent (Prev)) /= 12992 Visible_Declarations (Package_Specification (Current_Scope)) 12993 then 12994 Error_Msg_N 12995 ("deferred constant must be declared in visible part", 12996 Parent (Prev)); 12997 end if; 12998 12999 if Is_Access_Type (T) 13000 and then Nkind (Expression (N)) = N_Allocator 13001 then 13002 Check_Recursive_Declaration (Designated_Type (T)); 13003 end if; 13004 13005 -- A deferred constant is a visible entity. If type has invariants, 13006 -- verify that the initial value satisfies them. This is not done in 13007 -- GNATprove mode, as GNATprove handles invariant checks itself. 13008 13009 if Has_Invariants (T) 13010 and then Present (Invariant_Procedure (T)) 13011 and then not GNATprove_Mode 13012 then 13013 Insert_After (N, 13014 Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N)))); 13015 end if; 13016 end if; 13017 end Constant_Redeclaration; 13018 13019 ---------------------- 13020 -- Constrain_Access -- 13021 ---------------------- 13022 13023 procedure Constrain_Access 13024 (Def_Id : in out Entity_Id; 13025 S : Node_Id; 13026 Related_Nod : Node_Id) 13027 is 13028 T : constant Entity_Id := Entity (Subtype_Mark (S)); 13029 Desig_Type : constant Entity_Id := Designated_Type (T); 13030 Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); 13031 Constraint_OK : Boolean := True; 13032 13033 begin 13034 if Is_Array_Type (Desig_Type) then 13035 Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); 13036 13037 elsif (Is_Record_Type (Desig_Type) 13038 or else Is_Incomplete_Or_Private_Type (Desig_Type)) 13039 and then not Is_Constrained (Desig_Type) 13040 then 13041 -- If this is a constrained access definition for a record 13042 -- component, we leave the type as an unconstrained access, 13043 -- and mark the component so that its actual type is built 13044 -- at a point of use (e.g., an assignment statement). This 13045 -- is handled in Sem_Util.Build_Actual_Subtype_Of_Component. 13046 13047 if Desig_Type = Current_Scope 13048 and then No (Def_Id) 13049 then 13050 Desig_Subtype := 13051 Create_Itype 13052 (E_Void, Related_Nod, Scope_Id => Scope (Desig_Type)); 13053 Set_Ekind (Desig_Subtype, E_Record_Subtype); 13054 Def_Id := Entity (Subtype_Mark (S)); 13055 13056 -- We indicate that the component has a per-object constraint 13057 -- for treatment at a point of use, even though the constraint 13058 -- may be independent of discriminants of the enclosing type. 13059 13060 if Nkind (Related_Nod) = N_Component_Declaration then 13061 Set_Has_Per_Object_Constraint 13062 (Defining_Identifier (Related_Nod)); 13063 end if; 13064 13065 -- This call added to ensure that the constraint is analyzed 13066 -- (needed for a B test). Note that we still return early from 13067 -- this procedure to avoid recursive processing. 13068 13069 Constrain_Discriminated_Type 13070 (Desig_Subtype, S, Related_Nod, For_Access => True); 13071 return; 13072 end if; 13073 13074 -- Enforce rule that the constraint is illegal if there is an 13075 -- unconstrained view of the designated type. This means that the 13076 -- partial view (either a private type declaration or a derivation 13077 -- from a private type) has no discriminants. (Defect Report 13078 -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001). 13079 13080 -- Rule updated for Ada 2005: The private type is said to have 13081 -- a constrained partial view, given that objects of the type 13082 -- can be declared. Furthermore, the rule applies to all access 13083 -- types, unlike the rule concerning default discriminants (see 13084 -- RM 3.7.1(7/3)) 13085 13086 if (Ekind (T) = E_General_Access_Type or else Ada_Version >= Ada_2005) 13087 and then Has_Private_Declaration (Desig_Type) 13088 and then In_Open_Scopes (Scope (Desig_Type)) 13089 and then Has_Discriminants (Desig_Type) 13090 then 13091 declare 13092 Pack : constant Node_Id := 13093 Unit_Declaration_Node (Scope (Desig_Type)); 13094 Decls : List_Id; 13095 Decl : Node_Id; 13096 13097 begin 13098 if Nkind (Pack) = N_Package_Declaration then 13099 Decls := Visible_Declarations (Specification (Pack)); 13100 Decl := First (Decls); 13101 while Present (Decl) loop 13102 if (Nkind (Decl) = N_Private_Type_Declaration 13103 and then Chars (Defining_Identifier (Decl)) = 13104 Chars (Desig_Type)) 13105 13106 or else 13107 (Nkind (Decl) = N_Full_Type_Declaration 13108 and then 13109 Chars (Defining_Identifier (Decl)) = 13110 Chars (Desig_Type) 13111 and then Is_Derived_Type (Desig_Type) 13112 and then 13113 Has_Private_Declaration (Etype (Desig_Type))) 13114 then 13115 if No (Discriminant_Specifications (Decl)) then 13116 Error_Msg_N 13117 ("cannot constrain access type if designated " 13118 & "type has constrained partial view", S); 13119 end if; 13120 13121 exit; 13122 end if; 13123 13124 Next (Decl); 13125 end loop; 13126 end if; 13127 end; 13128 end if; 13129 13130 Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, 13131 For_Access => True); 13132 13133 elsif Is_Concurrent_Type (Desig_Type) 13134 and then not Is_Constrained (Desig_Type) 13135 then 13136 Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' '); 13137 13138 else 13139 Error_Msg_N ("invalid constraint on access type", S); 13140 13141 -- We simply ignore an invalid constraint 13142 13143 Desig_Subtype := Desig_Type; 13144 Constraint_OK := False; 13145 end if; 13146 13147 if No (Def_Id) then 13148 Def_Id := Create_Itype (E_Access_Subtype, Related_Nod); 13149 else 13150 Set_Ekind (Def_Id, E_Access_Subtype); 13151 end if; 13152 13153 if Constraint_OK then 13154 Set_Etype (Def_Id, Base_Type (T)); 13155 13156 if Is_Private_Type (Desig_Type) then 13157 Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod); 13158 end if; 13159 else 13160 Set_Etype (Def_Id, Any_Type); 13161 end if; 13162 13163 Set_Size_Info (Def_Id, T); 13164 Set_Is_Constrained (Def_Id, Constraint_OK); 13165 Set_Directly_Designated_Type (Def_Id, Desig_Subtype); 13166 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 13167 Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T)); 13168 13169 Conditional_Delay (Def_Id, T); 13170 13171 -- AI-363 : Subtypes of general access types whose designated types have 13172 -- default discriminants are disallowed. In instances, the rule has to 13173 -- be checked against the actual, of which T is the subtype. In a 13174 -- generic body, the rule is checked assuming that the actual type has 13175 -- defaulted discriminants. 13176 13177 if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then 13178 if Ekind (Base_Type (T)) = E_General_Access_Type 13179 and then Has_Defaulted_Discriminants (Desig_Type) 13180 then 13181 if Ada_Version < Ada_2005 then 13182 Error_Msg_N 13183 ("access subtype of general access type would not " & 13184 "be allowed in Ada 2005?y?", S); 13185 else 13186 Error_Msg_N 13187 ("access subtype of general access type not allowed", S); 13188 end if; 13189 13190 Error_Msg_N ("\discriminants have defaults", S); 13191 13192 elsif Is_Access_Type (T) 13193 and then Is_Generic_Type (Desig_Type) 13194 and then Has_Discriminants (Desig_Type) 13195 and then In_Package_Body (Current_Scope) 13196 then 13197 if Ada_Version < Ada_2005 then 13198 Error_Msg_N 13199 ("access subtype would not be allowed in generic body " 13200 & "in Ada 2005?y?", S); 13201 else 13202 Error_Msg_N 13203 ("access subtype not allowed in generic body", S); 13204 end if; 13205 13206 Error_Msg_N 13207 ("\designated type is a discriminated formal", S); 13208 end if; 13209 end if; 13210 end Constrain_Access; 13211 13212 --------------------- 13213 -- Constrain_Array -- 13214 --------------------- 13215 13216 procedure Constrain_Array 13217 (Def_Id : in out Entity_Id; 13218 SI : Node_Id; 13219 Related_Nod : Node_Id; 13220 Related_Id : Entity_Id; 13221 Suffix : Character) 13222 is 13223 C : constant Node_Id := Constraint (SI); 13224 Number_Of_Constraints : Nat := 0; 13225 Index : Node_Id; 13226 S, T : Entity_Id; 13227 Constraint_OK : Boolean := True; 13228 13229 begin 13230 T := Entity (Subtype_Mark (SI)); 13231 13232 if Is_Access_Type (T) then 13233 T := Designated_Type (T); 13234 end if; 13235 13236 -- If an index constraint follows a subtype mark in a subtype indication 13237 -- then the type or subtype denoted by the subtype mark must not already 13238 -- impose an index constraint. The subtype mark must denote either an 13239 -- unconstrained array type or an access type whose designated type 13240 -- is such an array type... (RM 3.6.1) 13241 13242 if Is_Constrained (T) then 13243 Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); 13244 Constraint_OK := False; 13245 13246 else 13247 S := First (Constraints (C)); 13248 while Present (S) loop 13249 Number_Of_Constraints := Number_Of_Constraints + 1; 13250 Next (S); 13251 end loop; 13252 13253 -- In either case, the index constraint must provide a discrete 13254 -- range for each index of the array type and the type of each 13255 -- discrete range must be the same as that of the corresponding 13256 -- index. (RM 3.6.1) 13257 13258 if Number_Of_Constraints /= Number_Dimensions (T) then 13259 Error_Msg_NE ("incorrect number of index constraints for }", C, T); 13260 Constraint_OK := False; 13261 13262 else 13263 S := First (Constraints (C)); 13264 Index := First_Index (T); 13265 Analyze (Index); 13266 13267 -- Apply constraints to each index type 13268 13269 for J in 1 .. Number_Of_Constraints loop 13270 Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J); 13271 Next (Index); 13272 Next (S); 13273 end loop; 13274 13275 end if; 13276 end if; 13277 13278 if No (Def_Id) then 13279 Def_Id := 13280 Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix); 13281 Set_Parent (Def_Id, Related_Nod); 13282 13283 else 13284 Set_Ekind (Def_Id, E_Array_Subtype); 13285 end if; 13286 13287 Set_Size_Info (Def_Id, (T)); 13288 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 13289 Set_Etype (Def_Id, Base_Type (T)); 13290 13291 if Constraint_OK then 13292 Set_First_Index (Def_Id, First (Constraints (C))); 13293 else 13294 Set_First_Index (Def_Id, First_Index (T)); 13295 end if; 13296 13297 Set_Is_Constrained (Def_Id, True); 13298 Set_Is_Aliased (Def_Id, Is_Aliased (T)); 13299 Set_Is_Independent (Def_Id, Is_Independent (T)); 13300 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 13301 13302 Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T)); 13303 Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T)); 13304 13305 -- A subtype does not inherit the Packed_Array_Impl_Type of is parent. 13306 -- We need to initialize the attribute because if Def_Id is previously 13307 -- analyzed through a limited_with clause, it will have the attributes 13308 -- of an incomplete type, one of which is an Elist that overlaps the 13309 -- Packed_Array_Impl_Type field. 13310 13311 Set_Packed_Array_Impl_Type (Def_Id, Empty); 13312 13313 -- Build a freeze node if parent still needs one. Also make sure that 13314 -- the Depends_On_Private status is set because the subtype will need 13315 -- reprocessing at the time the base type does, and also we must set a 13316 -- conditional delay. 13317 13318 Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); 13319 Conditional_Delay (Def_Id, T); 13320 end Constrain_Array; 13321 13322 ------------------------------ 13323 -- Constrain_Component_Type -- 13324 ------------------------------ 13325 13326 function Constrain_Component_Type 13327 (Comp : Entity_Id; 13328 Constrained_Typ : Entity_Id; 13329 Related_Node : Node_Id; 13330 Typ : Entity_Id; 13331 Constraints : Elist_Id) return Entity_Id 13332 is 13333 Loc : constant Source_Ptr := Sloc (Constrained_Typ); 13334 Compon_Type : constant Entity_Id := Etype (Comp); 13335 13336 function Build_Constrained_Array_Type 13337 (Old_Type : Entity_Id) return Entity_Id; 13338 -- If Old_Type is an array type, one of whose indexes is constrained 13339 -- by a discriminant, build an Itype whose constraint replaces the 13340 -- discriminant with its value in the constraint. 13341 13342 function Build_Constrained_Discriminated_Type 13343 (Old_Type : Entity_Id) return Entity_Id; 13344 -- Ditto for record components. Handle the case where the constraint 13345 -- is a conversion of the discriminant value, introduced during 13346 -- expansion. 13347 13348 function Build_Constrained_Access_Type 13349 (Old_Type : Entity_Id) return Entity_Id; 13350 -- Ditto for access types. Makes use of previous two functions, to 13351 -- constrain designated type. 13352 13353 function Is_Discriminant (Expr : Node_Id) return Boolean; 13354 -- Returns True if Expr is a discriminant 13355 13356 function Get_Discr_Value (Discr_Expr : Node_Id) return Node_Id; 13357 -- Find the value of a discriminant named by Discr_Expr in Constraints 13358 13359 ----------------------------------- 13360 -- Build_Constrained_Access_Type -- 13361 ----------------------------------- 13362 13363 function Build_Constrained_Access_Type 13364 (Old_Type : Entity_Id) return Entity_Id 13365 is 13366 Desig_Type : constant Entity_Id := Designated_Type (Old_Type); 13367 Itype : Entity_Id; 13368 Desig_Subtype : Entity_Id; 13369 Scop : Entity_Id; 13370 13371 begin 13372 -- If the original access type was not embedded in the enclosing 13373 -- type definition, there is no need to produce a new access 13374 -- subtype. In fact every access type with an explicit constraint 13375 -- generates an itype whose scope is the enclosing record. 13376 13377 if not Is_Type (Scope (Old_Type)) then 13378 return Old_Type; 13379 13380 elsif Is_Array_Type (Desig_Type) then 13381 Desig_Subtype := Build_Constrained_Array_Type (Desig_Type); 13382 13383 elsif Has_Discriminants (Desig_Type) then 13384 13385 -- This may be an access type to an enclosing record type for 13386 -- which we are constructing the constrained components. Return 13387 -- the enclosing record subtype. This is not always correct, 13388 -- but avoids infinite recursion. ??? 13389 13390 Desig_Subtype := Any_Type; 13391 13392 for J in reverse 0 .. Scope_Stack.Last loop 13393 Scop := Scope_Stack.Table (J).Entity; 13394 13395 if Is_Type (Scop) 13396 and then Base_Type (Scop) = Base_Type (Desig_Type) 13397 then 13398 Desig_Subtype := Scop; 13399 end if; 13400 13401 exit when not Is_Type (Scop); 13402 end loop; 13403 13404 if Desig_Subtype = Any_Type then 13405 Desig_Subtype := 13406 Build_Constrained_Discriminated_Type (Desig_Type); 13407 end if; 13408 13409 else 13410 return Old_Type; 13411 end if; 13412 13413 if Desig_Subtype /= Desig_Type then 13414 13415 -- The Related_Node better be here or else we won't be able 13416 -- to attach new itypes to a node in the tree. 13417 13418 pragma Assert (Present (Related_Node)); 13419 13420 Itype := Create_Itype (E_Access_Subtype, Related_Node); 13421 13422 Set_Etype (Itype, Base_Type (Old_Type)); 13423 Set_Size_Info (Itype, (Old_Type)); 13424 Set_Directly_Designated_Type (Itype, Desig_Subtype); 13425 Set_Depends_On_Private (Itype, Has_Private_Component 13426 (Old_Type)); 13427 Set_Is_Access_Constant (Itype, Is_Access_Constant 13428 (Old_Type)); 13429 13430 -- The new itype needs freezing when it depends on a not frozen 13431 -- type and the enclosing subtype needs freezing. 13432 13433 if Has_Delayed_Freeze (Constrained_Typ) 13434 and then not Is_Frozen (Constrained_Typ) 13435 then 13436 Conditional_Delay (Itype, Base_Type (Old_Type)); 13437 end if; 13438 13439 return Itype; 13440 13441 else 13442 return Old_Type; 13443 end if; 13444 end Build_Constrained_Access_Type; 13445 13446 ---------------------------------- 13447 -- Build_Constrained_Array_Type -- 13448 ---------------------------------- 13449 13450 function Build_Constrained_Array_Type 13451 (Old_Type : Entity_Id) return Entity_Id 13452 is 13453 Lo_Expr : Node_Id; 13454 Hi_Expr : Node_Id; 13455 Old_Index : Node_Id; 13456 Range_Node : Node_Id; 13457 Constr_List : List_Id; 13458 13459 Need_To_Create_Itype : Boolean := False; 13460 13461 begin 13462 Old_Index := First_Index (Old_Type); 13463 while Present (Old_Index) loop 13464 Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); 13465 13466 if Is_Discriminant (Lo_Expr) 13467 or else 13468 Is_Discriminant (Hi_Expr) 13469 then 13470 Need_To_Create_Itype := True; 13471 exit; 13472 end if; 13473 13474 Next_Index (Old_Index); 13475 end loop; 13476 13477 if Need_To_Create_Itype then 13478 Constr_List := New_List; 13479 13480 Old_Index := First_Index (Old_Type); 13481 while Present (Old_Index) loop 13482 Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); 13483 13484 if Is_Discriminant (Lo_Expr) then 13485 Lo_Expr := Get_Discr_Value (Lo_Expr); 13486 end if; 13487 13488 if Is_Discriminant (Hi_Expr) then 13489 Hi_Expr := Get_Discr_Value (Hi_Expr); 13490 end if; 13491 13492 Range_Node := 13493 Make_Range 13494 (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr)); 13495 13496 Append (Range_Node, To => Constr_List); 13497 13498 Next_Index (Old_Index); 13499 end loop; 13500 13501 return Build_Subtype (Related_Node, Loc, Old_Type, Constr_List); 13502 13503 else 13504 return Old_Type; 13505 end if; 13506 end Build_Constrained_Array_Type; 13507 13508 ------------------------------------------ 13509 -- Build_Constrained_Discriminated_Type -- 13510 ------------------------------------------ 13511 13512 function Build_Constrained_Discriminated_Type 13513 (Old_Type : Entity_Id) return Entity_Id 13514 is 13515 Expr : Node_Id; 13516 Constr_List : List_Id; 13517 Old_Constraint : Elmt_Id; 13518 13519 Need_To_Create_Itype : Boolean := False; 13520 13521 begin 13522 Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); 13523 while Present (Old_Constraint) loop 13524 Expr := Node (Old_Constraint); 13525 13526 if Is_Discriminant (Expr) then 13527 Need_To_Create_Itype := True; 13528 exit; 13529 13530 -- After expansion of discriminated task types, the value 13531 -- of the discriminant may be converted to a run-time type 13532 -- for restricted run-times. Propagate the value of the 13533 -- discriminant as well, so that e.g. the secondary stack 13534 -- component has a static constraint. Necessary for LLVM. 13535 13536 elsif Nkind (Expr) = N_Type_Conversion 13537 and then Is_Discriminant (Expression (Expr)) 13538 then 13539 Need_To_Create_Itype := True; 13540 exit; 13541 end if; 13542 13543 Next_Elmt (Old_Constraint); 13544 end loop; 13545 13546 if Need_To_Create_Itype then 13547 Constr_List := New_List; 13548 13549 Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); 13550 while Present (Old_Constraint) loop 13551 Expr := Node (Old_Constraint); 13552 13553 if Is_Discriminant (Expr) then 13554 Expr := Get_Discr_Value (Expr); 13555 13556 elsif Nkind (Expr) = N_Type_Conversion 13557 and then Is_Discriminant (Expression (Expr)) 13558 then 13559 Expr := New_Copy_Tree (Expr); 13560 Set_Expression (Expr, Get_Discr_Value (Expression (Expr))); 13561 end if; 13562 13563 Append (New_Copy_Tree (Expr), To => Constr_List); 13564 13565 Next_Elmt (Old_Constraint); 13566 end loop; 13567 13568 return Build_Subtype (Related_Node, Loc, Old_Type, Constr_List); 13569 13570 else 13571 return Old_Type; 13572 end if; 13573 end Build_Constrained_Discriminated_Type; 13574 13575 --------------------- 13576 -- Get_Discr_Value -- 13577 --------------------- 13578 13579 function Get_Discr_Value (Discr_Expr : Node_Id) return Node_Id is 13580 Discr_Id : constant Entity_Id := Entity (Discr_Expr); 13581 -- Entity of a discriminant that appear as a standalone expression in 13582 -- the constraint of a component. 13583 13584 D : Entity_Id; 13585 E : Elmt_Id; 13586 13587 begin 13588 -- The discriminant may be declared for the type, in which case we 13589 -- find it by iterating over the list of discriminants. If the 13590 -- discriminant is inherited from a parent type, it appears as the 13591 -- corresponding discriminant of the current type. This will be the 13592 -- case when constraining an inherited component whose constraint is 13593 -- given by a discriminant of the parent. 13594 13595 D := First_Discriminant (Typ); 13596 E := First_Elmt (Constraints); 13597 13598 while Present (D) loop 13599 if D = Discr_Id 13600 or else D = CR_Discriminant (Discr_Id) 13601 or else Corresponding_Discriminant (D) = Discr_Id 13602 then 13603 return Node (E); 13604 end if; 13605 13606 Next_Discriminant (D); 13607 Next_Elmt (E); 13608 end loop; 13609 13610 -- The Corresponding_Discriminant mechanism is incomplete, because 13611 -- the correspondence between new and old discriminants is not one 13612 -- to one: one new discriminant can constrain several old ones. In 13613 -- that case, scan sequentially the stored_constraint, the list of 13614 -- discriminants of the parents, and the constraints. 13615 13616 -- Previous code checked for the present of the Stored_Constraint 13617 -- list for the derived type, but did not use it at all. Should it 13618 -- be present when the component is a discriminated task type? 13619 13620 if Is_Derived_Type (Typ) 13621 and then Scope (Discr_Id) = Etype (Typ) 13622 then 13623 D := First_Discriminant (Etype (Typ)); 13624 E := First_Elmt (Constraints); 13625 while Present (D) loop 13626 if D = Discr_Id then 13627 return Node (E); 13628 end if; 13629 13630 Next_Discriminant (D); 13631 Next_Elmt (E); 13632 end loop; 13633 end if; 13634 13635 -- Something is wrong if we did not find the value 13636 13637 raise Program_Error; 13638 end Get_Discr_Value; 13639 13640 --------------------- 13641 -- Is_Discriminant -- 13642 --------------------- 13643 13644 function Is_Discriminant (Expr : Node_Id) return Boolean is 13645 Discrim_Scope : Entity_Id; 13646 13647 begin 13648 if Denotes_Discriminant (Expr) then 13649 Discrim_Scope := Scope (Entity (Expr)); 13650 13651 -- Either we have a reference to one of Typ's discriminants, 13652 13653 pragma Assert (Discrim_Scope = Typ 13654 13655 -- or to the discriminants of the parent type, in the case 13656 -- of a derivation of a tagged type with variants. 13657 13658 or else Discrim_Scope = Etype (Typ) 13659 or else Full_View (Discrim_Scope) = Etype (Typ) 13660 13661 -- or same as above for the case where the discriminants 13662 -- were declared in Typ's private view. 13663 13664 or else (Is_Private_Type (Discrim_Scope) 13665 and then Chars (Discrim_Scope) = Chars (Typ)) 13666 13667 -- or else we are deriving from the full view and the 13668 -- discriminant is declared in the private entity. 13669 13670 or else (Is_Private_Type (Typ) 13671 and then Chars (Discrim_Scope) = Chars (Typ)) 13672 13673 -- Or we are constrained the corresponding record of a 13674 -- synchronized type that completes a private declaration. 13675 13676 or else (Is_Concurrent_Record_Type (Typ) 13677 and then 13678 Corresponding_Concurrent_Type (Typ) = Discrim_Scope) 13679 13680 -- or we have a class-wide type, in which case make sure the 13681 -- discriminant found belongs to the root type. 13682 13683 or else (Is_Class_Wide_Type (Typ) 13684 and then Etype (Typ) = Discrim_Scope)); 13685 13686 return True; 13687 end if; 13688 13689 -- In all other cases we have something wrong 13690 13691 return False; 13692 end Is_Discriminant; 13693 13694 -- Start of processing for Constrain_Component_Type 13695 13696 begin 13697 if Nkind (Parent (Comp)) = N_Component_Declaration 13698 and then Comes_From_Source (Parent (Comp)) 13699 and then Comes_From_Source 13700 (Subtype_Indication (Component_Definition (Parent (Comp)))) 13701 and then 13702 Is_Entity_Name 13703 (Subtype_Indication (Component_Definition (Parent (Comp)))) 13704 then 13705 return Compon_Type; 13706 13707 elsif Is_Array_Type (Compon_Type) then 13708 return Build_Constrained_Array_Type (Compon_Type); 13709 13710 elsif Has_Discriminants (Compon_Type) then 13711 return Build_Constrained_Discriminated_Type (Compon_Type); 13712 13713 elsif Is_Access_Type (Compon_Type) then 13714 return Build_Constrained_Access_Type (Compon_Type); 13715 13716 else 13717 return Compon_Type; 13718 end if; 13719 end Constrain_Component_Type; 13720 13721 -------------------------- 13722 -- Constrain_Concurrent -- 13723 -------------------------- 13724 13725 -- For concurrent types, the associated record value type carries the same 13726 -- discriminants, so when we constrain a concurrent type, we must constrain 13727 -- the corresponding record type as well. 13728 13729 procedure Constrain_Concurrent 13730 (Def_Id : in out Entity_Id; 13731 SI : Node_Id; 13732 Related_Nod : Node_Id; 13733 Related_Id : Entity_Id; 13734 Suffix : Character) 13735 is 13736 -- Retrieve Base_Type to ensure getting to the concurrent type in the 13737 -- case of a private subtype (needed when only doing semantic analysis). 13738 13739 T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI))); 13740 T_Val : Entity_Id; 13741 13742 begin 13743 if Is_Access_Type (T_Ent) then 13744 T_Ent := Designated_Type (T_Ent); 13745 end if; 13746 13747 T_Val := Corresponding_Record_Type (T_Ent); 13748 13749 if Present (T_Val) then 13750 13751 if No (Def_Id) then 13752 Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 13753 13754 -- Elaborate itype now, as it may be used in a subsequent 13755 -- synchronized operation in another scope. 13756 13757 if Nkind (Related_Nod) = N_Full_Type_Declaration then 13758 Build_Itype_Reference (Def_Id, Related_Nod); 13759 end if; 13760 end if; 13761 13762 Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); 13763 Set_First_Private_Entity (Def_Id, First_Private_Entity (T_Ent)); 13764 13765 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 13766 Set_Corresponding_Record_Type (Def_Id, 13767 Constrain_Corresponding_Record (Def_Id, T_Val, Related_Nod)); 13768 13769 else 13770 -- If there is no associated record, expansion is disabled and this 13771 -- is a generic context. Create a subtype in any case, so that 13772 -- semantic analysis can proceed. 13773 13774 if No (Def_Id) then 13775 Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 13776 end if; 13777 13778 Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); 13779 end if; 13780 end Constrain_Concurrent; 13781 13782 ------------------------------------ 13783 -- Constrain_Corresponding_Record -- 13784 ------------------------------------ 13785 13786 function Constrain_Corresponding_Record 13787 (Prot_Subt : Entity_Id; 13788 Corr_Rec : Entity_Id; 13789 Related_Nod : Node_Id) return Entity_Id 13790 is 13791 T_Sub : constant Entity_Id := 13792 Create_Itype 13793 (Ekind => E_Record_Subtype, 13794 Related_Nod => Related_Nod, 13795 Related_Id => Corr_Rec, 13796 Suffix => 'C', 13797 Suffix_Index => -1); 13798 13799 begin 13800 Set_Etype (T_Sub, Corr_Rec); 13801 Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt)); 13802 Set_Is_Tagged_Type (T_Sub, Is_Tagged_Type (Corr_Rec)); 13803 Set_Is_Constrained (T_Sub, True); 13804 Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); 13805 Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec)); 13806 13807 if Has_Discriminants (Prot_Subt) then -- False only if errors. 13808 Set_Discriminant_Constraint 13809 (T_Sub, Discriminant_Constraint (Prot_Subt)); 13810 Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub); 13811 Create_Constrained_Components 13812 (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub)); 13813 end if; 13814 13815 Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub)); 13816 13817 if Ekind (Scope (Prot_Subt)) /= E_Record_Type then 13818 Conditional_Delay (T_Sub, Corr_Rec); 13819 13820 else 13821 -- This is a component subtype: it will be frozen in the context of 13822 -- the enclosing record's init_proc, so that discriminant references 13823 -- are resolved to discriminals. (Note: we used to skip freezing 13824 -- altogether in that case, which caused errors downstream for 13825 -- components of a bit packed array type). 13826 13827 Set_Has_Delayed_Freeze (T_Sub); 13828 end if; 13829 13830 return T_Sub; 13831 end Constrain_Corresponding_Record; 13832 13833 ----------------------- 13834 -- Constrain_Decimal -- 13835 ----------------------- 13836 13837 procedure Constrain_Decimal (Def_Id : Entity_Id; S : Node_Id) is 13838 T : constant Entity_Id := Entity (Subtype_Mark (S)); 13839 C : constant Node_Id := Constraint (S); 13840 Loc : constant Source_Ptr := Sloc (C); 13841 Range_Expr : Node_Id; 13842 Digits_Expr : Node_Id; 13843 Digits_Val : Uint; 13844 Bound_Val : Ureal; 13845 13846 begin 13847 Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype); 13848 13849 if Nkind (C) = N_Range_Constraint then 13850 Range_Expr := Range_Expression (C); 13851 Digits_Val := Digits_Value (T); 13852 13853 else 13854 pragma Assert (Nkind (C) = N_Digits_Constraint); 13855 13856 Digits_Expr := Digits_Expression (C); 13857 Analyze_And_Resolve (Digits_Expr, Any_Integer); 13858 13859 Check_Digits_Expression (Digits_Expr); 13860 Digits_Val := Expr_Value (Digits_Expr); 13861 13862 if Digits_Val > Digits_Value (T) then 13863 Error_Msg_N 13864 ("digits expression is incompatible with subtype", C); 13865 Digits_Val := Digits_Value (T); 13866 end if; 13867 13868 if Present (Range_Constraint (C)) then 13869 Range_Expr := Range_Expression (Range_Constraint (C)); 13870 else 13871 Range_Expr := Empty; 13872 end if; 13873 end if; 13874 13875 Set_Etype (Def_Id, Base_Type (T)); 13876 Set_Size_Info (Def_Id, (T)); 13877 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 13878 Set_Delta_Value (Def_Id, Delta_Value (T)); 13879 Set_Scale_Value (Def_Id, Scale_Value (T)); 13880 Set_Small_Value (Def_Id, Small_Value (T)); 13881 Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T)); 13882 Set_Digits_Value (Def_Id, Digits_Val); 13883 13884 -- Manufacture range from given digits value if no range present 13885 13886 if No (Range_Expr) then 13887 Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T); 13888 Range_Expr := 13889 Make_Range (Loc, 13890 Low_Bound => 13891 Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))), 13892 High_Bound => 13893 Convert_To (T, Make_Real_Literal (Loc, Bound_Val))); 13894 end if; 13895 13896 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T); 13897 Set_Discrete_RM_Size (Def_Id); 13898 13899 -- Unconditionally delay the freeze, since we cannot set size 13900 -- information in all cases correctly until the freeze point. 13901 13902 Set_Has_Delayed_Freeze (Def_Id); 13903 end Constrain_Decimal; 13904 13905 ---------------------------------- 13906 -- Constrain_Discriminated_Type -- 13907 ---------------------------------- 13908 13909 procedure Constrain_Discriminated_Type 13910 (Def_Id : Entity_Id; 13911 S : Node_Id; 13912 Related_Nod : Node_Id; 13913 For_Access : Boolean := False) 13914 is 13915 E : Entity_Id := Entity (Subtype_Mark (S)); 13916 T : Entity_Id; 13917 13918 procedure Fixup_Bad_Constraint; 13919 -- Called after finding a bad constraint, and after having posted an 13920 -- appropriate error message. The goal is to leave type Def_Id in as 13921 -- reasonable state as possible. 13922 13923 -------------------------- 13924 -- Fixup_Bad_Constraint -- 13925 -------------------------- 13926 13927 procedure Fixup_Bad_Constraint is 13928 begin 13929 -- Set a reasonable Ekind for the entity, including incomplete types. 13930 13931 Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); 13932 13933 -- Set Etype to the known type, to reduce chances of cascaded errors 13934 13935 Set_Etype (Def_Id, E); 13936 Set_Error_Posted (Def_Id); 13937 end Fixup_Bad_Constraint; 13938 13939 -- Local variables 13940 13941 C : Node_Id; 13942 Constr : Elist_Id := New_Elmt_List; 13943 13944 -- Start of processing for Constrain_Discriminated_Type 13945 13946 begin 13947 C := Constraint (S); 13948 13949 -- A discriminant constraint is only allowed in a subtype indication, 13950 -- after a subtype mark. This subtype mark must denote either a type 13951 -- with discriminants, or an access type whose designated type is a 13952 -- type with discriminants. A discriminant constraint specifies the 13953 -- values of these discriminants (RM 3.7.2(5)). 13954 13955 T := Base_Type (Entity (Subtype_Mark (S))); 13956 13957 if Is_Access_Type (T) then 13958 T := Designated_Type (T); 13959 end if; 13960 13961 -- In an instance it may be necessary to retrieve the full view of a 13962 -- type with unknown discriminants, or a full view with defaulted 13963 -- discriminants. In other contexts the constraint is illegal. 13964 13965 if In_Instance 13966 and then Is_Private_Type (T) 13967 and then Present (Full_View (T)) 13968 and then 13969 (Has_Unknown_Discriminants (T) 13970 or else 13971 (not Has_Discriminants (T) 13972 and then Has_Discriminants (Full_View (T)) 13973 and then Present (Discriminant_Default_Value 13974 (First_Discriminant (Full_View (T)))))) 13975 then 13976 T := Full_View (T); 13977 E := Full_View (E); 13978 end if; 13979 13980 -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. Avoid 13981 -- generating an error for access-to-incomplete subtypes. 13982 13983 if Ada_Version >= Ada_2005 13984 and then Ekind (T) = E_Incomplete_Type 13985 and then Nkind (Parent (S)) = N_Subtype_Declaration 13986 and then not Is_Itype (Def_Id) 13987 then 13988 -- A little sanity check: emit an error message if the type has 13989 -- discriminants to begin with. Type T may be a regular incomplete 13990 -- type or imported via a limited with clause. 13991 13992 if Has_Discriminants (T) 13993 or else (From_Limited_With (T) 13994 and then Present (Non_Limited_View (T)) 13995 and then Nkind (Parent (Non_Limited_View (T))) = 13996 N_Full_Type_Declaration 13997 and then Present (Discriminant_Specifications 13998 (Parent (Non_Limited_View (T))))) 13999 then 14000 Error_Msg_N 14001 ("(Ada 2005) incomplete subtype may not be constrained", C); 14002 else 14003 Error_Msg_N ("invalid constraint: type has no discriminant", C); 14004 end if; 14005 14006 Fixup_Bad_Constraint; 14007 return; 14008 14009 -- Check that the type has visible discriminants. The type may be 14010 -- a private type with unknown discriminants whose full view has 14011 -- discriminants which are invisible. 14012 14013 elsif not Has_Discriminants (T) 14014 or else 14015 (Has_Unknown_Discriminants (T) 14016 and then Is_Private_Type (T)) 14017 then 14018 Error_Msg_N ("invalid constraint: type has no discriminant", C); 14019 Fixup_Bad_Constraint; 14020 return; 14021 14022 elsif Is_Constrained (E) 14023 or else (Ekind (E) = E_Class_Wide_Subtype 14024 and then Present (Discriminant_Constraint (E))) 14025 then 14026 Error_Msg_N ("type is already constrained", Subtype_Mark (S)); 14027 Fixup_Bad_Constraint; 14028 return; 14029 end if; 14030 14031 -- T may be an unconstrained subtype (e.g. a generic actual). Constraint 14032 -- applies to the base type. 14033 14034 T := Base_Type (T); 14035 14036 Constr := Build_Discriminant_Constraints (T, S); 14037 14038 -- If the list returned was empty we had an error in building the 14039 -- discriminant constraint. We have also already signalled an error 14040 -- in the incomplete type case 14041 14042 if Is_Empty_Elmt_List (Constr) then 14043 Fixup_Bad_Constraint; 14044 return; 14045 end if; 14046 14047 Build_Discriminated_Subtype (T, Def_Id, Constr, Related_Nod, For_Access); 14048 end Constrain_Discriminated_Type; 14049 14050 --------------------------- 14051 -- Constrain_Enumeration -- 14052 --------------------------- 14053 14054 procedure Constrain_Enumeration (Def_Id : Entity_Id; S : Node_Id) is 14055 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14056 C : constant Node_Id := Constraint (S); 14057 14058 begin 14059 Set_Ekind (Def_Id, E_Enumeration_Subtype); 14060 14061 Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); 14062 14063 Set_Etype (Def_Id, Base_Type (T)); 14064 Set_Size_Info (Def_Id, (T)); 14065 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14066 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 14067 14068 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 14069 14070 Set_Discrete_RM_Size (Def_Id); 14071 end Constrain_Enumeration; 14072 14073 ---------------------- 14074 -- Constrain_Float -- 14075 ---------------------- 14076 14077 procedure Constrain_Float (Def_Id : Entity_Id; S : Node_Id) is 14078 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14079 C : Node_Id; 14080 D : Node_Id; 14081 Rais : Node_Id; 14082 14083 begin 14084 Set_Ekind (Def_Id, E_Floating_Point_Subtype); 14085 14086 Set_Etype (Def_Id, Base_Type (T)); 14087 Set_Size_Info (Def_Id, (T)); 14088 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14089 14090 -- Process the constraint 14091 14092 C := Constraint (S); 14093 14094 -- Digits constraint present 14095 14096 if Nkind (C) = N_Digits_Constraint then 14097 Check_Restriction (No_Obsolescent_Features, C); 14098 14099 if Warn_On_Obsolescent_Feature then 14100 Error_Msg_N 14101 ("subtype digits constraint is an " & 14102 "obsolescent feature (RM J.3(8))?j?", C); 14103 end if; 14104 14105 D := Digits_Expression (C); 14106 Analyze_And_Resolve (D, Any_Integer); 14107 Check_Digits_Expression (D); 14108 Set_Digits_Value (Def_Id, Expr_Value (D)); 14109 14110 -- Check that digits value is in range. Obviously we can do this 14111 -- at compile time, but it is strictly a runtime check, and of 14112 -- course there is an ACVC test that checks this. 14113 14114 if Digits_Value (Def_Id) > Digits_Value (T) then 14115 Error_Msg_Uint_1 := Digits_Value (T); 14116 Error_Msg_N ("??digits value is too large, maximum is ^", D); 14117 Rais := 14118 Make_Raise_Constraint_Error (Sloc (D), 14119 Reason => CE_Range_Check_Failed); 14120 Insert_Action (Declaration_Node (Def_Id), Rais); 14121 end if; 14122 14123 C := Range_Constraint (C); 14124 14125 -- No digits constraint present 14126 14127 else 14128 Set_Digits_Value (Def_Id, Digits_Value (T)); 14129 end if; 14130 14131 -- Range constraint present 14132 14133 if Nkind (C) = N_Range_Constraint then 14134 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 14135 14136 -- No range constraint present 14137 14138 else 14139 pragma Assert (No (C)); 14140 Set_Scalar_Range (Def_Id, Scalar_Range (T)); 14141 end if; 14142 14143 Set_Is_Constrained (Def_Id); 14144 end Constrain_Float; 14145 14146 --------------------- 14147 -- Constrain_Index -- 14148 --------------------- 14149 14150 procedure Constrain_Index 14151 (Index : Node_Id; 14152 S : Node_Id; 14153 Related_Nod : Node_Id; 14154 Related_Id : Entity_Id; 14155 Suffix : Character; 14156 Suffix_Index : Pos) 14157 is 14158 Def_Id : Entity_Id; 14159 R : Node_Id := Empty; 14160 T : constant Entity_Id := Etype (Index); 14161 14162 begin 14163 Def_Id := 14164 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index); 14165 Set_Etype (Def_Id, Base_Type (T)); 14166 14167 if Nkind (S) = N_Range 14168 or else 14169 (Nkind (S) = N_Attribute_Reference 14170 and then Attribute_Name (S) = Name_Range) 14171 then 14172 -- A Range attribute will be transformed into N_Range by Resolve 14173 14174 Analyze (S); 14175 Set_Etype (S, T); 14176 R := S; 14177 14178 Process_Range_Expr_In_Decl (R, T); 14179 14180 if not Error_Posted (S) 14181 and then 14182 (Nkind (S) /= N_Range 14183 or else not Covers (T, (Etype (Low_Bound (S)))) 14184 or else not Covers (T, (Etype (High_Bound (S))))) 14185 then 14186 if Base_Type (T) /= Any_Type 14187 and then Etype (Low_Bound (S)) /= Any_Type 14188 and then Etype (High_Bound (S)) /= Any_Type 14189 then 14190 Error_Msg_N ("range expected", S); 14191 end if; 14192 end if; 14193 14194 elsif Nkind (S) = N_Subtype_Indication then 14195 14196 -- The parser has verified that this is a discrete indication 14197 14198 Resolve_Discrete_Subtype_Indication (S, T); 14199 Bad_Predicated_Subtype_Use 14200 ("subtype& has predicate, not allowed in index constraint", 14201 S, Entity (Subtype_Mark (S))); 14202 14203 R := Range_Expression (Constraint (S)); 14204 14205 -- Capture values of bounds and generate temporaries for them if 14206 -- needed, since checks may cause duplication of the expressions 14207 -- which must not be reevaluated. 14208 14209 -- The forced evaluation removes side effects from expressions, which 14210 -- should occur also in GNATprove mode. Otherwise, we end up with 14211 -- unexpected insertions of actions at places where this is not 14212 -- supposed to occur, e.g. on default parameters of a call. 14213 14214 if Expander_Active or GNATprove_Mode then 14215 Force_Evaluation 14216 (Low_Bound (R), Related_Id => Def_Id, Is_Low_Bound => True); 14217 Force_Evaluation 14218 (High_Bound (R), Related_Id => Def_Id, Is_High_Bound => True); 14219 end if; 14220 14221 elsif Nkind (S) = N_Discriminant_Association then 14222 14223 -- Syntactically valid in subtype indication 14224 14225 Error_Msg_N ("invalid index constraint", S); 14226 Rewrite (S, New_Occurrence_Of (T, Sloc (S))); 14227 return; 14228 14229 -- Subtype_Mark case, no anonymous subtypes to construct 14230 14231 else 14232 Analyze (S); 14233 14234 if Is_Entity_Name (S) then 14235 if not Is_Type (Entity (S)) then 14236 Error_Msg_N ("expect subtype mark for index constraint", S); 14237 14238 elsif Base_Type (Entity (S)) /= Base_Type (T) then 14239 Wrong_Type (S, Base_Type (T)); 14240 14241 -- Check error of subtype with predicate in index constraint 14242 14243 else 14244 Bad_Predicated_Subtype_Use 14245 ("subtype& has predicate, not allowed in index constraint", 14246 S, Entity (S)); 14247 end if; 14248 14249 return; 14250 14251 else 14252 Error_Msg_N ("invalid index constraint", S); 14253 Rewrite (S, New_Occurrence_Of (T, Sloc (S))); 14254 return; 14255 end if; 14256 end if; 14257 14258 -- Complete construction of the Itype 14259 14260 if Is_Modular_Integer_Type (T) then 14261 Set_Ekind (Def_Id, E_Modular_Integer_Subtype); 14262 14263 elsif Is_Integer_Type (T) then 14264 Set_Ekind (Def_Id, E_Signed_Integer_Subtype); 14265 14266 else 14267 Set_Ekind (Def_Id, E_Enumeration_Subtype); 14268 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 14269 Set_First_Literal (Def_Id, First_Literal (T)); 14270 end if; 14271 14272 Set_Size_Info (Def_Id, (T)); 14273 Set_RM_Size (Def_Id, RM_Size (T)); 14274 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14275 14276 Set_Scalar_Range (Def_Id, R); 14277 14278 Set_Etype (S, Def_Id); 14279 Set_Discrete_RM_Size (Def_Id); 14280 end Constrain_Index; 14281 14282 ----------------------- 14283 -- Constrain_Integer -- 14284 ----------------------- 14285 14286 procedure Constrain_Integer (Def_Id : Entity_Id; S : Node_Id) is 14287 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14288 C : constant Node_Id := Constraint (S); 14289 14290 begin 14291 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 14292 14293 if Is_Modular_Integer_Type (T) then 14294 Set_Ekind (Def_Id, E_Modular_Integer_Subtype); 14295 else 14296 Set_Ekind (Def_Id, E_Signed_Integer_Subtype); 14297 end if; 14298 14299 Set_Etype (Def_Id, Base_Type (T)); 14300 Set_Size_Info (Def_Id, (T)); 14301 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14302 Set_Discrete_RM_Size (Def_Id); 14303 end Constrain_Integer; 14304 14305 ------------------------------ 14306 -- Constrain_Ordinary_Fixed -- 14307 ------------------------------ 14308 14309 procedure Constrain_Ordinary_Fixed (Def_Id : Entity_Id; S : Node_Id) is 14310 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14311 C : Node_Id; 14312 D : Node_Id; 14313 Rais : Node_Id; 14314 14315 begin 14316 Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); 14317 Set_Etype (Def_Id, Base_Type (T)); 14318 Set_Size_Info (Def_Id, (T)); 14319 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14320 Set_Small_Value (Def_Id, Small_Value (T)); 14321 14322 -- Process the constraint 14323 14324 C := Constraint (S); 14325 14326 -- Delta constraint present 14327 14328 if Nkind (C) = N_Delta_Constraint then 14329 Check_Restriction (No_Obsolescent_Features, C); 14330 14331 if Warn_On_Obsolescent_Feature then 14332 Error_Msg_S 14333 ("subtype delta constraint is an " & 14334 "obsolescent feature (RM J.3(7))?j?"); 14335 end if; 14336 14337 D := Delta_Expression (C); 14338 Analyze_And_Resolve (D, Any_Real); 14339 Check_Delta_Expression (D); 14340 Set_Delta_Value (Def_Id, Expr_Value_R (D)); 14341 14342 -- Check that delta value is in range. Obviously we can do this 14343 -- at compile time, but it is strictly a runtime check, and of 14344 -- course there is an ACVC test that checks this. 14345 14346 if Delta_Value (Def_Id) < Delta_Value (T) then 14347 Error_Msg_N ("??delta value is too small", D); 14348 Rais := 14349 Make_Raise_Constraint_Error (Sloc (D), 14350 Reason => CE_Range_Check_Failed); 14351 Insert_Action (Declaration_Node (Def_Id), Rais); 14352 end if; 14353 14354 C := Range_Constraint (C); 14355 14356 -- No delta constraint present 14357 14358 else 14359 Set_Delta_Value (Def_Id, Delta_Value (T)); 14360 end if; 14361 14362 -- Range constraint present 14363 14364 if Nkind (C) = N_Range_Constraint then 14365 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 14366 14367 -- No range constraint present 14368 14369 else 14370 pragma Assert (No (C)); 14371 Set_Scalar_Range (Def_Id, Scalar_Range (T)); 14372 end if; 14373 14374 Set_Discrete_RM_Size (Def_Id); 14375 14376 -- Unconditionally delay the freeze, since we cannot set size 14377 -- information in all cases correctly until the freeze point. 14378 14379 Set_Has_Delayed_Freeze (Def_Id); 14380 end Constrain_Ordinary_Fixed; 14381 14382 ----------------------- 14383 -- Contain_Interface -- 14384 ----------------------- 14385 14386 function Contain_Interface 14387 (Iface : Entity_Id; 14388 Ifaces : Elist_Id) return Boolean 14389 is 14390 Iface_Elmt : Elmt_Id; 14391 14392 begin 14393 if Present (Ifaces) then 14394 Iface_Elmt := First_Elmt (Ifaces); 14395 while Present (Iface_Elmt) loop 14396 if Node (Iface_Elmt) = Iface then 14397 return True; 14398 end if; 14399 14400 Next_Elmt (Iface_Elmt); 14401 end loop; 14402 end if; 14403 14404 return False; 14405 end Contain_Interface; 14406 14407 --------------------------- 14408 -- Convert_Scalar_Bounds -- 14409 --------------------------- 14410 14411 procedure Convert_Scalar_Bounds 14412 (N : Node_Id; 14413 Parent_Type : Entity_Id; 14414 Derived_Type : Entity_Id; 14415 Loc : Source_Ptr) 14416 is 14417 Implicit_Base : constant Entity_Id := Base_Type (Derived_Type); 14418 14419 Lo : Node_Id; 14420 Hi : Node_Id; 14421 Rng : Node_Id; 14422 14423 begin 14424 -- Defend against previous errors 14425 14426 if No (Scalar_Range (Derived_Type)) then 14427 Check_Error_Detected; 14428 return; 14429 end if; 14430 14431 Lo := Build_Scalar_Bound 14432 (Type_Low_Bound (Derived_Type), 14433 Parent_Type, Implicit_Base); 14434 14435 Hi := Build_Scalar_Bound 14436 (Type_High_Bound (Derived_Type), 14437 Parent_Type, Implicit_Base); 14438 14439 Rng := 14440 Make_Range (Loc, 14441 Low_Bound => Lo, 14442 High_Bound => Hi); 14443 14444 Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type)); 14445 14446 Set_Parent (Rng, N); 14447 Set_Scalar_Range (Derived_Type, Rng); 14448 14449 -- Analyze the bounds 14450 14451 Analyze_And_Resolve (Lo, Implicit_Base); 14452 Analyze_And_Resolve (Hi, Implicit_Base); 14453 14454 -- Analyze the range itself, except that we do not analyze it if 14455 -- the bounds are real literals, and we have a fixed-point type. 14456 -- The reason for this is that we delay setting the bounds in this 14457 -- case till we know the final Small and Size values (see circuit 14458 -- in Freeze.Freeze_Fixed_Point_Type for further details). 14459 14460 if Is_Fixed_Point_Type (Parent_Type) 14461 and then Nkind (Lo) = N_Real_Literal 14462 and then Nkind (Hi) = N_Real_Literal 14463 then 14464 return; 14465 14466 -- Here we do the analysis of the range 14467 14468 -- Note: we do this manually, since if we do a normal Analyze and 14469 -- Resolve call, there are problems with the conversions used for 14470 -- the derived type range. 14471 14472 else 14473 Set_Etype (Rng, Implicit_Base); 14474 Set_Analyzed (Rng, True); 14475 end if; 14476 end Convert_Scalar_Bounds; 14477 14478 ------------------- 14479 -- Copy_And_Swap -- 14480 ------------------- 14481 14482 procedure Copy_And_Swap (Priv, Full : Entity_Id) is 14483 begin 14484 -- Initialize new full declaration entity by copying the pertinent 14485 -- fields of the corresponding private declaration entity. 14486 14487 -- We temporarily set Ekind to a value appropriate for a type to 14488 -- avoid assert failures in Einfo from checking for setting type 14489 -- attributes on something that is not a type. Ekind (Priv) is an 14490 -- appropriate choice, since it allowed the attributes to be set 14491 -- in the first place. This Ekind value will be modified later. 14492 14493 Set_Ekind (Full, Ekind (Priv)); 14494 14495 -- Also set Etype temporarily to Any_Type, again, in the absence 14496 -- of errors, it will be properly reset, and if there are errors, 14497 -- then we want a value of Any_Type to remain. 14498 14499 Set_Etype (Full, Any_Type); 14500 14501 -- Now start copying attributes 14502 14503 Set_Has_Discriminants (Full, Has_Discriminants (Priv)); 14504 14505 if Has_Discriminants (Full) then 14506 Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv)); 14507 Set_Stored_Constraint (Full, Stored_Constraint (Priv)); 14508 end if; 14509 14510 Set_First_Rep_Item (Full, First_Rep_Item (Priv)); 14511 Set_Homonym (Full, Homonym (Priv)); 14512 Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv)); 14513 Set_Is_Public (Full, Is_Public (Priv)); 14514 Set_Is_Pure (Full, Is_Pure (Priv)); 14515 Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); 14516 Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv)); 14517 Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); 14518 Set_Has_Pragma_Unreferenced_Objects 14519 (Full, Has_Pragma_Unreferenced_Objects 14520 (Priv)); 14521 14522 Conditional_Delay (Full, Priv); 14523 14524 if Is_Tagged_Type (Full) then 14525 Set_Direct_Primitive_Operations 14526 (Full, Direct_Primitive_Operations (Priv)); 14527 Set_No_Tagged_Streams_Pragma 14528 (Full, No_Tagged_Streams_Pragma (Priv)); 14529 14530 if Is_Base_Type (Priv) then 14531 Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); 14532 end if; 14533 end if; 14534 14535 Set_Is_Volatile (Full, Is_Volatile (Priv)); 14536 Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv)); 14537 Set_Scope (Full, Scope (Priv)); 14538 Set_Prev_Entity (Full, Prev_Entity (Priv)); 14539 Set_Next_Entity (Full, Next_Entity (Priv)); 14540 Set_First_Entity (Full, First_Entity (Priv)); 14541 Set_Last_Entity (Full, Last_Entity (Priv)); 14542 14543 -- If access types have been recorded for later handling, keep them in 14544 -- the full view so that they get handled when the full view freeze 14545 -- node is expanded. 14546 14547 if Present (Freeze_Node (Priv)) 14548 and then Present (Access_Types_To_Process (Freeze_Node (Priv))) 14549 then 14550 Ensure_Freeze_Node (Full); 14551 Set_Access_Types_To_Process 14552 (Freeze_Node (Full), 14553 Access_Types_To_Process (Freeze_Node (Priv))); 14554 end if; 14555 14556 -- Swap the two entities. Now Private is the full type entity and Full 14557 -- is the private one. They will be swapped back at the end of the 14558 -- private part. This swapping ensures that the entity that is visible 14559 -- in the private part is the full declaration. 14560 14561 Exchange_Entities (Priv, Full); 14562 Append_Entity (Full, Scope (Full)); 14563 end Copy_And_Swap; 14564 14565 ------------------------------------- 14566 -- Copy_Array_Base_Type_Attributes -- 14567 ------------------------------------- 14568 14569 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is 14570 begin 14571 Set_Component_Alignment (T1, Component_Alignment (T2)); 14572 Set_Component_Type (T1, Component_Type (T2)); 14573 Set_Component_Size (T1, Component_Size (T2)); 14574 Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); 14575 Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); 14576 Propagate_Concurrent_Flags (T1, T2); 14577 Set_Is_Packed (T1, Is_Packed (T2)); 14578 Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); 14579 Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2)); 14580 Set_Has_Independent_Components (T1, Has_Independent_Components (T2)); 14581 Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2)); 14582 end Copy_Array_Base_Type_Attributes; 14583 14584 ----------------------------------- 14585 -- Copy_Array_Subtype_Attributes -- 14586 ----------------------------------- 14587 14588 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is 14589 begin 14590 Set_Size_Info (T1, T2); 14591 14592 Set_First_Index (T1, First_Index (T2)); 14593 Set_Is_Aliased (T1, Is_Aliased (T2)); 14594 Set_Is_Atomic (T1, Is_Atomic (T2)); 14595 Set_Is_Independent (T1, Is_Independent (T2)); 14596 Set_Is_Volatile (T1, Is_Volatile (T2)); 14597 Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2)); 14598 Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); 14599 Set_Is_Constrained (T1, Is_Constrained (T2)); 14600 Set_Depends_On_Private (T1, Has_Private_Component (T2)); 14601 Inherit_Rep_Item_Chain (T1, T2); 14602 Set_Convention (T1, Convention (T2)); 14603 Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2)); 14604 Set_Is_Private_Composite (T1, Is_Private_Composite (T2)); 14605 Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2)); 14606 end Copy_Array_Subtype_Attributes; 14607 14608 ----------------------------------- 14609 -- Create_Constrained_Components -- 14610 ----------------------------------- 14611 14612 procedure Create_Constrained_Components 14613 (Subt : Entity_Id; 14614 Decl_Node : Node_Id; 14615 Typ : Entity_Id; 14616 Constraints : Elist_Id) 14617 is 14618 Loc : constant Source_Ptr := Sloc (Subt); 14619 Comp_List : constant Elist_Id := New_Elmt_List; 14620 Parent_Type : constant Entity_Id := Etype (Typ); 14621 Assoc_List : constant List_Id := New_List; 14622 14623 Discr_Val : Elmt_Id; 14624 Errors : Boolean; 14625 New_C : Entity_Id; 14626 Old_C : Entity_Id; 14627 Is_Static : Boolean := True; 14628 Is_Compile_Time_Known : Boolean := True; 14629 14630 procedure Collect_Fixed_Components (Typ : Entity_Id); 14631 -- Collect parent type components that do not appear in a variant part 14632 14633 procedure Create_All_Components; 14634 -- Iterate over Comp_List to create the components of the subtype 14635 14636 function Create_Component (Old_Compon : Entity_Id) return Entity_Id; 14637 -- Creates a new component from Old_Compon, copying all the fields from 14638 -- it, including its Etype, inserts the new component in the Subt entity 14639 -- chain and returns the new component. 14640 14641 function Is_Variant_Record (T : Entity_Id) return Boolean; 14642 -- If true, and discriminants are static, collect only components from 14643 -- variants selected by discriminant values. 14644 14645 ------------------------------ 14646 -- Collect_Fixed_Components -- 14647 ------------------------------ 14648 14649 procedure Collect_Fixed_Components (Typ : Entity_Id) is 14650 begin 14651 -- Build association list for discriminants, and find components of the 14652 -- variant part selected by the values of the discriminants. 14653 14654 Old_C := First_Discriminant (Typ); 14655 Discr_Val := First_Elmt (Constraints); 14656 while Present (Old_C) loop 14657 Append_To (Assoc_List, 14658 Make_Component_Association (Loc, 14659 Choices => New_List (New_Occurrence_Of (Old_C, Loc)), 14660 Expression => New_Copy (Node (Discr_Val)))); 14661 14662 Next_Elmt (Discr_Val); 14663 Next_Discriminant (Old_C); 14664 end loop; 14665 14666 -- The tag and the possible parent component are unconditionally in 14667 -- the subtype. 14668 14669 if Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 14670 Old_C := First_Component (Typ); 14671 while Present (Old_C) loop 14672 if Chars (Old_C) in Name_uTag | Name_uParent then 14673 Append_Elmt (Old_C, Comp_List); 14674 end if; 14675 14676 Next_Component (Old_C); 14677 end loop; 14678 end if; 14679 end Collect_Fixed_Components; 14680 14681 --------------------------- 14682 -- Create_All_Components -- 14683 --------------------------- 14684 14685 procedure Create_All_Components is 14686 Comp : Elmt_Id; 14687 14688 begin 14689 Comp := First_Elmt (Comp_List); 14690 while Present (Comp) loop 14691 Old_C := Node (Comp); 14692 New_C := Create_Component (Old_C); 14693 14694 Set_Etype 14695 (New_C, 14696 Constrain_Component_Type 14697 (Old_C, Subt, Decl_Node, Typ, Constraints)); 14698 Set_Is_Public (New_C, Is_Public (Subt)); 14699 14700 Next_Elmt (Comp); 14701 end loop; 14702 end Create_All_Components; 14703 14704 ---------------------- 14705 -- Create_Component -- 14706 ---------------------- 14707 14708 function Create_Component (Old_Compon : Entity_Id) return Entity_Id is 14709 New_Compon : constant Entity_Id := New_Copy (Old_Compon); 14710 14711 begin 14712 if Ekind (Old_Compon) = E_Discriminant 14713 and then Is_Completely_Hidden (Old_Compon) 14714 then 14715 -- This is a shadow discriminant created for a discriminant of 14716 -- the parent type, which needs to be present in the subtype. 14717 -- Give the shadow discriminant an internal name that cannot 14718 -- conflict with that of visible components. 14719 14720 Set_Chars (New_Compon, New_Internal_Name ('C')); 14721 end if; 14722 14723 -- Set the parent so we have a proper link for freezing etc. This is 14724 -- not a real parent pointer, since of course our parent does not own 14725 -- up to us and reference us, we are an illegitimate child of the 14726 -- original parent. 14727 14728 Set_Parent (New_Compon, Parent (Old_Compon)); 14729 14730 -- We do not want this node marked as Comes_From_Source, since 14731 -- otherwise it would get first class status and a separate cross- 14732 -- reference line would be generated. Illegitimate children do not 14733 -- rate such recognition. 14734 14735 Set_Comes_From_Source (New_Compon, False); 14736 14737 -- But it is a real entity, and a birth certificate must be properly 14738 -- registered by entering it into the entity list, and setting its 14739 -- scope to the given subtype. This turns out to be useful for the 14740 -- LLVM code generator, but that scope is not used otherwise. 14741 14742 Enter_Name (New_Compon); 14743 Set_Scope (New_Compon, Subt); 14744 14745 return New_Compon; 14746 end Create_Component; 14747 14748 ----------------------- 14749 -- Is_Variant_Record -- 14750 ----------------------- 14751 14752 function Is_Variant_Record (T : Entity_Id) return Boolean is 14753 begin 14754 return Nkind (Parent (T)) = N_Full_Type_Declaration 14755 and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition 14756 and then Present (Component_List (Type_Definition (Parent (T)))) 14757 and then 14758 Present 14759 (Variant_Part (Component_List (Type_Definition (Parent (T))))); 14760 end Is_Variant_Record; 14761 14762 -- Start of processing for Create_Constrained_Components 14763 14764 begin 14765 pragma Assert (Subt /= Base_Type (Subt)); 14766 pragma Assert (Typ = Base_Type (Typ)); 14767 14768 Set_First_Entity (Subt, Empty); 14769 Set_Last_Entity (Subt, Empty); 14770 14771 -- Check whether constraint is fully static, in which case we can 14772 -- optimize the list of components. 14773 14774 Discr_Val := First_Elmt (Constraints); 14775 while Present (Discr_Val) loop 14776 if not Is_OK_Static_Expression (Node (Discr_Val)) then 14777 Is_Static := False; 14778 14779 if not Compile_Time_Known_Value (Node (Discr_Val)) then 14780 Is_Compile_Time_Known := False; 14781 exit; 14782 end if; 14783 end if; 14784 14785 Next_Elmt (Discr_Val); 14786 end loop; 14787 14788 Set_Has_Static_Discriminants (Subt, Is_Static); 14789 14790 Push_Scope (Subt); 14791 14792 -- Inherit the discriminants of the parent type 14793 14794 Add_Discriminants : declare 14795 Num_Disc : Nat; 14796 Num_Gird : Nat; 14797 14798 begin 14799 Num_Disc := 0; 14800 Old_C := First_Discriminant (Typ); 14801 14802 while Present (Old_C) loop 14803 Num_Disc := Num_Disc + 1; 14804 New_C := Create_Component (Old_C); 14805 Set_Is_Public (New_C, Is_Public (Subt)); 14806 Next_Discriminant (Old_C); 14807 end loop; 14808 14809 -- For an untagged derived subtype, the number of discriminants may 14810 -- be smaller than the number of inherited discriminants, because 14811 -- several of them may be renamed by a single new discriminant or 14812 -- constrained. In this case, add the hidden discriminants back into 14813 -- the subtype, because they need to be present if the optimizer of 14814 -- the GCC 4.x back-end decides to break apart assignments between 14815 -- objects using the parent view into member-wise assignments. 14816 14817 Num_Gird := 0; 14818 14819 if Is_Derived_Type (Typ) 14820 and then not Is_Tagged_Type (Typ) 14821 then 14822 Old_C := First_Stored_Discriminant (Typ); 14823 14824 while Present (Old_C) loop 14825 Num_Gird := Num_Gird + 1; 14826 Next_Stored_Discriminant (Old_C); 14827 end loop; 14828 end if; 14829 14830 if Num_Gird > Num_Disc then 14831 14832 -- Find out multiple uses of new discriminants, and add hidden 14833 -- components for the extra renamed discriminants. We recognize 14834 -- multiple uses through the Corresponding_Discriminant of a 14835 -- new discriminant: if it constrains several old discriminants, 14836 -- this field points to the last one in the parent type. The 14837 -- stored discriminants of the derived type have the same name 14838 -- as those of the parent. 14839 14840 declare 14841 Constr : Elmt_Id; 14842 New_Discr : Entity_Id; 14843 Old_Discr : Entity_Id; 14844 14845 begin 14846 Constr := First_Elmt (Stored_Constraint (Typ)); 14847 Old_Discr := First_Stored_Discriminant (Typ); 14848 while Present (Constr) loop 14849 if Is_Entity_Name (Node (Constr)) 14850 and then Ekind (Entity (Node (Constr))) = E_Discriminant 14851 then 14852 New_Discr := Entity (Node (Constr)); 14853 14854 if Chars (Corresponding_Discriminant (New_Discr)) /= 14855 Chars (Old_Discr) 14856 then 14857 -- The new discriminant has been used to rename a 14858 -- subsequent old discriminant. Introduce a shadow 14859 -- component for the current old discriminant. 14860 14861 New_C := Create_Component (Old_Discr); 14862 Set_Original_Record_Component (New_C, Old_Discr); 14863 end if; 14864 14865 else 14866 -- The constraint has eliminated the old discriminant. 14867 -- Introduce a shadow component. 14868 14869 New_C := Create_Component (Old_Discr); 14870 Set_Original_Record_Component (New_C, Old_Discr); 14871 end if; 14872 14873 Next_Elmt (Constr); 14874 Next_Stored_Discriminant (Old_Discr); 14875 end loop; 14876 end; 14877 end if; 14878 end Add_Discriminants; 14879 14880 if Is_Compile_Time_Known 14881 and then Is_Variant_Record (Typ) 14882 then 14883 Collect_Fixed_Components (Typ); 14884 Gather_Components 14885 (Typ, 14886 Component_List (Type_Definition (Parent (Typ))), 14887 Governed_By => Assoc_List, 14888 Into => Comp_List, 14889 Report_Errors => Errors, 14890 Allow_Compile_Time => True); 14891 pragma Assert (not Errors or else Serious_Errors_Detected > 0); 14892 14893 Create_All_Components; 14894 14895 -- If the subtype declaration is created for a tagged type derivation 14896 -- with constraints, we retrieve the record definition of the parent 14897 -- type to select the components of the proper variant. 14898 14899 elsif Is_Compile_Time_Known 14900 and then Is_Tagged_Type (Typ) 14901 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 14902 and then 14903 Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition 14904 and then Is_Variant_Record (Parent_Type) 14905 then 14906 Collect_Fixed_Components (Typ); 14907 Gather_Components 14908 (Typ, 14909 Component_List (Type_Definition (Parent (Parent_Type))), 14910 Governed_By => Assoc_List, 14911 Into => Comp_List, 14912 Report_Errors => Errors, 14913 Allow_Compile_Time => True); 14914 14915 -- Note: previously there was a check at this point that no errors 14916 -- were detected. As a consequence of AI05-220 there may be an error 14917 -- if an inherited discriminant that controls a variant has a non- 14918 -- static constraint. 14919 14920 -- If the tagged derivation has a type extension, collect all the 14921 -- new relevant components therein via Gather_Components. 14922 14923 if Present (Record_Extension_Part (Type_Definition (Parent (Typ)))) 14924 then 14925 Gather_Components 14926 (Typ, 14927 Component_List 14928 (Record_Extension_Part (Type_Definition (Parent (Typ)))), 14929 Governed_By => Assoc_List, 14930 Into => Comp_List, 14931 Report_Errors => Errors, 14932 Allow_Compile_Time => True, 14933 Include_Interface_Tag => True); 14934 end if; 14935 14936 Create_All_Components; 14937 14938 else 14939 -- If discriminants are not static, or if this is a multi-level type 14940 -- extension, we have to include all components of the parent type. 14941 14942 Old_C := First_Component (Typ); 14943 while Present (Old_C) loop 14944 New_C := Create_Component (Old_C); 14945 14946 Set_Etype 14947 (New_C, 14948 Constrain_Component_Type 14949 (Old_C, Subt, Decl_Node, Typ, Constraints)); 14950 Set_Is_Public (New_C, Is_Public (Subt)); 14951 14952 Next_Component (Old_C); 14953 end loop; 14954 end if; 14955 14956 End_Scope; 14957 end Create_Constrained_Components; 14958 14959 ------------------------------------------ 14960 -- Decimal_Fixed_Point_Type_Declaration -- 14961 ------------------------------------------ 14962 14963 procedure Decimal_Fixed_Point_Type_Declaration 14964 (T : Entity_Id; 14965 Def : Node_Id) 14966 is 14967 Loc : constant Source_Ptr := Sloc (Def); 14968 Digs_Expr : constant Node_Id := Digits_Expression (Def); 14969 Delta_Expr : constant Node_Id := Delta_Expression (Def); 14970 Max_Digits : constant Nat := 14971 (if System_Max_Integer_Size = 128 then 38 else 18); 14972 -- Maximum number of digits that can be represented in an integer 14973 14974 Implicit_Base : Entity_Id; 14975 Digs_Val : Uint; 14976 Delta_Val : Ureal; 14977 Scale_Val : Uint; 14978 Bound_Val : Ureal; 14979 14980 begin 14981 Check_Restriction (No_Fixed_Point, Def); 14982 14983 -- Create implicit base type 14984 14985 Implicit_Base := 14986 Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B'); 14987 Set_Etype (Implicit_Base, Implicit_Base); 14988 14989 -- Analyze and process delta expression 14990 14991 Analyze_And_Resolve (Delta_Expr, Universal_Real); 14992 14993 Check_Delta_Expression (Delta_Expr); 14994 Delta_Val := Expr_Value_R (Delta_Expr); 14995 14996 -- Check delta is power of 10, and determine scale value from it 14997 14998 declare 14999 Val : Ureal; 15000 15001 begin 15002 Scale_Val := Uint_0; 15003 Val := Delta_Val; 15004 15005 if Val < Ureal_1 then 15006 while Val < Ureal_1 loop 15007 Val := Val * Ureal_10; 15008 Scale_Val := Scale_Val + 1; 15009 end loop; 15010 15011 if Scale_Val > Max_Digits then 15012 Error_Msg_Uint_1 := UI_From_Int (Max_Digits); 15013 Error_Msg_N ("scale exceeds maximum value of ^", Def); 15014 Scale_Val := UI_From_Int (Max_Digits); 15015 end if; 15016 15017 else 15018 while Val > Ureal_1 loop 15019 Val := Val / Ureal_10; 15020 Scale_Val := Scale_Val - 1; 15021 end loop; 15022 15023 if Scale_Val < -Max_Digits then 15024 Error_Msg_Uint_1 := UI_From_Int (-Max_Digits); 15025 Error_Msg_N ("scale is less than minimum value of ^", Def); 15026 Scale_Val := UI_From_Int (-Max_Digits); 15027 end if; 15028 end if; 15029 15030 if Val /= Ureal_1 then 15031 Error_Msg_N ("delta expression must be a power of 10", Def); 15032 Delta_Val := Ureal_10 ** (-Scale_Val); 15033 end if; 15034 end; 15035 15036 -- Set delta, scale and small (small = delta for decimal type) 15037 15038 Set_Delta_Value (Implicit_Base, Delta_Val); 15039 Set_Scale_Value (Implicit_Base, Scale_Val); 15040 Set_Small_Value (Implicit_Base, Delta_Val); 15041 15042 -- Analyze and process digits expression 15043 15044 Analyze_And_Resolve (Digs_Expr, Any_Integer); 15045 Check_Digits_Expression (Digs_Expr); 15046 Digs_Val := Expr_Value (Digs_Expr); 15047 15048 if Digs_Val > Max_Digits then 15049 Error_Msg_Uint_1 := UI_From_Int (Max_Digits); 15050 Error_Msg_N ("digits value out of range, maximum is ^", Digs_Expr); 15051 Digs_Val := UI_From_Int (Max_Digits); 15052 end if; 15053 15054 Set_Digits_Value (Implicit_Base, Digs_Val); 15055 Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val; 15056 15057 -- Set range of base type from digits value for now. This will be 15058 -- expanded to represent the true underlying base range by Freeze. 15059 15060 Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); 15061 15062 -- Note: We leave size as zero for now, size will be set at freeze 15063 -- time. We have to do this for ordinary fixed-point, because the size 15064 -- depends on the specified small, and we might as well do the same for 15065 -- decimal fixed-point. 15066 15067 pragma Assert (Esize (Implicit_Base) = Uint_0); 15068 15069 -- If there are bounds given in the declaration use them as the 15070 -- bounds of the first named subtype. 15071 15072 if Present (Real_Range_Specification (Def)) then 15073 declare 15074 RRS : constant Node_Id := Real_Range_Specification (Def); 15075 Low : constant Node_Id := Low_Bound (RRS); 15076 High : constant Node_Id := High_Bound (RRS); 15077 Low_Val : Ureal; 15078 High_Val : Ureal; 15079 15080 begin 15081 Analyze_And_Resolve (Low, Any_Real); 15082 Analyze_And_Resolve (High, Any_Real); 15083 Check_Real_Bound (Low); 15084 Check_Real_Bound (High); 15085 Low_Val := Expr_Value_R (Low); 15086 High_Val := Expr_Value_R (High); 15087 15088 if Low_Val < (-Bound_Val) then 15089 Error_Msg_N 15090 ("range low bound too small for digits value", Low); 15091 Low_Val := -Bound_Val; 15092 end if; 15093 15094 if High_Val > Bound_Val then 15095 Error_Msg_N 15096 ("range high bound too large for digits value", High); 15097 High_Val := Bound_Val; 15098 end if; 15099 15100 Set_Fixed_Range (T, Loc, Low_Val, High_Val); 15101 end; 15102 15103 -- If no explicit range, use range that corresponds to given 15104 -- digits value. This will end up as the final range for the 15105 -- first subtype. 15106 15107 else 15108 Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val); 15109 end if; 15110 15111 -- Complete entity for first subtype. The inheritance of the rep item 15112 -- chain ensures that SPARK-related pragmas are not clobbered when the 15113 -- decimal fixed point type acts as a full view of a private type. 15114 15115 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); 15116 Set_Etype (T, Implicit_Base); 15117 Set_Size_Info (T, Implicit_Base); 15118 Inherit_Rep_Item_Chain (T, Implicit_Base); 15119 Set_Digits_Value (T, Digs_Val); 15120 Set_Delta_Value (T, Delta_Val); 15121 Set_Small_Value (T, Delta_Val); 15122 Set_Scale_Value (T, Scale_Val); 15123 Set_Is_Constrained (T); 15124 end Decimal_Fixed_Point_Type_Declaration; 15125 15126 ----------------------------------- 15127 -- Derive_Progenitor_Subprograms -- 15128 ----------------------------------- 15129 15130 procedure Derive_Progenitor_Subprograms 15131 (Parent_Type : Entity_Id; 15132 Tagged_Type : Entity_Id) 15133 is 15134 E : Entity_Id; 15135 Elmt : Elmt_Id; 15136 Iface : Entity_Id; 15137 Iface_Alias : Entity_Id; 15138 Iface_Elmt : Elmt_Id; 15139 Iface_Subp : Entity_Id; 15140 New_Subp : Entity_Id := Empty; 15141 Prim_Elmt : Elmt_Id; 15142 Subp : Entity_Id; 15143 Typ : Entity_Id; 15144 15145 begin 15146 pragma Assert (Ada_Version >= Ada_2005 15147 and then Is_Record_Type (Tagged_Type) 15148 and then Is_Tagged_Type (Tagged_Type) 15149 and then Has_Interfaces (Tagged_Type)); 15150 15151 -- Step 1: Transfer to the full-view primitives associated with the 15152 -- partial-view that cover interface primitives. Conceptually this 15153 -- work should be done later by Process_Full_View; done here to 15154 -- simplify its implementation at later stages. It can be safely 15155 -- done here because interfaces must be visible in the partial and 15156 -- private view (RM 7.3(7.3/2)). 15157 15158 -- Small optimization: This work is only required if the parent may 15159 -- have entities whose Alias attribute reference an interface primitive. 15160 -- Such a situation may occur if the parent is an abstract type and the 15161 -- primitive has not been yet overridden or if the parent is a generic 15162 -- formal type covering interfaces. 15163 15164 -- If the tagged type is not abstract, it cannot have abstract 15165 -- primitives (the only entities in the list of primitives of 15166 -- non-abstract tagged types that can reference abstract primitives 15167 -- through its Alias attribute are the internal entities that have 15168 -- attribute Interface_Alias, and these entities are generated later 15169 -- by Add_Internal_Interface_Entities). 15170 15171 if In_Private_Part (Current_Scope) 15172 and then (Is_Abstract_Type (Parent_Type) 15173 or else 15174 Is_Generic_Type (Parent_Type)) 15175 then 15176 Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); 15177 while Present (Elmt) loop 15178 Subp := Node (Elmt); 15179 15180 -- At this stage it is not possible to have entities in the list 15181 -- of primitives that have attribute Interface_Alias. 15182 15183 pragma Assert (No (Interface_Alias (Subp))); 15184 15185 Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); 15186 15187 if Is_Interface (Typ) then 15188 E := Find_Primitive_Covering_Interface 15189 (Tagged_Type => Tagged_Type, 15190 Iface_Prim => Subp); 15191 15192 if Present (E) 15193 and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ 15194 then 15195 Replace_Elmt (Elmt, E); 15196 Remove_Homonym (Subp); 15197 end if; 15198 end if; 15199 15200 Next_Elmt (Elmt); 15201 end loop; 15202 end if; 15203 15204 -- Step 2: Add primitives of progenitors that are not implemented by 15205 -- parents of Tagged_Type. 15206 15207 if Present (Interfaces (Base_Type (Tagged_Type))) then 15208 Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type))); 15209 while Present (Iface_Elmt) loop 15210 Iface := Node (Iface_Elmt); 15211 15212 Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); 15213 while Present (Prim_Elmt) loop 15214 Iface_Subp := Node (Prim_Elmt); 15215 Iface_Alias := Ultimate_Alias (Iface_Subp); 15216 15217 -- Exclude derivation of predefined primitives except those 15218 -- that come from source, or are inherited from one that comes 15219 -- from source. Required to catch declarations of equality 15220 -- operators of interfaces. For example: 15221 15222 -- type Iface is interface; 15223 -- function "=" (Left, Right : Iface) return Boolean; 15224 15225 if not Is_Predefined_Dispatching_Operation (Iface_Subp) 15226 or else Comes_From_Source (Iface_Alias) 15227 then 15228 E := 15229 Find_Primitive_Covering_Interface 15230 (Tagged_Type => Tagged_Type, 15231 Iface_Prim => Iface_Subp); 15232 15233 -- If not found we derive a new primitive leaving its alias 15234 -- attribute referencing the interface primitive. 15235 15236 if No (E) then 15237 Derive_Subprogram 15238 (New_Subp, Iface_Subp, Tagged_Type, Iface); 15239 15240 -- Ada 2012 (AI05-0197): If the covering primitive's name 15241 -- differs from the name of the interface primitive then it 15242 -- is a private primitive inherited from a parent type. In 15243 -- such case, given that Tagged_Type covers the interface, 15244 -- the inherited private primitive becomes visible. For such 15245 -- purpose we add a new entity that renames the inherited 15246 -- private primitive. 15247 15248 elsif Chars (E) /= Chars (Iface_Subp) then 15249 pragma Assert (Has_Suffix (E, 'P')); 15250 Derive_Subprogram 15251 (New_Subp, Iface_Subp, Tagged_Type, Iface); 15252 Set_Alias (New_Subp, E); 15253 Set_Is_Abstract_Subprogram (New_Subp, 15254 Is_Abstract_Subprogram (E)); 15255 15256 -- Propagate to the full view interface entities associated 15257 -- with the partial view. 15258 15259 elsif In_Private_Part (Current_Scope) 15260 and then Present (Alias (E)) 15261 and then Alias (E) = Iface_Subp 15262 and then 15263 List_Containing (Parent (E)) /= 15264 Private_Declarations 15265 (Specification 15266 (Unit_Declaration_Node (Current_Scope))) 15267 then 15268 Append_Elmt (E, Primitive_Operations (Tagged_Type)); 15269 end if; 15270 end if; 15271 15272 Next_Elmt (Prim_Elmt); 15273 end loop; 15274 15275 Next_Elmt (Iface_Elmt); 15276 end loop; 15277 end if; 15278 end Derive_Progenitor_Subprograms; 15279 15280 ----------------------- 15281 -- Derive_Subprogram -- 15282 ----------------------- 15283 15284 procedure Derive_Subprogram 15285 (New_Subp : out Entity_Id; 15286 Parent_Subp : Entity_Id; 15287 Derived_Type : Entity_Id; 15288 Parent_Type : Entity_Id; 15289 Actual_Subp : Entity_Id := Empty) 15290 is 15291 Formal : Entity_Id; 15292 -- Formal parameter of parent primitive operation 15293 15294 Formal_Of_Actual : Entity_Id; 15295 -- Formal parameter of actual operation, when the derivation is to 15296 -- create a renaming for a primitive operation of an actual in an 15297 -- instantiation. 15298 15299 New_Formal : Entity_Id; 15300 -- Formal of inherited operation 15301 15302 Visible_Subp : Entity_Id := Parent_Subp; 15303 15304 function Is_Private_Overriding return Boolean; 15305 -- If Subp is a private overriding of a visible operation, the inherited 15306 -- operation derives from the overridden op (even though its body is the 15307 -- overriding one) and the inherited operation is visible now. See 15308 -- sem_disp to see the full details of the handling of the overridden 15309 -- subprogram, which is removed from the list of primitive operations of 15310 -- the type. The overridden subprogram is saved locally in Visible_Subp, 15311 -- and used to diagnose abstract operations that need overriding in the 15312 -- derived type. 15313 15314 procedure Replace_Type (Id, New_Id : Entity_Id); 15315 -- When the type is an anonymous access type, create a new access type 15316 -- designating the derived type. 15317 15318 procedure Set_Derived_Name; 15319 -- This procedure sets the appropriate Chars name for New_Subp. This 15320 -- is normally just a copy of the parent name. An exception arises for 15321 -- type support subprograms, where the name is changed to reflect the 15322 -- name of the derived type, e.g. if type foo is derived from type bar, 15323 -- then a procedure barDA is derived with a name fooDA. 15324 15325 --------------------------- 15326 -- Is_Private_Overriding -- 15327 --------------------------- 15328 15329 function Is_Private_Overriding return Boolean is 15330 Prev : Entity_Id; 15331 15332 begin 15333 -- If the parent is not a dispatching operation there is no 15334 -- need to investigate overridings 15335 15336 if not Is_Dispatching_Operation (Parent_Subp) then 15337 return False; 15338 end if; 15339 15340 -- The visible operation that is overridden is a homonym of the 15341 -- parent subprogram. We scan the homonym chain to find the one 15342 -- whose alias is the subprogram we are deriving. 15343 15344 Prev := Current_Entity (Parent_Subp); 15345 while Present (Prev) loop 15346 if Ekind (Prev) = Ekind (Parent_Subp) 15347 and then Alias (Prev) = Parent_Subp 15348 and then Scope (Parent_Subp) = Scope (Prev) 15349 and then not Is_Hidden (Prev) 15350 then 15351 Visible_Subp := Prev; 15352 return True; 15353 end if; 15354 15355 Prev := Homonym (Prev); 15356 end loop; 15357 15358 return False; 15359 end Is_Private_Overriding; 15360 15361 ------------------ 15362 -- Replace_Type -- 15363 ------------------ 15364 15365 procedure Replace_Type (Id, New_Id : Entity_Id) is 15366 Id_Type : constant Entity_Id := Etype (Id); 15367 Acc_Type : Entity_Id; 15368 Par : constant Node_Id := Parent (Derived_Type); 15369 15370 begin 15371 -- When the type is an anonymous access type, create a new access 15372 -- type designating the derived type. This itype must be elaborated 15373 -- at the point of the derivation, not on subsequent calls that may 15374 -- be out of the proper scope for Gigi, so we insert a reference to 15375 -- it after the derivation. 15376 15377 if Ekind (Id_Type) = E_Anonymous_Access_Type then 15378 declare 15379 Desig_Typ : Entity_Id := Designated_Type (Id_Type); 15380 15381 begin 15382 if Ekind (Desig_Typ) = E_Record_Type_With_Private 15383 and then Present (Full_View (Desig_Typ)) 15384 and then not Is_Private_Type (Parent_Type) 15385 then 15386 Desig_Typ := Full_View (Desig_Typ); 15387 end if; 15388 15389 if Base_Type (Desig_Typ) = Base_Type (Parent_Type) 15390 15391 -- Ada 2005 (AI-251): Handle also derivations of abstract 15392 -- interface primitives. 15393 15394 or else (Is_Interface (Desig_Typ) 15395 and then not Is_Class_Wide_Type (Desig_Typ)) 15396 then 15397 Acc_Type := New_Copy (Id_Type); 15398 Set_Etype (Acc_Type, Acc_Type); 15399 Set_Scope (Acc_Type, New_Subp); 15400 15401 -- Set size of anonymous access type. If we have an access 15402 -- to an unconstrained array, this is a fat pointer, so it 15403 -- is sizes at twice addtress size. 15404 15405 if Is_Array_Type (Desig_Typ) 15406 and then not Is_Constrained (Desig_Typ) 15407 then 15408 Init_Size (Acc_Type, 2 * System_Address_Size); 15409 15410 -- Other cases use a thin pointer 15411 15412 else 15413 Init_Size (Acc_Type, System_Address_Size); 15414 end if; 15415 15416 -- Set remaining characterstics of anonymous access type 15417 15418 Init_Alignment (Acc_Type); 15419 Set_Directly_Designated_Type (Acc_Type, Derived_Type); 15420 15421 Set_Etype (New_Id, Acc_Type); 15422 Set_Scope (New_Id, New_Subp); 15423 15424 -- Create a reference to it 15425 15426 Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); 15427 15428 else 15429 Set_Etype (New_Id, Id_Type); 15430 end if; 15431 end; 15432 15433 -- In Ada2012, a formal may have an incomplete type but the type 15434 -- derivation that inherits the primitive follows the full view. 15435 15436 elsif Base_Type (Id_Type) = Base_Type (Parent_Type) 15437 or else 15438 (Ekind (Id_Type) = E_Record_Type_With_Private 15439 and then Present (Full_View (Id_Type)) 15440 and then 15441 Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type)) 15442 or else 15443 (Ada_Version >= Ada_2012 15444 and then Ekind (Id_Type) = E_Incomplete_Type 15445 and then Full_View (Id_Type) = Parent_Type) 15446 then 15447 -- Constraint checks on formals are generated during expansion, 15448 -- based on the signature of the original subprogram. The bounds 15449 -- of the derived type are not relevant, and thus we can use 15450 -- the base type for the formals. However, the return type may be 15451 -- used in a context that requires that the proper static bounds 15452 -- be used (a case statement, for example) and for those cases 15453 -- we must use the derived type (first subtype), not its base. 15454 15455 -- If the derived_type_definition has no constraints, we know that 15456 -- the derived type has the same constraints as the first subtype 15457 -- of the parent, and we can also use it rather than its base, 15458 -- which can lead to more efficient code. 15459 15460 if Etype (Id) = Parent_Type then 15461 if Is_Scalar_Type (Parent_Type) 15462 and then 15463 Subtypes_Statically_Compatible (Parent_Type, Derived_Type) 15464 then 15465 Set_Etype (New_Id, Derived_Type); 15466 15467 elsif Nkind (Par) = N_Full_Type_Declaration 15468 and then 15469 Nkind (Type_Definition (Par)) = N_Derived_Type_Definition 15470 and then 15471 Is_Entity_Name 15472 (Subtype_Indication (Type_Definition (Par))) 15473 then 15474 Set_Etype (New_Id, Derived_Type); 15475 15476 else 15477 Set_Etype (New_Id, Base_Type (Derived_Type)); 15478 end if; 15479 15480 else 15481 Set_Etype (New_Id, Base_Type (Derived_Type)); 15482 end if; 15483 15484 else 15485 Set_Etype (New_Id, Etype (Id)); 15486 end if; 15487 end Replace_Type; 15488 15489 ---------------------- 15490 -- Set_Derived_Name -- 15491 ---------------------- 15492 15493 procedure Set_Derived_Name is 15494 Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp); 15495 begin 15496 if Nm = TSS_Null then 15497 Set_Chars (New_Subp, Chars (Parent_Subp)); 15498 else 15499 Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm)); 15500 end if; 15501 end Set_Derived_Name; 15502 15503 -- Start of processing for Derive_Subprogram 15504 15505 begin 15506 New_Subp := New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); 15507 Set_Ekind (New_Subp, Ekind (Parent_Subp)); 15508 15509 -- Check whether the inherited subprogram is a private operation that 15510 -- should be inherited but not yet made visible. Such subprograms can 15511 -- become visible at a later point (e.g., the private part of a public 15512 -- child unit) via Declare_Inherited_Private_Subprograms. If the 15513 -- following predicate is true, then this is not such a private 15514 -- operation and the subprogram simply inherits the name of the parent 15515 -- subprogram. Note the special check for the names of controlled 15516 -- operations, which are currently exempted from being inherited with 15517 -- a hidden name because they must be findable for generation of 15518 -- implicit run-time calls. 15519 15520 if not Is_Hidden (Parent_Subp) 15521 or else Is_Internal (Parent_Subp) 15522 or else Is_Private_Overriding 15523 or else Is_Internal_Name (Chars (Parent_Subp)) 15524 or else (Is_Controlled (Parent_Type) 15525 and then Chars (Parent_Subp) in Name_Adjust 15526 | Name_Finalize 15527 | Name_Initialize) 15528 then 15529 Set_Derived_Name; 15530 15531 -- An inherited dispatching equality will be overridden by an internally 15532 -- generated one, or by an explicit one, so preserve its name and thus 15533 -- its entry in the dispatch table. Otherwise, if Parent_Subp is a 15534 -- private operation it may become invisible if the full view has 15535 -- progenitors, and the dispatch table will be malformed. 15536 -- We check that the type is limited to handle the anomalous declaration 15537 -- of Limited_Controlled, which is derived from a non-limited type, and 15538 -- which is handled specially elsewhere as well. 15539 15540 elsif Chars (Parent_Subp) = Name_Op_Eq 15541 and then Is_Dispatching_Operation (Parent_Subp) 15542 and then Etype (Parent_Subp) = Standard_Boolean 15543 and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp))) 15544 and then 15545 Etype (First_Formal (Parent_Subp)) = 15546 Etype (Next_Formal (First_Formal (Parent_Subp))) 15547 then 15548 Set_Derived_Name; 15549 15550 -- If parent is hidden, this can be a regular derivation if the 15551 -- parent is immediately visible in a non-instantiating context, 15552 -- or if we are in the private part of an instance. This test 15553 -- should still be refined ??? 15554 15555 -- The test for In_Instance_Not_Visible avoids inheriting the derived 15556 -- operation as a non-visible operation in cases where the parent 15557 -- subprogram might not be visible now, but was visible within the 15558 -- original generic, so it would be wrong to make the inherited 15559 -- subprogram non-visible now. (Not clear if this test is fully 15560 -- correct; are there any cases where we should declare the inherited 15561 -- operation as not visible to avoid it being overridden, e.g., when 15562 -- the parent type is a generic actual with private primitives ???) 15563 15564 -- (they should be treated the same as other private inherited 15565 -- subprograms, but it's not clear how to do this cleanly). ??? 15566 15567 elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type))) 15568 and then Is_Immediately_Visible (Parent_Subp) 15569 and then not In_Instance) 15570 or else In_Instance_Not_Visible 15571 then 15572 Set_Derived_Name; 15573 15574 -- Ada 2005 (AI-251): Regular derivation if the parent subprogram 15575 -- overrides an interface primitive because interface primitives 15576 -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) 15577 15578 elsif Ada_Version >= Ada_2005 15579 and then Is_Dispatching_Operation (Parent_Subp) 15580 and then Present (Covered_Interface_Op (Parent_Subp)) 15581 then 15582 Set_Derived_Name; 15583 15584 -- Otherwise, the type is inheriting a private operation, so enter it 15585 -- with a special name so it can't be overridden. See also below, where 15586 -- we check for this case, and if so avoid setting Requires_Overriding. 15587 15588 else 15589 Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P')); 15590 end if; 15591 15592 Set_Parent (New_Subp, Parent (Derived_Type)); 15593 15594 if Present (Actual_Subp) then 15595 Replace_Type (Actual_Subp, New_Subp); 15596 else 15597 Replace_Type (Parent_Subp, New_Subp); 15598 end if; 15599 15600 Conditional_Delay (New_Subp, Parent_Subp); 15601 15602 -- If we are creating a renaming for a primitive operation of an 15603 -- actual of a generic derived type, we must examine the signature 15604 -- of the actual primitive, not that of the generic formal, which for 15605 -- example may be an interface. However the name and initial value 15606 -- of the inherited operation are those of the formal primitive. 15607 15608 Formal := First_Formal (Parent_Subp); 15609 15610 if Present (Actual_Subp) then 15611 Formal_Of_Actual := First_Formal (Actual_Subp); 15612 else 15613 Formal_Of_Actual := Empty; 15614 end if; 15615 15616 while Present (Formal) loop 15617 New_Formal := New_Copy (Formal); 15618 15619 -- Extra formals are not inherited from a limited interface parent 15620 -- since limitedness is not inherited in such case (AI-419) and this 15621 -- affects the extra formals. 15622 15623 if Is_Limited_Interface (Parent_Type) then 15624 Set_Extra_Formal (New_Formal, Empty); 15625 Set_Extra_Accessibility (New_Formal, Empty); 15626 end if; 15627 15628 -- Normally we do not go copying parents, but in the case of 15629 -- formals, we need to link up to the declaration (which is the 15630 -- parameter specification), and it is fine to link up to the 15631 -- original formal's parameter specification in this case. 15632 15633 Set_Parent (New_Formal, Parent (Formal)); 15634 Append_Entity (New_Formal, New_Subp); 15635 15636 if Present (Formal_Of_Actual) then 15637 Replace_Type (Formal_Of_Actual, New_Formal); 15638 Next_Formal (Formal_Of_Actual); 15639 else 15640 Replace_Type (Formal, New_Formal); 15641 end if; 15642 15643 Next_Formal (Formal); 15644 end loop; 15645 15646 -- Extra formals are shared between the parent subprogram and the 15647 -- derived subprogram (implicit in the above copy of formals), unless 15648 -- the parent type is a limited interface type; hence we must inherit 15649 -- also the reference to the first extra formal. When the parent type is 15650 -- an interface the extra formals will be added when the subprogram is 15651 -- frozen (see Freeze.Freeze_Subprogram). 15652 15653 if not Is_Limited_Interface (Parent_Type) then 15654 Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp)); 15655 15656 if Ekind (New_Subp) = E_Function then 15657 Set_Extra_Accessibility_Of_Result (New_Subp, 15658 Extra_Accessibility_Of_Result (Parent_Subp)); 15659 end if; 15660 end if; 15661 15662 -- If this derivation corresponds to a tagged generic actual, then 15663 -- primitive operations rename those of the actual. Otherwise the 15664 -- primitive operations rename those of the parent type, If the parent 15665 -- renames an intrinsic operator, so does the new subprogram. We except 15666 -- concatenation, which is always properly typed, and does not get 15667 -- expanded as other intrinsic operations. 15668 15669 if No (Actual_Subp) then 15670 if Is_Intrinsic_Subprogram (Parent_Subp) then 15671 Set_Is_Intrinsic_Subprogram (New_Subp); 15672 15673 if Present (Alias (Parent_Subp)) 15674 and then Chars (Parent_Subp) /= Name_Op_Concat 15675 then 15676 Set_Alias (New_Subp, Alias (Parent_Subp)); 15677 else 15678 Set_Alias (New_Subp, Parent_Subp); 15679 end if; 15680 15681 else 15682 Set_Alias (New_Subp, Parent_Subp); 15683 end if; 15684 15685 else 15686 Set_Alias (New_Subp, Actual_Subp); 15687 end if; 15688 15689 -- Derived subprograms of a tagged type must inherit the convention 15690 -- of the parent subprogram (a requirement of AI-117). Derived 15691 -- subprograms of untagged types simply get convention Ada by default. 15692 15693 -- If the derived type is a tagged generic formal type with unknown 15694 -- discriminants, its convention is intrinsic (RM 6.3.1 (8)). 15695 15696 -- However, if the type is derived from a generic formal, the further 15697 -- inherited subprogram has the convention of the non-generic ancestor. 15698 -- Otherwise there would be no way to override the operation. 15699 -- (This is subject to forthcoming ARG discussions). 15700 15701 if Is_Tagged_Type (Derived_Type) then 15702 if Is_Generic_Type (Derived_Type) 15703 and then Has_Unknown_Discriminants (Derived_Type) 15704 then 15705 Set_Convention (New_Subp, Convention_Intrinsic); 15706 15707 else 15708 if Is_Generic_Type (Parent_Type) 15709 and then Has_Unknown_Discriminants (Parent_Type) 15710 then 15711 Set_Convention (New_Subp, Convention (Alias (Parent_Subp))); 15712 else 15713 Set_Convention (New_Subp, Convention (Parent_Subp)); 15714 end if; 15715 end if; 15716 end if; 15717 15718 -- Predefined controlled operations retain their name even if the parent 15719 -- is hidden (see above), but they are not primitive operations if the 15720 -- ancestor is not visible, for example if the parent is a private 15721 -- extension completed with a controlled extension. Note that a full 15722 -- type that is controlled can break privacy: the flag Is_Controlled is 15723 -- set on both views of the type. 15724 15725 if Is_Controlled (Parent_Type) 15726 and then Chars (Parent_Subp) in Name_Initialize 15727 | Name_Adjust 15728 | Name_Finalize 15729 and then Is_Hidden (Parent_Subp) 15730 and then not Is_Visibly_Controlled (Parent_Type) 15731 then 15732 Set_Is_Hidden (New_Subp); 15733 end if; 15734 15735 Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp)); 15736 Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp)); 15737 15738 if Ekind (Parent_Subp) = E_Procedure then 15739 Set_Is_Valued_Procedure 15740 (New_Subp, Is_Valued_Procedure (Parent_Subp)); 15741 else 15742 Set_Has_Controlling_Result 15743 (New_Subp, Has_Controlling_Result (Parent_Subp)); 15744 end if; 15745 15746 -- No_Return must be inherited properly. If this is overridden in the 15747 -- case of a dispatching operation, then the check is made later in 15748 -- Check_Abstract_Overriding that the overriding operation is also 15749 -- No_Return (no such check is required for the nondispatching case). 15750 15751 Set_No_Return (New_Subp, No_Return (Parent_Subp)); 15752 15753 -- A derived function with a controlling result is abstract. If the 15754 -- Derived_Type is a nonabstract formal generic derived type, then 15755 -- inherited operations are not abstract: the required check is done at 15756 -- instantiation time. If the derivation is for a generic actual, the 15757 -- function is not abstract unless the actual is. 15758 15759 if Is_Generic_Type (Derived_Type) 15760 and then not Is_Abstract_Type (Derived_Type) 15761 then 15762 null; 15763 15764 -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" 15765 -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). Note 15766 -- that functions with controlling access results of record extensions 15767 -- with a null extension part require overriding (AI95-00391/06). 15768 15769 -- Ada 202x (AI12-0042): Similarly, set those properties for 15770 -- implementing the rule of RM 7.3.2(6.1/4). 15771 15772 -- A subprogram subject to pragma Extensions_Visible with value False 15773 -- requires overriding if the subprogram has at least one controlling 15774 -- OUT parameter (SPARK RM 6.1.7(6)). 15775 15776 elsif Ada_Version >= Ada_2005 15777 and then (Is_Abstract_Subprogram (Alias (New_Subp)) 15778 or else (Is_Tagged_Type (Derived_Type) 15779 and then Etype (New_Subp) = Derived_Type 15780 and then not Is_Null_Extension (Derived_Type)) 15781 or else (Is_Tagged_Type (Derived_Type) 15782 and then Ekind (Etype (New_Subp)) = 15783 E_Anonymous_Access_Type 15784 and then Designated_Type (Etype (New_Subp)) = 15785 Derived_Type) 15786 or else (Comes_From_Source (Alias (New_Subp)) 15787 and then Is_EVF_Procedure (Alias (New_Subp))) 15788 15789 -- AI12-0042: Set Requires_Overriding when a type extension 15790 -- inherits a private operation that is visible at the 15791 -- point of extension (Has_Private_Ancestor is False) from 15792 -- an ancestor that has Type_Invariant'Class, and when the 15793 -- type extension is in a visible part (the latter as 15794 -- clarified by AI12-0382). 15795 15796 or else 15797 (not Has_Private_Ancestor (Derived_Type) 15798 and then Has_Invariants (Parent_Type) 15799 and then 15800 Present (Get_Pragma (Parent_Type, Pragma_Invariant)) 15801 and then 15802 Class_Present 15803 (Get_Pragma (Parent_Type, Pragma_Invariant)) 15804 and then Is_Private_Primitive (Parent_Subp) 15805 and then In_Visible_Part (Scope (Derived_Type)))) 15806 15807 and then No (Actual_Subp) 15808 then 15809 if not Is_Tagged_Type (Derived_Type) 15810 or else Is_Abstract_Type (Derived_Type) 15811 or else Is_Abstract_Subprogram (Alias (New_Subp)) 15812 then 15813 Set_Is_Abstract_Subprogram (New_Subp); 15814 15815 -- If the Chars of the new subprogram is different from that of the 15816 -- parent's one, it means that we entered it with a special name so 15817 -- it can't be overridden (see above). In that case we had better not 15818 -- *require* it to be overridden. This is the case where the parent 15819 -- type inherited the operation privately, so there's no danger of 15820 -- dangling dispatching. 15821 15822 elsif Chars (New_Subp) = Chars (Alias (New_Subp)) then 15823 Set_Requires_Overriding (New_Subp); 15824 end if; 15825 15826 elsif Ada_Version < Ada_2005 15827 and then (Is_Abstract_Subprogram (Alias (New_Subp)) 15828 or else (Is_Tagged_Type (Derived_Type) 15829 and then Etype (New_Subp) = Derived_Type 15830 and then No (Actual_Subp))) 15831 then 15832 Set_Is_Abstract_Subprogram (New_Subp); 15833 15834 -- AI05-0097 : an inherited operation that dispatches on result is 15835 -- abstract if the derived type is abstract, even if the parent type 15836 -- is concrete and the derived type is a null extension. 15837 15838 elsif Has_Controlling_Result (Alias (New_Subp)) 15839 and then Is_Abstract_Type (Etype (New_Subp)) 15840 then 15841 Set_Is_Abstract_Subprogram (New_Subp); 15842 15843 -- Finally, if the parent type is abstract we must verify that all 15844 -- inherited operations are either non-abstract or overridden, or that 15845 -- the derived type itself is abstract (this check is performed at the 15846 -- end of a package declaration, in Check_Abstract_Overriding). A 15847 -- private overriding in the parent type will not be visible in the 15848 -- derivation if we are not in an inner package or in a child unit of 15849 -- the parent type, in which case the abstractness of the inherited 15850 -- operation is carried to the new subprogram. 15851 15852 elsif Is_Abstract_Type (Parent_Type) 15853 and then not In_Open_Scopes (Scope (Parent_Type)) 15854 and then Is_Private_Overriding 15855 and then Is_Abstract_Subprogram (Visible_Subp) 15856 then 15857 if No (Actual_Subp) then 15858 Set_Alias (New_Subp, Visible_Subp); 15859 Set_Is_Abstract_Subprogram (New_Subp, True); 15860 15861 else 15862 -- If this is a derivation for an instance of a formal derived 15863 -- type, abstractness comes from the primitive operation of the 15864 -- actual, not from the operation inherited from the ancestor. 15865 15866 Set_Is_Abstract_Subprogram 15867 (New_Subp, Is_Abstract_Subprogram (Actual_Subp)); 15868 end if; 15869 end if; 15870 15871 New_Overloaded_Entity (New_Subp, Derived_Type); 15872 15873 -- Ada RM 6.1.1 (15): If a subprogram inherits nonconforming class-wide 15874 -- preconditions and the derived type is abstract, the derived operation 15875 -- is abstract as well if parent subprogram is not abstract or null. 15876 15877 if Is_Abstract_Type (Derived_Type) 15878 and then Has_Non_Trivial_Precondition (Parent_Subp) 15879 and then Present (Interfaces (Derived_Type)) 15880 then 15881 15882 -- Add useful attributes of subprogram before the freeze point, 15883 -- in case freezing is delayed or there are previous errors. 15884 15885 Set_Is_Dispatching_Operation (New_Subp); 15886 15887 declare 15888 Iface_Prim : constant Entity_Id := Covered_Interface_Op (New_Subp); 15889 15890 begin 15891 if Present (Iface_Prim) 15892 and then Has_Non_Trivial_Precondition (Iface_Prim) 15893 then 15894 Set_Is_Abstract_Subprogram (New_Subp); 15895 end if; 15896 end; 15897 end if; 15898 15899 -- Check for case of a derived subprogram for the instantiation of a 15900 -- formal derived tagged type, if so mark the subprogram as dispatching 15901 -- and inherit the dispatching attributes of the actual subprogram. The 15902 -- derived subprogram is effectively renaming of the actual subprogram, 15903 -- so it needs to have the same attributes as the actual. 15904 15905 if Present (Actual_Subp) 15906 and then Is_Dispatching_Operation (Actual_Subp) 15907 then 15908 Set_Is_Dispatching_Operation (New_Subp); 15909 15910 if Present (DTC_Entity (Actual_Subp)) then 15911 Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp)); 15912 Set_DT_Position_Value (New_Subp, DT_Position (Actual_Subp)); 15913 end if; 15914 end if; 15915 15916 -- Indicate that a derived subprogram does not require a body and that 15917 -- it does not require processing of default expressions. 15918 15919 Set_Has_Completion (New_Subp); 15920 Set_Default_Expressions_Processed (New_Subp); 15921 15922 if Ekind (New_Subp) = E_Function then 15923 Set_Mechanism (New_Subp, Mechanism (Parent_Subp)); 15924 end if; 15925 15926 -- Ada 2020 (AI12-0279): If a Yield aspect is specified True for a 15927 -- primitive subprogram S of a type T, then the aspect is inherited 15928 -- by the corresponding primitive subprogram of each descendant of T. 15929 15930 if Is_Tagged_Type (Derived_Type) 15931 and then Is_Dispatching_Operation (New_Subp) 15932 and then Has_Yield_Aspect (Alias (New_Subp)) 15933 then 15934 Set_Has_Yield_Aspect (New_Subp, Has_Yield_Aspect (Alias (New_Subp))); 15935 end if; 15936 end Derive_Subprogram; 15937 15938 ------------------------ 15939 -- Derive_Subprograms -- 15940 ------------------------ 15941 15942 procedure Derive_Subprograms 15943 (Parent_Type : Entity_Id; 15944 Derived_Type : Entity_Id; 15945 Generic_Actual : Entity_Id := Empty) 15946 is 15947 Op_List : constant Elist_Id := 15948 Collect_Primitive_Operations (Parent_Type); 15949 15950 function Check_Derived_Type return Boolean; 15951 -- Check that all the entities derived from Parent_Type are found in 15952 -- the list of primitives of Derived_Type exactly in the same order. 15953 15954 procedure Derive_Interface_Subprogram 15955 (New_Subp : out Entity_Id; 15956 Subp : Entity_Id; 15957 Actual_Subp : Entity_Id); 15958 -- Derive New_Subp from the ultimate alias of the parent subprogram Subp 15959 -- (which is an interface primitive). If Generic_Actual is present then 15960 -- Actual_Subp is the actual subprogram corresponding with the generic 15961 -- subprogram Subp. 15962 15963 ------------------------ 15964 -- Check_Derived_Type -- 15965 ------------------------ 15966 15967 function Check_Derived_Type return Boolean is 15968 E : Entity_Id; 15969 Elmt : Elmt_Id; 15970 List : Elist_Id; 15971 New_Subp : Entity_Id; 15972 Op_Elmt : Elmt_Id; 15973 Subp : Entity_Id; 15974 15975 begin 15976 -- Traverse list of entities in the current scope searching for 15977 -- an incomplete type whose full-view is derived type. 15978 15979 E := First_Entity (Scope (Derived_Type)); 15980 while Present (E) and then E /= Derived_Type loop 15981 if Ekind (E) = E_Incomplete_Type 15982 and then Present (Full_View (E)) 15983 and then Full_View (E) = Derived_Type 15984 then 15985 -- Disable this test if Derived_Type completes an incomplete 15986 -- type because in such case more primitives can be added 15987 -- later to the list of primitives of Derived_Type by routine 15988 -- Process_Incomplete_Dependents 15989 15990 return True; 15991 end if; 15992 15993 Next_Entity (E); 15994 end loop; 15995 15996 List := Collect_Primitive_Operations (Derived_Type); 15997 Elmt := First_Elmt (List); 15998 15999 Op_Elmt := First_Elmt (Op_List); 16000 while Present (Op_Elmt) loop 16001 Subp := Node (Op_Elmt); 16002 New_Subp := Node (Elmt); 16003 16004 -- At this early stage Derived_Type has no entities with attribute 16005 -- Interface_Alias. In addition, such primitives are always 16006 -- located at the end of the list of primitives of Parent_Type. 16007 -- Therefore, if found we can safely stop processing pending 16008 -- entities. 16009 16010 exit when Present (Interface_Alias (Subp)); 16011 16012 -- Handle hidden entities 16013 16014 if not Is_Predefined_Dispatching_Operation (Subp) 16015 and then Is_Hidden (Subp) 16016 then 16017 if Present (New_Subp) 16018 and then Primitive_Names_Match (Subp, New_Subp) 16019 then 16020 Next_Elmt (Elmt); 16021 end if; 16022 16023 else 16024 if not Present (New_Subp) 16025 or else Ekind (Subp) /= Ekind (New_Subp) 16026 or else not Primitive_Names_Match (Subp, New_Subp) 16027 then 16028 return False; 16029 end if; 16030 16031 Next_Elmt (Elmt); 16032 end if; 16033 16034 Next_Elmt (Op_Elmt); 16035 end loop; 16036 16037 return True; 16038 end Check_Derived_Type; 16039 16040 --------------------------------- 16041 -- Derive_Interface_Subprogram -- 16042 --------------------------------- 16043 16044 procedure Derive_Interface_Subprogram 16045 (New_Subp : out Entity_Id; 16046 Subp : Entity_Id; 16047 Actual_Subp : Entity_Id) 16048 is 16049 Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp); 16050 Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp); 16051 16052 begin 16053 pragma Assert (Is_Interface (Iface_Type)); 16054 16055 Derive_Subprogram 16056 (New_Subp => New_Subp, 16057 Parent_Subp => Iface_Subp, 16058 Derived_Type => Derived_Type, 16059 Parent_Type => Iface_Type, 16060 Actual_Subp => Actual_Subp); 16061 16062 -- Given that this new interface entity corresponds with a primitive 16063 -- of the parent that was not overridden we must leave it associated 16064 -- with its parent primitive to ensure that it will share the same 16065 -- dispatch table slot when overridden. We must set the Alias to Subp 16066 -- (instead of Iface_Subp), and we must fix Is_Abstract_Subprogram 16067 -- (in case we inherited Subp from Iface_Type via a nonabstract 16068 -- generic formal type). 16069 16070 if No (Actual_Subp) then 16071 Set_Alias (New_Subp, Subp); 16072 16073 declare 16074 T : Entity_Id := Find_Dispatching_Type (Subp); 16075 begin 16076 while Etype (T) /= T loop 16077 if Is_Generic_Type (T) and then not Is_Abstract_Type (T) then 16078 Set_Is_Abstract_Subprogram (New_Subp, False); 16079 exit; 16080 end if; 16081 16082 T := Etype (T); 16083 end loop; 16084 end; 16085 16086 -- For instantiations this is not needed since the previous call to 16087 -- Derive_Subprogram leaves the entity well decorated. 16088 16089 else 16090 pragma Assert (Alias (New_Subp) = Actual_Subp); 16091 null; 16092 end if; 16093 end Derive_Interface_Subprogram; 16094 16095 -- Local variables 16096 16097 Alias_Subp : Entity_Id; 16098 Act_List : Elist_Id; 16099 Act_Elmt : Elmt_Id; 16100 Act_Subp : Entity_Id := Empty; 16101 Elmt : Elmt_Id; 16102 Need_Search : Boolean := False; 16103 New_Subp : Entity_Id := Empty; 16104 Parent_Base : Entity_Id; 16105 Subp : Entity_Id; 16106 16107 -- Start of processing for Derive_Subprograms 16108 16109 begin 16110 if Ekind (Parent_Type) = E_Record_Type_With_Private 16111 and then Has_Discriminants (Parent_Type) 16112 and then Present (Full_View (Parent_Type)) 16113 then 16114 Parent_Base := Full_View (Parent_Type); 16115 else 16116 Parent_Base := Parent_Type; 16117 end if; 16118 16119 if Present (Generic_Actual) then 16120 Act_List := Collect_Primitive_Operations (Generic_Actual); 16121 Act_Elmt := First_Elmt (Act_List); 16122 else 16123 Act_List := No_Elist; 16124 Act_Elmt := No_Elmt; 16125 end if; 16126 16127 -- Derive primitives inherited from the parent. Note that if the generic 16128 -- actual is present, this is not really a type derivation, it is a 16129 -- completion within an instance. 16130 16131 -- Case 1: Derived_Type does not implement interfaces 16132 16133 if not Is_Tagged_Type (Derived_Type) 16134 or else (not Has_Interfaces (Derived_Type) 16135 and then not (Present (Generic_Actual) 16136 and then Has_Interfaces (Generic_Actual))) 16137 then 16138 Elmt := First_Elmt (Op_List); 16139 while Present (Elmt) loop 16140 Subp := Node (Elmt); 16141 16142 -- Literals are derived earlier in the process of building the 16143 -- derived type, and are skipped here. 16144 16145 if Ekind (Subp) = E_Enumeration_Literal then 16146 null; 16147 16148 -- The actual is a direct descendant and the common primitive 16149 -- operations appear in the same order. 16150 16151 -- If the generic parent type is present, the derived type is an 16152 -- instance of a formal derived type, and within the instance its 16153 -- operations are those of the actual. We derive from the formal 16154 -- type but make the inherited operations aliases of the 16155 -- corresponding operations of the actual. 16156 16157 else 16158 pragma Assert (No (Node (Act_Elmt)) 16159 or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) 16160 and then 16161 Type_Conformant 16162 (Subp, Node (Act_Elmt), 16163 Skip_Controlling_Formals => True))); 16164 16165 Derive_Subprogram 16166 (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); 16167 16168 if Present (Act_Elmt) then 16169 Next_Elmt (Act_Elmt); 16170 end if; 16171 end if; 16172 16173 Next_Elmt (Elmt); 16174 end loop; 16175 16176 -- Case 2: Derived_Type implements interfaces 16177 16178 else 16179 -- If the parent type has no predefined primitives we remove 16180 -- predefined primitives from the list of primitives of generic 16181 -- actual to simplify the complexity of this algorithm. 16182 16183 if Present (Generic_Actual) then 16184 declare 16185 Has_Predefined_Primitives : Boolean := False; 16186 16187 begin 16188 -- Check if the parent type has predefined primitives 16189 16190 Elmt := First_Elmt (Op_List); 16191 while Present (Elmt) loop 16192 Subp := Node (Elmt); 16193 16194 if Is_Predefined_Dispatching_Operation (Subp) 16195 and then not Comes_From_Source (Ultimate_Alias (Subp)) 16196 then 16197 Has_Predefined_Primitives := True; 16198 exit; 16199 end if; 16200 16201 Next_Elmt (Elmt); 16202 end loop; 16203 16204 -- Remove predefined primitives of Generic_Actual. We must use 16205 -- an auxiliary list because in case of tagged types the value 16206 -- returned by Collect_Primitive_Operations is the value stored 16207 -- in its Primitive_Operations attribute (and we don't want to 16208 -- modify its current contents). 16209 16210 if not Has_Predefined_Primitives then 16211 declare 16212 Aux_List : constant Elist_Id := New_Elmt_List; 16213 16214 begin 16215 Elmt := First_Elmt (Act_List); 16216 while Present (Elmt) loop 16217 Subp := Node (Elmt); 16218 16219 if not Is_Predefined_Dispatching_Operation (Subp) 16220 or else Comes_From_Source (Subp) 16221 then 16222 Append_Elmt (Subp, Aux_List); 16223 end if; 16224 16225 Next_Elmt (Elmt); 16226 end loop; 16227 16228 Act_List := Aux_List; 16229 end; 16230 end if; 16231 16232 Act_Elmt := First_Elmt (Act_List); 16233 Act_Subp := Node (Act_Elmt); 16234 end; 16235 end if; 16236 16237 -- Stage 1: If the generic actual is not present we derive the 16238 -- primitives inherited from the parent type. If the generic parent 16239 -- type is present, the derived type is an instance of a formal 16240 -- derived type, and within the instance its operations are those of 16241 -- the actual. We derive from the formal type but make the inherited 16242 -- operations aliases of the corresponding operations of the actual. 16243 16244 Elmt := First_Elmt (Op_List); 16245 while Present (Elmt) loop 16246 Subp := Node (Elmt); 16247 Alias_Subp := Ultimate_Alias (Subp); 16248 16249 -- Do not derive internal entities of the parent that link 16250 -- interface primitives with their covering primitive. These 16251 -- entities will be added to this type when frozen. 16252 16253 if Present (Interface_Alias (Subp)) then 16254 goto Continue; 16255 end if; 16256 16257 -- If the generic actual is present find the corresponding 16258 -- operation in the generic actual. If the parent type is a 16259 -- direct ancestor of the derived type then, even if it is an 16260 -- interface, the operations are inherited from the primary 16261 -- dispatch table and are in the proper order. If we detect here 16262 -- that primitives are not in the same order we traverse the list 16263 -- of primitive operations of the actual to find the one that 16264 -- implements the interface primitive. 16265 16266 if Need_Search 16267 or else 16268 (Present (Generic_Actual) 16269 and then Present (Act_Subp) 16270 and then not 16271 (Primitive_Names_Match (Subp, Act_Subp) 16272 and then 16273 Type_Conformant (Subp, Act_Subp, 16274 Skip_Controlling_Formals => True))) 16275 then 16276 pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual, 16277 Use_Full_View => True)); 16278 16279 -- Remember that we need searching for all pending primitives 16280 16281 Need_Search := True; 16282 16283 -- Handle entities associated with interface primitives 16284 16285 if Present (Alias_Subp) 16286 and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) 16287 and then not Is_Predefined_Dispatching_Operation (Subp) 16288 then 16289 -- Search for the primitive in the homonym chain 16290 16291 Act_Subp := 16292 Find_Primitive_Covering_Interface 16293 (Tagged_Type => Generic_Actual, 16294 Iface_Prim => Alias_Subp); 16295 16296 -- Previous search may not locate primitives covering 16297 -- interfaces defined in generics units or instantiations. 16298 -- (it fails if the covering primitive has formals whose 16299 -- type is also defined in generics or instantiations). 16300 -- In such case we search in the list of primitives of the 16301 -- generic actual for the internal entity that links the 16302 -- interface primitive and the covering primitive. 16303 16304 if No (Act_Subp) 16305 and then Is_Generic_Type (Parent_Type) 16306 then 16307 -- This code has been designed to handle only generic 16308 -- formals that implement interfaces that are defined 16309 -- in a generic unit or instantiation. If this code is 16310 -- needed for other cases we must review it because 16311 -- (given that it relies on Original_Location to locate 16312 -- the primitive of Generic_Actual that covers the 16313 -- interface) it could leave linked through attribute 16314 -- Alias entities of unrelated instantiations). 16315 16316 pragma Assert 16317 (Is_Generic_Unit 16318 (Scope (Find_Dispatching_Type (Alias_Subp))) 16319 or else 16320 Instantiation_Depth 16321 (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); 16322 16323 declare 16324 Iface_Prim_Loc : constant Source_Ptr := 16325 Original_Location (Sloc (Alias_Subp)); 16326 16327 Elmt : Elmt_Id; 16328 Prim : Entity_Id; 16329 16330 begin 16331 Elmt := 16332 First_Elmt (Primitive_Operations (Generic_Actual)); 16333 16334 Search : while Present (Elmt) loop 16335 Prim := Node (Elmt); 16336 16337 if Present (Interface_Alias (Prim)) 16338 and then Original_Location 16339 (Sloc (Interface_Alias (Prim))) = 16340 Iface_Prim_Loc 16341 then 16342 Act_Subp := Alias (Prim); 16343 exit Search; 16344 end if; 16345 16346 Next_Elmt (Elmt); 16347 end loop Search; 16348 end; 16349 end if; 16350 16351 pragma Assert (Present (Act_Subp) 16352 or else Is_Abstract_Type (Generic_Actual) 16353 or else Serious_Errors_Detected > 0); 16354 16355 -- Handle predefined primitives plus the rest of user-defined 16356 -- primitives 16357 16358 else 16359 Act_Elmt := First_Elmt (Act_List); 16360 while Present (Act_Elmt) loop 16361 Act_Subp := Node (Act_Elmt); 16362 16363 exit when Primitive_Names_Match (Subp, Act_Subp) 16364 and then Type_Conformant 16365 (Subp, Act_Subp, 16366 Skip_Controlling_Formals => True) 16367 and then No (Interface_Alias (Act_Subp)); 16368 16369 Next_Elmt (Act_Elmt); 16370 end loop; 16371 16372 if No (Act_Elmt) then 16373 Act_Subp := Empty; 16374 end if; 16375 end if; 16376 end if; 16377 16378 -- Case 1: If the parent is a limited interface then it has the 16379 -- predefined primitives of synchronized interfaces. However, the 16380 -- actual type may be a non-limited type and hence it does not 16381 -- have such primitives. 16382 16383 if Present (Generic_Actual) 16384 and then not Present (Act_Subp) 16385 and then Is_Limited_Interface (Parent_Base) 16386 and then Is_Predefined_Interface_Primitive (Subp) 16387 then 16388 null; 16389 16390 -- Case 2: Inherit entities associated with interfaces that were 16391 -- not covered by the parent type. We exclude here null interface 16392 -- primitives because they do not need special management. 16393 16394 -- We also exclude interface operations that are renamings. If the 16395 -- subprogram is an explicit renaming of an interface primitive, 16396 -- it is a regular primitive operation, and the presence of its 16397 -- alias is not relevant: it has to be derived like any other 16398 -- primitive. 16399 16400 elsif Present (Alias (Subp)) 16401 and then Nkind (Unit_Declaration_Node (Subp)) /= 16402 N_Subprogram_Renaming_Declaration 16403 and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) 16404 and then not 16405 (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification 16406 and then Null_Present (Parent (Alias_Subp))) 16407 then 16408 -- If this is an abstract private type then we transfer the 16409 -- derivation of the interface primitive from the partial view 16410 -- to the full view. This is safe because all the interfaces 16411 -- must be visible in the partial view. Done to avoid adding 16412 -- a new interface derivation to the private part of the 16413 -- enclosing package; otherwise this new derivation would be 16414 -- decorated as hidden when the analysis of the enclosing 16415 -- package completes. 16416 16417 if Is_Abstract_Type (Derived_Type) 16418 and then In_Private_Part (Current_Scope) 16419 and then Has_Private_Declaration (Derived_Type) 16420 then 16421 declare 16422 Partial_View : Entity_Id; 16423 Elmt : Elmt_Id; 16424 Ent : Entity_Id; 16425 16426 begin 16427 Partial_View := First_Entity (Current_Scope); 16428 loop 16429 exit when No (Partial_View) 16430 or else (Has_Private_Declaration (Partial_View) 16431 and then 16432 Full_View (Partial_View) = Derived_Type); 16433 16434 Next_Entity (Partial_View); 16435 end loop; 16436 16437 -- If the partial view was not found then the source code 16438 -- has errors and the derivation is not needed. 16439 16440 if Present (Partial_View) then 16441 Elmt := 16442 First_Elmt (Primitive_Operations (Partial_View)); 16443 while Present (Elmt) loop 16444 Ent := Node (Elmt); 16445 16446 if Present (Alias (Ent)) 16447 and then Ultimate_Alias (Ent) = Alias (Subp) 16448 then 16449 Append_Elmt 16450 (Ent, Primitive_Operations (Derived_Type)); 16451 exit; 16452 end if; 16453 16454 Next_Elmt (Elmt); 16455 end loop; 16456 16457 -- If the interface primitive was not found in the 16458 -- partial view then this interface primitive was 16459 -- overridden. We add a derivation to activate in 16460 -- Derive_Progenitor_Subprograms the machinery to 16461 -- search for it. 16462 16463 if No (Elmt) then 16464 Derive_Interface_Subprogram 16465 (New_Subp => New_Subp, 16466 Subp => Subp, 16467 Actual_Subp => Act_Subp); 16468 end if; 16469 end if; 16470 end; 16471 else 16472 Derive_Interface_Subprogram 16473 (New_Subp => New_Subp, 16474 Subp => Subp, 16475 Actual_Subp => Act_Subp); 16476 end if; 16477 16478 -- Case 3: Common derivation 16479 16480 else 16481 Derive_Subprogram 16482 (New_Subp => New_Subp, 16483 Parent_Subp => Subp, 16484 Derived_Type => Derived_Type, 16485 Parent_Type => Parent_Base, 16486 Actual_Subp => Act_Subp); 16487 end if; 16488 16489 -- No need to update Act_Elm if we must search for the 16490 -- corresponding operation in the generic actual 16491 16492 if not Need_Search 16493 and then Present (Act_Elmt) 16494 then 16495 Next_Elmt (Act_Elmt); 16496 Act_Subp := Node (Act_Elmt); 16497 end if; 16498 16499 <<Continue>> 16500 Next_Elmt (Elmt); 16501 end loop; 16502 16503 -- Inherit additional operations from progenitors. If the derived 16504 -- type is a generic actual, there are not new primitive operations 16505 -- for the type because it has those of the actual, and therefore 16506 -- nothing needs to be done. The renamings generated above are not 16507 -- primitive operations, and their purpose is simply to make the 16508 -- proper operations visible within an instantiation. 16509 16510 if No (Generic_Actual) then 16511 Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); 16512 end if; 16513 end if; 16514 16515 -- Final check: Direct descendants must have their primitives in the 16516 -- same order. We exclude from this test untagged types and instances 16517 -- of formal derived types. We skip this test if we have already 16518 -- reported serious errors in the sources. 16519 16520 pragma Assert (not Is_Tagged_Type (Derived_Type) 16521 or else Present (Generic_Actual) 16522 or else Serious_Errors_Detected > 0 16523 or else Check_Derived_Type); 16524 end Derive_Subprograms; 16525 16526 -------------------------------- 16527 -- Derived_Standard_Character -- 16528 -------------------------------- 16529 16530 procedure Derived_Standard_Character 16531 (N : Node_Id; 16532 Parent_Type : Entity_Id; 16533 Derived_Type : Entity_Id) 16534 is 16535 Loc : constant Source_Ptr := Sloc (N); 16536 Def : constant Node_Id := Type_Definition (N); 16537 Indic : constant Node_Id := Subtype_Indication (Def); 16538 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 16539 Implicit_Base : constant Entity_Id := 16540 Create_Itype 16541 (E_Enumeration_Type, N, Derived_Type, 'B'); 16542 16543 Lo : Node_Id; 16544 Hi : Node_Id; 16545 16546 begin 16547 Discard_Node (Process_Subtype (Indic, N)); 16548 16549 Set_Etype (Implicit_Base, Parent_Base); 16550 Set_Size_Info (Implicit_Base, Root_Type (Parent_Type)); 16551 Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type))); 16552 16553 Set_Is_Character_Type (Implicit_Base, True); 16554 Set_Has_Delayed_Freeze (Implicit_Base); 16555 16556 -- The bounds of the implicit base are the bounds of the parent base. 16557 -- Note that their type is the parent base. 16558 16559 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); 16560 Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); 16561 16562 Set_Scalar_Range (Implicit_Base, 16563 Make_Range (Loc, 16564 Low_Bound => Lo, 16565 High_Bound => Hi)); 16566 16567 Conditional_Delay (Derived_Type, Parent_Type); 16568 16569 Set_Ekind (Derived_Type, E_Enumeration_Subtype); 16570 Set_Etype (Derived_Type, Implicit_Base); 16571 Set_Size_Info (Derived_Type, Parent_Type); 16572 16573 if Unknown_RM_Size (Derived_Type) then 16574 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 16575 end if; 16576 16577 Set_Is_Character_Type (Derived_Type, True); 16578 16579 if Nkind (Indic) /= N_Subtype_Indication then 16580 16581 -- If no explicit constraint, the bounds are those 16582 -- of the parent type. 16583 16584 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type)); 16585 Hi := New_Copy_Tree (Type_High_Bound (Parent_Type)); 16586 Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi)); 16587 end if; 16588 16589 Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); 16590 16591 -- Because the implicit base is used in the conversion of the bounds, we 16592 -- have to freeze it now. This is similar to what is done for numeric 16593 -- types, and it equally suspicious, but otherwise a nonstatic bound 16594 -- will have a reference to an unfrozen type, which is rejected by Gigi 16595 -- (???). This requires specific care for definition of stream 16596 -- attributes. For details, see comments at the end of 16597 -- Build_Derived_Numeric_Type. 16598 16599 Freeze_Before (N, Implicit_Base); 16600 end Derived_Standard_Character; 16601 16602 ------------------------------ 16603 -- Derived_Type_Declaration -- 16604 ------------------------------ 16605 16606 procedure Derived_Type_Declaration 16607 (T : Entity_Id; 16608 N : Node_Id; 16609 Is_Completion : Boolean) 16610 is 16611 Parent_Type : Entity_Id; 16612 16613 function Comes_From_Generic (Typ : Entity_Id) return Boolean; 16614 -- Check whether the parent type is a generic formal, or derives 16615 -- directly or indirectly from one. 16616 16617 ------------------------ 16618 -- Comes_From_Generic -- 16619 ------------------------ 16620 16621 function Comes_From_Generic (Typ : Entity_Id) return Boolean is 16622 begin 16623 if Is_Generic_Type (Typ) then 16624 return True; 16625 16626 elsif Is_Generic_Type (Root_Type (Parent_Type)) then 16627 return True; 16628 16629 elsif Is_Private_Type (Typ) 16630 and then Present (Full_View (Typ)) 16631 and then Is_Generic_Type (Root_Type (Full_View (Typ))) 16632 then 16633 return True; 16634 16635 elsif Is_Generic_Actual_Type (Typ) then 16636 return True; 16637 16638 else 16639 return False; 16640 end if; 16641 end Comes_From_Generic; 16642 16643 -- Local variables 16644 16645 Def : constant Node_Id := Type_Definition (N); 16646 Iface_Def : Node_Id; 16647 Indic : constant Node_Id := Subtype_Indication (Def); 16648 Extension : constant Node_Id := Record_Extension_Part (Def); 16649 Parent_Node : Node_Id; 16650 Taggd : Boolean; 16651 16652 -- Start of processing for Derived_Type_Declaration 16653 16654 begin 16655 Parent_Type := Find_Type_Of_Subtype_Indic (Indic); 16656 16657 if SPARK_Mode = On 16658 and then Is_Tagged_Type (Parent_Type) 16659 then 16660 declare 16661 Partial_View : constant Entity_Id := 16662 Incomplete_Or_Partial_View (Parent_Type); 16663 16664 begin 16665 -- If the partial view was not found then the parent type is not 16666 -- a private type. Otherwise check if the partial view is a tagged 16667 -- private type. 16668 16669 if Present (Partial_View) 16670 and then Is_Private_Type (Partial_View) 16671 and then not Is_Tagged_Type (Partial_View) 16672 then 16673 Error_Msg_NE 16674 ("cannot derive from & declared as untagged private " 16675 & "(SPARK RM 3.4(1))", N, Partial_View); 16676 end if; 16677 end; 16678 end if; 16679 16680 -- Ada 2005 (AI-251): In case of interface derivation check that the 16681 -- parent is also an interface. 16682 16683 if Interface_Present (Def) then 16684 if not Is_Interface (Parent_Type) then 16685 Diagnose_Interface (Indic, Parent_Type); 16686 16687 else 16688 Parent_Node := Parent (Base_Type (Parent_Type)); 16689 Iface_Def := Type_Definition (Parent_Node); 16690 16691 -- Ada 2005 (AI-251): Limited interfaces can only inherit from 16692 -- other limited interfaces. 16693 16694 if Limited_Present (Def) then 16695 if Limited_Present (Iface_Def) then 16696 null; 16697 16698 elsif Protected_Present (Iface_Def) then 16699 Error_Msg_NE 16700 ("descendant of & must be declared as a protected " 16701 & "interface", N, Parent_Type); 16702 16703 elsif Synchronized_Present (Iface_Def) then 16704 Error_Msg_NE 16705 ("descendant of & must be declared as a synchronized " 16706 & "interface", N, Parent_Type); 16707 16708 elsif Task_Present (Iface_Def) then 16709 Error_Msg_NE 16710 ("descendant of & must be declared as a task interface", 16711 N, Parent_Type); 16712 16713 else 16714 Error_Msg_N 16715 ("(Ada 2005) limited interface cannot inherit from " 16716 & "non-limited interface", Indic); 16717 end if; 16718 16719 -- Ada 2005 (AI-345): Non-limited interfaces can only inherit 16720 -- from non-limited or limited interfaces. 16721 16722 elsif not Protected_Present (Def) 16723 and then not Synchronized_Present (Def) 16724 and then not Task_Present (Def) 16725 then 16726 if Limited_Present (Iface_Def) then 16727 null; 16728 16729 elsif Protected_Present (Iface_Def) then 16730 Error_Msg_NE 16731 ("descendant of & must be declared as a protected " 16732 & "interface", N, Parent_Type); 16733 16734 elsif Synchronized_Present (Iface_Def) then 16735 Error_Msg_NE 16736 ("descendant of & must be declared as a synchronized " 16737 & "interface", N, Parent_Type); 16738 16739 elsif Task_Present (Iface_Def) then 16740 Error_Msg_NE 16741 ("descendant of & must be declared as a task interface", 16742 N, Parent_Type); 16743 else 16744 null; 16745 end if; 16746 end if; 16747 end if; 16748 end if; 16749 16750 if Is_Tagged_Type (Parent_Type) 16751 and then Is_Concurrent_Type (Parent_Type) 16752 and then not Is_Interface (Parent_Type) 16753 then 16754 Error_Msg_N 16755 ("parent type of a record extension cannot be a synchronized " 16756 & "tagged type (RM 3.9.1 (3/1))", N); 16757 Set_Etype (T, Any_Type); 16758 return; 16759 end if; 16760 16761 -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor 16762 -- interfaces 16763 16764 if Is_Tagged_Type (Parent_Type) 16765 and then Is_Non_Empty_List (Interface_List (Def)) 16766 then 16767 declare 16768 Intf : Node_Id; 16769 T : Entity_Id; 16770 16771 begin 16772 Intf := First (Interface_List (Def)); 16773 while Present (Intf) loop 16774 T := Find_Type_Of_Subtype_Indic (Intf); 16775 16776 if not Is_Interface (T) then 16777 Diagnose_Interface (Intf, T); 16778 16779 -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow 16780 -- a limited type from having a nonlimited progenitor. 16781 16782 elsif (Limited_Present (Def) 16783 or else (not Is_Interface (Parent_Type) 16784 and then Is_Limited_Type (Parent_Type))) 16785 and then not Is_Limited_Interface (T) 16786 then 16787 Error_Msg_NE 16788 ("progenitor interface& of limited type must be limited", 16789 N, T); 16790 end if; 16791 16792 Next (Intf); 16793 end loop; 16794 end; 16795 16796 -- Check consistency of any nonoverridable aspects that are 16797 -- inherited from multiple sources. 16798 16799 Check_Inherited_Nonoverridable_Aspects 16800 (Inheritor => T, 16801 Interface_List => Interface_List (Def), 16802 Parent_Type => Parent_Type); 16803 end if; 16804 16805 if Parent_Type = Any_Type 16806 or else Etype (Parent_Type) = Any_Type 16807 or else (Is_Class_Wide_Type (Parent_Type) 16808 and then Etype (Parent_Type) = T) 16809 then 16810 -- If Parent_Type is undefined or illegal, make new type into a 16811 -- subtype of Any_Type, and set a few attributes to prevent cascaded 16812 -- errors. If this is a self-definition, emit error now. 16813 16814 if T = Parent_Type or else T = Etype (Parent_Type) then 16815 Error_Msg_N ("type cannot be used in its own definition", Indic); 16816 end if; 16817 16818 Set_Ekind (T, Ekind (Parent_Type)); 16819 Set_Etype (T, Any_Type); 16820 Set_Scalar_Range (T, Scalar_Range (Any_Type)); 16821 16822 if Is_Tagged_Type (T) 16823 and then Is_Record_Type (T) 16824 then 16825 Set_Direct_Primitive_Operations (T, New_Elmt_List); 16826 end if; 16827 16828 return; 16829 end if; 16830 16831 -- Ada 2005 (AI-251): The case in which the parent of the full-view is 16832 -- an interface is special because the list of interfaces in the full 16833 -- view can be given in any order. For example: 16834 16835 -- type A is interface; 16836 -- type B is interface and A; 16837 -- type D is new B with private; 16838 -- private 16839 -- type D is new A and B with null record; -- 1 -- 16840 16841 -- In this case we perform the following transformation of -1-: 16842 16843 -- type D is new B and A with null record; 16844 16845 -- If the parent of the full-view covers the parent of the partial-view 16846 -- we have two possible cases: 16847 16848 -- 1) They have the same parent 16849 -- 2) The parent of the full-view implements some further interfaces 16850 16851 -- In both cases we do not need to perform the transformation. In the 16852 -- first case the source program is correct and the transformation is 16853 -- not needed; in the second case the source program does not fulfill 16854 -- the no-hidden interfaces rule (AI-396) and the error will be reported 16855 -- later. 16856 16857 -- This transformation not only simplifies the rest of the analysis of 16858 -- this type declaration but also simplifies the correct generation of 16859 -- the object layout to the expander. 16860 16861 if In_Private_Part (Current_Scope) 16862 and then Is_Interface (Parent_Type) 16863 then 16864 declare 16865 Iface : Node_Id; 16866 Partial_View : Entity_Id; 16867 Partial_View_Parent : Entity_Id; 16868 New_Iface : Node_Id; 16869 16870 begin 16871 -- Look for the associated private type declaration 16872 16873 Partial_View := Incomplete_Or_Partial_View (T); 16874 16875 -- If the partial view was not found then the source code has 16876 -- errors and the transformation is not needed. 16877 16878 if Present (Partial_View) then 16879 Partial_View_Parent := Etype (Partial_View); 16880 16881 -- If the parent of the full-view covers the parent of the 16882 -- partial-view we have nothing else to do. 16883 16884 if Interface_Present_In_Ancestor 16885 (Parent_Type, Partial_View_Parent) 16886 then 16887 null; 16888 16889 -- Traverse the list of interfaces of the full-view to look 16890 -- for the parent of the partial-view and perform the tree 16891 -- transformation. 16892 16893 else 16894 Iface := First (Interface_List (Def)); 16895 while Present (Iface) loop 16896 if Etype (Iface) = Etype (Partial_View) then 16897 Rewrite (Subtype_Indication (Def), 16898 New_Copy (Subtype_Indication 16899 (Parent (Partial_View)))); 16900 16901 New_Iface := 16902 Make_Identifier (Sloc (N), Chars (Parent_Type)); 16903 Append (New_Iface, Interface_List (Def)); 16904 16905 -- Analyze the transformed code 16906 16907 Derived_Type_Declaration (T, N, Is_Completion); 16908 return; 16909 end if; 16910 16911 Next (Iface); 16912 end loop; 16913 end if; 16914 end if; 16915 end; 16916 end if; 16917 16918 -- Only composite types other than array types are allowed to have 16919 -- discriminants. 16920 16921 if Present (Discriminant_Specifications (N)) then 16922 if (Is_Elementary_Type (Parent_Type) 16923 or else 16924 Is_Array_Type (Parent_Type)) 16925 and then not Error_Posted (N) 16926 then 16927 Error_Msg_N 16928 ("elementary or array type cannot have discriminants", 16929 Defining_Identifier (First (Discriminant_Specifications (N)))); 16930 16931 -- Unset Has_Discriminants flag to prevent cascaded errors, but 16932 -- only if we are not already processing a malformed syntax tree. 16933 16934 if Is_Type (T) then 16935 Set_Has_Discriminants (T, False); 16936 end if; 16937 end if; 16938 end if; 16939 16940 -- In Ada 83, a derived type defined in a package specification cannot 16941 -- be used for further derivation until the end of its visible part. 16942 -- Note that derivation in the private part of the package is allowed. 16943 16944 if Ada_Version = Ada_83 16945 and then Is_Derived_Type (Parent_Type) 16946 and then In_Visible_Part (Scope (Parent_Type)) 16947 then 16948 if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then 16949 Error_Msg_N 16950 ("(Ada 83) premature use of type for derivation", Indic); 16951 end if; 16952 end if; 16953 16954 -- Check for early use of incomplete or private type 16955 16956 if Ekind (Parent_Type) in E_Void | E_Incomplete_Type then 16957 Error_Msg_N ("premature derivation of incomplete type", Indic); 16958 return; 16959 16960 elsif (Is_Incomplete_Or_Private_Type (Parent_Type) 16961 and then not Comes_From_Generic (Parent_Type)) 16962 or else Has_Private_Component (Parent_Type) 16963 then 16964 -- The ancestor type of a formal type can be incomplete, in which 16965 -- case only the operations of the partial view are available in the 16966 -- generic. Subsequent checks may be required when the full view is 16967 -- analyzed to verify that a derivation from a tagged type has an 16968 -- extension. 16969 16970 if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then 16971 null; 16972 16973 elsif No (Underlying_Type (Parent_Type)) 16974 or else Has_Private_Component (Parent_Type) 16975 then 16976 Error_Msg_N 16977 ("premature derivation of derived or private type", Indic); 16978 16979 -- Flag the type itself as being in error, this prevents some 16980 -- nasty problems with subsequent uses of the malformed type. 16981 16982 Set_Error_Posted (T); 16983 16984 -- Check that within the immediate scope of an untagged partial 16985 -- view it's illegal to derive from the partial view if the 16986 -- full view is tagged. (7.3(7)) 16987 16988 -- We verify that the Parent_Type is a partial view by checking 16989 -- that it is not a Full_Type_Declaration (i.e. a private type or 16990 -- private extension declaration), to distinguish a partial view 16991 -- from a derivation from a private type which also appears as 16992 -- E_Private_Type. If the parent base type is not declared in an 16993 -- enclosing scope there is no need to check. 16994 16995 elsif Present (Full_View (Parent_Type)) 16996 and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration 16997 and then not Is_Tagged_Type (Parent_Type) 16998 and then Is_Tagged_Type (Full_View (Parent_Type)) 16999 and then In_Open_Scopes (Scope (Base_Type (Parent_Type))) 17000 then 17001 Error_Msg_N 17002 ("premature derivation from type with tagged full view", 17003 Indic); 17004 end if; 17005 end if; 17006 17007 -- Check that form of derivation is appropriate 17008 17009 Taggd := Is_Tagged_Type (Parent_Type); 17010 17011 -- Set the parent type to the class-wide type's specific type in this 17012 -- case to prevent cascading errors 17013 17014 if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then 17015 Error_Msg_N ("parent type must not be a class-wide type", Indic); 17016 Set_Etype (T, Etype (Parent_Type)); 17017 return; 17018 end if; 17019 17020 if Present (Extension) and then not Taggd then 17021 Error_Msg_N 17022 ("type derived from untagged type cannot have extension", Indic); 17023 17024 elsif No (Extension) and then Taggd then 17025 17026 -- If this declaration is within a private part (or body) of a 17027 -- generic instantiation then the derivation is allowed (the parent 17028 -- type can only appear tagged in this case if it's a generic actual 17029 -- type, since it would otherwise have been rejected in the analysis 17030 -- of the generic template). 17031 17032 if not Is_Generic_Actual_Type (Parent_Type) 17033 or else In_Visible_Part (Scope (Parent_Type)) 17034 then 17035 if Is_Class_Wide_Type (Parent_Type) then 17036 Error_Msg_N 17037 ("parent type must not be a class-wide type", Indic); 17038 17039 -- Use specific type to prevent cascaded errors. 17040 17041 Parent_Type := Etype (Parent_Type); 17042 17043 else 17044 Error_Msg_N 17045 ("type derived from tagged type must have extension", Indic); 17046 end if; 17047 end if; 17048 end if; 17049 17050 -- AI-443: Synchronized formal derived types require a private 17051 -- extension. There is no point in checking the ancestor type or 17052 -- the progenitors since the construct is wrong to begin with. 17053 17054 if Ada_Version >= Ada_2005 17055 and then Is_Generic_Type (T) 17056 and then Present (Original_Node (N)) 17057 then 17058 declare 17059 Decl : constant Node_Id := Original_Node (N); 17060 17061 begin 17062 if Nkind (Decl) = N_Formal_Type_Declaration 17063 and then Nkind (Formal_Type_Definition (Decl)) = 17064 N_Formal_Derived_Type_Definition 17065 and then Synchronized_Present (Formal_Type_Definition (Decl)) 17066 and then No (Extension) 17067 17068 -- Avoid emitting a duplicate error message 17069 17070 and then not Error_Posted (Indic) 17071 then 17072 Error_Msg_N 17073 ("synchronized derived type must have extension", N); 17074 end if; 17075 end; 17076 end if; 17077 17078 if Null_Exclusion_Present (Def) 17079 and then not Is_Access_Type (Parent_Type) 17080 then 17081 Error_Msg_N ("null exclusion can only apply to an access type", N); 17082 end if; 17083 17084 -- Avoid deriving parent primitives of underlying record views 17085 17086 Build_Derived_Type (N, Parent_Type, T, Is_Completion, 17087 Derive_Subps => not Is_Underlying_Record_View (T)); 17088 17089 -- AI-419: The parent type of an explicitly limited derived type must 17090 -- be a limited type or a limited interface. 17091 17092 if Limited_Present (Def) then 17093 Set_Is_Limited_Record (T); 17094 17095 if Is_Interface (T) then 17096 Set_Is_Limited_Interface (T); 17097 end if; 17098 17099 if not Is_Limited_Type (Parent_Type) 17100 and then 17101 (not Is_Interface (Parent_Type) 17102 or else not Is_Limited_Interface (Parent_Type)) 17103 then 17104 -- AI05-0096: a derivation in the private part of an instance is 17105 -- legal if the generic formal is untagged limited, and the actual 17106 -- is non-limited. 17107 17108 if Is_Generic_Actual_Type (Parent_Type) 17109 and then In_Private_Part (Current_Scope) 17110 and then 17111 not Is_Tagged_Type 17112 (Generic_Parent_Type (Parent (Parent_Type))) 17113 then 17114 null; 17115 17116 else 17117 Error_Msg_NE 17118 ("parent type& of limited type must be limited", 17119 N, Parent_Type); 17120 end if; 17121 end if; 17122 end if; 17123 end Derived_Type_Declaration; 17124 17125 ------------------------ 17126 -- Diagnose_Interface -- 17127 ------------------------ 17128 17129 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is 17130 begin 17131 if not Is_Interface (E) and then E /= Any_Type then 17132 Error_Msg_NE ("(Ada 2005) & must be an interface", N, E); 17133 end if; 17134 end Diagnose_Interface; 17135 17136 ---------------------------------- 17137 -- Enumeration_Type_Declaration -- 17138 ---------------------------------- 17139 17140 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is 17141 Ev : Uint; 17142 L : Node_Id; 17143 R_Node : Node_Id; 17144 B_Node : Node_Id; 17145 17146 begin 17147 -- Create identifier node representing lower bound 17148 17149 B_Node := New_Node (N_Identifier, Sloc (Def)); 17150 L := First (Literals (Def)); 17151 Set_Chars (B_Node, Chars (L)); 17152 Set_Entity (B_Node, L); 17153 Set_Etype (B_Node, T); 17154 Set_Is_Static_Expression (B_Node, True); 17155 17156 R_Node := New_Node (N_Range, Sloc (Def)); 17157 Set_Low_Bound (R_Node, B_Node); 17158 17159 Set_Ekind (T, E_Enumeration_Type); 17160 Set_First_Literal (T, L); 17161 Set_Etype (T, T); 17162 Set_Is_Constrained (T); 17163 17164 Ev := Uint_0; 17165 17166 -- Loop through literals of enumeration type setting pos and rep values 17167 -- except that if the Ekind is already set, then it means the literal 17168 -- was already constructed (case of a derived type declaration and we 17169 -- should not disturb the Pos and Rep values. 17170 17171 while Present (L) loop 17172 if Ekind (L) /= E_Enumeration_Literal then 17173 Set_Ekind (L, E_Enumeration_Literal); 17174 Set_Enumeration_Pos (L, Ev); 17175 Set_Enumeration_Rep (L, Ev); 17176 Set_Is_Known_Valid (L, True); 17177 end if; 17178 17179 Set_Etype (L, T); 17180 New_Overloaded_Entity (L); 17181 Generate_Definition (L); 17182 Set_Convention (L, Convention_Intrinsic); 17183 17184 -- Case of character literal 17185 17186 if Nkind (L) = N_Defining_Character_Literal then 17187 Set_Is_Character_Type (T, True); 17188 17189 -- Check violation of No_Wide_Characters 17190 17191 if Restriction_Check_Required (No_Wide_Characters) then 17192 Get_Name_String (Chars (L)); 17193 17194 if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then 17195 Check_Restriction (No_Wide_Characters, L); 17196 end if; 17197 end if; 17198 end if; 17199 17200 Ev := Ev + 1; 17201 Next (L); 17202 end loop; 17203 17204 -- Now create a node representing upper bound 17205 17206 B_Node := New_Node (N_Identifier, Sloc (Def)); 17207 Set_Chars (B_Node, Chars (Last (Literals (Def)))); 17208 Set_Entity (B_Node, Last (Literals (Def))); 17209 Set_Etype (B_Node, T); 17210 Set_Is_Static_Expression (B_Node, True); 17211 17212 Set_High_Bound (R_Node, B_Node); 17213 17214 -- Initialize various fields of the type. Some of this information 17215 -- may be overwritten later through rep.clauses. 17216 17217 Set_Scalar_Range (T, R_Node); 17218 Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); 17219 Set_Enum_Esize (T); 17220 Set_Enum_Pos_To_Rep (T, Empty); 17221 17222 -- Set Discard_Names if configuration pragma set, or if there is 17223 -- a parameterless pragma in the current declarative region 17224 17225 if Global_Discard_Names or else Discard_Names (Scope (T)) then 17226 Set_Discard_Names (T); 17227 end if; 17228 17229 -- Process end label if there is one 17230 17231 if Present (Def) then 17232 Process_End_Label (Def, 'e', T); 17233 end if; 17234 end Enumeration_Type_Declaration; 17235 17236 --------------------------------- 17237 -- Expand_To_Stored_Constraint -- 17238 --------------------------------- 17239 17240 function Expand_To_Stored_Constraint 17241 (Typ : Entity_Id; 17242 Constraint : Elist_Id) return Elist_Id 17243 is 17244 Explicitly_Discriminated_Type : Entity_Id; 17245 Expansion : Elist_Id; 17246 Discriminant : Entity_Id; 17247 17248 function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id; 17249 -- Find the nearest type that actually specifies discriminants 17250 17251 --------------------------------- 17252 -- Type_With_Explicit_Discrims -- 17253 --------------------------------- 17254 17255 function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is 17256 Typ : constant E := Base_Type (Id); 17257 17258 begin 17259 if Ekind (Typ) in Incomplete_Or_Private_Kind then 17260 if Present (Full_View (Typ)) then 17261 return Type_With_Explicit_Discrims (Full_View (Typ)); 17262 end if; 17263 17264 else 17265 if Has_Discriminants (Typ) then 17266 return Typ; 17267 end if; 17268 end if; 17269 17270 if Etype (Typ) = Typ then 17271 return Empty; 17272 elsif Has_Discriminants (Typ) then 17273 return Typ; 17274 else 17275 return Type_With_Explicit_Discrims (Etype (Typ)); 17276 end if; 17277 17278 end Type_With_Explicit_Discrims; 17279 17280 -- Start of processing for Expand_To_Stored_Constraint 17281 17282 begin 17283 if No (Constraint) or else Is_Empty_Elmt_List (Constraint) then 17284 return No_Elist; 17285 end if; 17286 17287 Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ); 17288 17289 if No (Explicitly_Discriminated_Type) then 17290 return No_Elist; 17291 end if; 17292 17293 Expansion := New_Elmt_List; 17294 17295 Discriminant := 17296 First_Stored_Discriminant (Explicitly_Discriminated_Type); 17297 while Present (Discriminant) loop 17298 Append_Elmt 17299 (Get_Discriminant_Value 17300 (Discriminant, Explicitly_Discriminated_Type, Constraint), 17301 To => Expansion); 17302 Next_Stored_Discriminant (Discriminant); 17303 end loop; 17304 17305 return Expansion; 17306 end Expand_To_Stored_Constraint; 17307 17308 --------------------------- 17309 -- Find_Hidden_Interface -- 17310 --------------------------- 17311 17312 function Find_Hidden_Interface 17313 (Src : Elist_Id; 17314 Dest : Elist_Id) return Entity_Id 17315 is 17316 Iface : Entity_Id; 17317 Iface_Elmt : Elmt_Id; 17318 17319 begin 17320 if Present (Src) and then Present (Dest) then 17321 Iface_Elmt := First_Elmt (Src); 17322 while Present (Iface_Elmt) loop 17323 Iface := Node (Iface_Elmt); 17324 17325 if Is_Interface (Iface) 17326 and then not Contain_Interface (Iface, Dest) 17327 then 17328 return Iface; 17329 end if; 17330 17331 Next_Elmt (Iface_Elmt); 17332 end loop; 17333 end if; 17334 17335 return Empty; 17336 end Find_Hidden_Interface; 17337 17338 -------------------- 17339 -- Find_Type_Name -- 17340 -------------------- 17341 17342 function Find_Type_Name (N : Node_Id) return Entity_Id is 17343 Id : constant Entity_Id := Defining_Identifier (N); 17344 New_Id : Entity_Id; 17345 Prev : Entity_Id; 17346 Prev_Par : Node_Id; 17347 17348 procedure Check_Duplicate_Aspects; 17349 -- Check that aspects specified in a completion have not been specified 17350 -- already in the partial view. 17351 17352 procedure Tag_Mismatch; 17353 -- Diagnose a tagged partial view whose full view is untagged. We post 17354 -- the message on the full view, with a reference to the previous 17355 -- partial view. The partial view can be private or incomplete, and 17356 -- these are handled in a different manner, so we determine the position 17357 -- of the error message from the respective slocs of both. 17358 17359 ----------------------------- 17360 -- Check_Duplicate_Aspects -- 17361 ----------------------------- 17362 17363 procedure Check_Duplicate_Aspects is 17364 function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id; 17365 -- Return the corresponding aspect of the partial view which matches 17366 -- the aspect id of Asp. Return Empty is no such aspect exists. 17367 17368 ----------------------------- 17369 -- Get_Partial_View_Aspect -- 17370 ----------------------------- 17371 17372 function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id is 17373 Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp); 17374 Prev_Asps : constant List_Id := Aspect_Specifications (Prev_Par); 17375 Prev_Asp : Node_Id; 17376 17377 begin 17378 if Present (Prev_Asps) then 17379 Prev_Asp := First (Prev_Asps); 17380 while Present (Prev_Asp) loop 17381 if Get_Aspect_Id (Prev_Asp) = Asp_Id then 17382 return Prev_Asp; 17383 end if; 17384 17385 Next (Prev_Asp); 17386 end loop; 17387 end if; 17388 17389 return Empty; 17390 end Get_Partial_View_Aspect; 17391 17392 -- Local variables 17393 17394 Full_Asps : constant List_Id := Aspect_Specifications (N); 17395 Full_Asp : Node_Id; 17396 Part_Asp : Node_Id; 17397 17398 -- Start of processing for Check_Duplicate_Aspects 17399 17400 begin 17401 if Present (Full_Asps) then 17402 Full_Asp := First (Full_Asps); 17403 while Present (Full_Asp) loop 17404 Part_Asp := Get_Partial_View_Aspect (Full_Asp); 17405 17406 -- An aspect and its class-wide counterpart are two distinct 17407 -- aspects and may apply to both views of an entity. 17408 17409 if Present (Part_Asp) 17410 and then Class_Present (Part_Asp) = Class_Present (Full_Asp) 17411 then 17412 Error_Msg_N 17413 ("aspect already specified in private declaration", 17414 Full_Asp); 17415 17416 Remove (Full_Asp); 17417 return; 17418 end if; 17419 17420 if Has_Discriminants (Prev) 17421 and then not Has_Unknown_Discriminants (Prev) 17422 and then Get_Aspect_Id (Full_Asp) = 17423 Aspect_Implicit_Dereference 17424 then 17425 Error_Msg_N 17426 ("cannot specify aspect if partial view has known " 17427 & "discriminants", Full_Asp); 17428 end if; 17429 17430 Next (Full_Asp); 17431 end loop; 17432 end if; 17433 end Check_Duplicate_Aspects; 17434 17435 ------------------ 17436 -- Tag_Mismatch -- 17437 ------------------ 17438 17439 procedure Tag_Mismatch is 17440 begin 17441 if Sloc (Prev) < Sloc (Id) then 17442 if Ada_Version >= Ada_2012 17443 and then Nkind (N) = N_Private_Type_Declaration 17444 then 17445 Error_Msg_NE 17446 ("declaration of private } must be a tagged type ", Id, Prev); 17447 else 17448 Error_Msg_NE 17449 ("full declaration of } must be a tagged type ", Id, Prev); 17450 end if; 17451 17452 else 17453 if Ada_Version >= Ada_2012 17454 and then Nkind (N) = N_Private_Type_Declaration 17455 then 17456 Error_Msg_NE 17457 ("declaration of private } must be a tagged type ", Prev, Id); 17458 else 17459 Error_Msg_NE 17460 ("full declaration of } must be a tagged type ", Prev, Id); 17461 end if; 17462 end if; 17463 end Tag_Mismatch; 17464 17465 -- Start of processing for Find_Type_Name 17466 17467 begin 17468 -- Find incomplete declaration, if one was given 17469 17470 Prev := Current_Entity_In_Scope (Id); 17471 17472 -- New type declaration 17473 17474 if No (Prev) then 17475 Enter_Name (Id); 17476 return Id; 17477 17478 -- Previous declaration exists 17479 17480 else 17481 Prev_Par := Parent (Prev); 17482 17483 -- Error if not incomplete/private case except if previous 17484 -- declaration is implicit, etc. Enter_Name will emit error if 17485 -- appropriate. 17486 17487 if not Is_Incomplete_Or_Private_Type (Prev) then 17488 Enter_Name (Id); 17489 New_Id := Id; 17490 17491 -- Check invalid completion of private or incomplete type 17492 17493 elsif Nkind (N) not in N_Full_Type_Declaration 17494 | N_Task_Type_Declaration 17495 | N_Protected_Type_Declaration 17496 and then 17497 (Ada_Version < Ada_2012 17498 or else not Is_Incomplete_Type (Prev) 17499 or else Nkind (N) not in N_Private_Type_Declaration 17500 | N_Private_Extension_Declaration) 17501 then 17502 -- Completion must be a full type declarations (RM 7.3(4)) 17503 17504 Error_Msg_Sloc := Sloc (Prev); 17505 Error_Msg_NE ("invalid completion of }", Id, Prev); 17506 17507 -- Set scope of Id to avoid cascaded errors. Entity is never 17508 -- examined again, except when saving globals in generics. 17509 17510 Set_Scope (Id, Current_Scope); 17511 New_Id := Id; 17512 17513 -- If this is a repeated incomplete declaration, no further 17514 -- checks are possible. 17515 17516 if Nkind (N) = N_Incomplete_Type_Declaration then 17517 return Prev; 17518 end if; 17519 17520 -- Case of full declaration of incomplete type 17521 17522 elsif Ekind (Prev) = E_Incomplete_Type 17523 and then (Ada_Version < Ada_2012 17524 or else No (Full_View (Prev)) 17525 or else not Is_Private_Type (Full_View (Prev))) 17526 then 17527 -- Indicate that the incomplete declaration has a matching full 17528 -- declaration. The defining occurrence of the incomplete 17529 -- declaration remains the visible one, and the procedure 17530 -- Get_Full_View dereferences it whenever the type is used. 17531 17532 if Present (Full_View (Prev)) then 17533 Error_Msg_NE ("invalid redeclaration of }", Id, Prev); 17534 end if; 17535 17536 Set_Full_View (Prev, Id); 17537 Append_Entity (Id, Current_Scope); 17538 Set_Is_Public (Id, Is_Public (Prev)); 17539 Set_Is_Internal (Id); 17540 New_Id := Prev; 17541 17542 -- If the incomplete view is tagged, a class_wide type has been 17543 -- created already. Use it for the private type as well, in order 17544 -- to prevent multiple incompatible class-wide types that may be 17545 -- created for self-referential anonymous access components. 17546 17547 if Is_Tagged_Type (Prev) 17548 and then Present (Class_Wide_Type (Prev)) 17549 then 17550 Set_Ekind (Id, Ekind (Prev)); -- will be reset later 17551 Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); 17552 17553 -- Type of the class-wide type is the current Id. Previously 17554 -- this was not done for private declarations because of order- 17555 -- of-elaboration issues in the back end, but gigi now handles 17556 -- this properly. 17557 17558 Set_Etype (Class_Wide_Type (Id), Id); 17559 end if; 17560 17561 -- Case of full declaration of private type 17562 17563 else 17564 -- If the private type was a completion of an incomplete type then 17565 -- update Prev to reference the private type 17566 17567 if Ada_Version >= Ada_2012 17568 and then Ekind (Prev) = E_Incomplete_Type 17569 and then Present (Full_View (Prev)) 17570 and then Is_Private_Type (Full_View (Prev)) 17571 then 17572 Prev := Full_View (Prev); 17573 Prev_Par := Parent (Prev); 17574 end if; 17575 17576 if Nkind (N) = N_Full_Type_Declaration 17577 and then Nkind (Type_Definition (N)) in 17578 N_Record_Definition | N_Derived_Type_Definition 17579 and then Interface_Present (Type_Definition (N)) 17580 then 17581 Error_Msg_N 17582 ("completion of private type cannot be an interface", N); 17583 end if; 17584 17585 if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then 17586 if Etype (Prev) /= Prev then 17587 17588 -- Prev is a private subtype or a derived type, and needs 17589 -- no completion. 17590 17591 Error_Msg_NE ("invalid redeclaration of }", Id, Prev); 17592 New_Id := Id; 17593 17594 elsif Ekind (Prev) = E_Private_Type 17595 and then Nkind (N) in N_Task_Type_Declaration 17596 | N_Protected_Type_Declaration 17597 then 17598 Error_Msg_N 17599 ("completion of nonlimited type cannot be limited", N); 17600 17601 elsif Ekind (Prev) = E_Record_Type_With_Private 17602 and then Nkind (N) in N_Task_Type_Declaration 17603 | N_Protected_Type_Declaration 17604 then 17605 if not Is_Limited_Record (Prev) then 17606 Error_Msg_N 17607 ("completion of nonlimited type cannot be limited", N); 17608 17609 elsif No (Interface_List (N)) then 17610 Error_Msg_N 17611 ("completion of tagged private type must be tagged", 17612 N); 17613 end if; 17614 end if; 17615 17616 -- Ada 2005 (AI-251): Private extension declaration of a task 17617 -- type or a protected type. This case arises when covering 17618 -- interface types. 17619 17620 elsif Nkind (N) in N_Task_Type_Declaration 17621 | N_Protected_Type_Declaration 17622 then 17623 null; 17624 17625 elsif Nkind (N) /= N_Full_Type_Declaration 17626 or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition 17627 then 17628 Error_Msg_N 17629 ("full view of private extension must be an extension", N); 17630 17631 elsif not (Abstract_Present (Parent (Prev))) 17632 and then Abstract_Present (Type_Definition (N)) 17633 then 17634 Error_Msg_N 17635 ("full view of non-abstract extension cannot be abstract", N); 17636 end if; 17637 17638 if not In_Private_Part (Current_Scope) then 17639 Error_Msg_N 17640 ("declaration of full view must appear in private part", N); 17641 end if; 17642 17643 if Ada_Version >= Ada_2012 then 17644 Check_Duplicate_Aspects; 17645 end if; 17646 17647 Copy_And_Swap (Prev, Id); 17648 Set_Has_Private_Declaration (Prev); 17649 Set_Has_Private_Declaration (Id); 17650 17651 -- AI12-0133: Indicate whether we have a partial view with 17652 -- unknown discriminants, in which case initialization of objects 17653 -- of the type do not receive an invariant check. 17654 17655 Set_Partial_View_Has_Unknown_Discr 17656 (Prev, Has_Unknown_Discriminants (Id)); 17657 17658 -- Preserve aspect and iterator flags that may have been set on 17659 -- the partial view. 17660 17661 Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id)); 17662 Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id)); 17663 17664 -- If no error, propagate freeze_node from private to full view. 17665 -- It may have been generated for an early operational item. 17666 17667 if Present (Freeze_Node (Id)) 17668 and then Serious_Errors_Detected = 0 17669 and then No (Full_View (Id)) 17670 then 17671 Set_Freeze_Node (Prev, Freeze_Node (Id)); 17672 Set_Freeze_Node (Id, Empty); 17673 Set_First_Rep_Item (Prev, First_Rep_Item (Id)); 17674 end if; 17675 17676 Set_Full_View (Id, Prev); 17677 New_Id := Prev; 17678 end if; 17679 17680 -- Verify that full declaration conforms to partial one 17681 17682 if Is_Incomplete_Or_Private_Type (Prev) 17683 and then Present (Discriminant_Specifications (Prev_Par)) 17684 then 17685 if Present (Discriminant_Specifications (N)) then 17686 if Ekind (Prev) = E_Incomplete_Type then 17687 Check_Discriminant_Conformance (N, Prev, Prev); 17688 else 17689 Check_Discriminant_Conformance (N, Prev, Id); 17690 end if; 17691 17692 else 17693 Error_Msg_N 17694 ("missing discriminants in full type declaration", N); 17695 17696 -- To avoid cascaded errors on subsequent use, share the 17697 -- discriminants of the partial view. 17698 17699 Set_Discriminant_Specifications (N, 17700 Discriminant_Specifications (Prev_Par)); 17701 end if; 17702 end if; 17703 17704 -- A prior untagged partial view can have an associated class-wide 17705 -- type due to use of the class attribute, and in this case the full 17706 -- type must also be tagged. This Ada 95 usage is deprecated in favor 17707 -- of incomplete tagged declarations, but we check for it. 17708 17709 if Is_Type (Prev) 17710 and then (Is_Tagged_Type (Prev) 17711 or else Present (Class_Wide_Type (Prev))) 17712 then 17713 -- Ada 2012 (AI05-0162): A private type may be the completion of 17714 -- an incomplete type. 17715 17716 if Ada_Version >= Ada_2012 17717 and then Is_Incomplete_Type (Prev) 17718 and then Nkind (N) in N_Private_Type_Declaration 17719 | N_Private_Extension_Declaration 17720 then 17721 -- No need to check private extensions since they are tagged 17722 17723 if Nkind (N) = N_Private_Type_Declaration 17724 and then not Tagged_Present (N) 17725 then 17726 Tag_Mismatch; 17727 end if; 17728 17729 -- The full declaration is either a tagged type (including 17730 -- a synchronized type that implements interfaces) or a 17731 -- type extension, otherwise this is an error. 17732 17733 elsif Nkind (N) in N_Task_Type_Declaration 17734 | N_Protected_Type_Declaration 17735 then 17736 if No (Interface_List (N)) and then not Error_Posted (N) then 17737 Tag_Mismatch; 17738 end if; 17739 17740 elsif Nkind (Type_Definition (N)) = N_Record_Definition then 17741 17742 -- Indicate that the previous declaration (tagged incomplete 17743 -- or private declaration) requires the same on the full one. 17744 17745 if not Tagged_Present (Type_Definition (N)) then 17746 Tag_Mismatch; 17747 Set_Is_Tagged_Type (Id); 17748 end if; 17749 17750 elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 17751 if No (Record_Extension_Part (Type_Definition (N))) then 17752 Error_Msg_NE 17753 ("full declaration of } must be a record extension", 17754 Prev, Id); 17755 17756 -- Set some attributes to produce a usable full view 17757 17758 Set_Is_Tagged_Type (Id); 17759 end if; 17760 17761 else 17762 Tag_Mismatch; 17763 end if; 17764 end if; 17765 17766 if Present (Prev) 17767 and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration 17768 and then Present (Premature_Use (Parent (Prev))) 17769 then 17770 Error_Msg_Sloc := Sloc (N); 17771 Error_Msg_N 17772 ("\full declaration #", Premature_Use (Parent (Prev))); 17773 end if; 17774 17775 return New_Id; 17776 end if; 17777 end Find_Type_Name; 17778 17779 ------------------------- 17780 -- Find_Type_Of_Object -- 17781 ------------------------- 17782 17783 function Find_Type_Of_Object 17784 (Obj_Def : Node_Id; 17785 Related_Nod : Node_Id) return Entity_Id 17786 is 17787 Def_Kind : constant Node_Kind := Nkind (Obj_Def); 17788 P : Node_Id := Parent (Obj_Def); 17789 T : Entity_Id; 17790 Nam : Name_Id; 17791 17792 begin 17793 -- If the parent is a component_definition node we climb to the 17794 -- component_declaration node 17795 17796 if Nkind (P) = N_Component_Definition then 17797 P := Parent (P); 17798 end if; 17799 17800 -- Case of an anonymous array subtype 17801 17802 if Def_Kind in N_Array_Type_Definition then 17803 T := Empty; 17804 Array_Type_Declaration (T, Obj_Def); 17805 17806 -- Create an explicit subtype whenever possible 17807 17808 elsif Nkind (P) /= N_Component_Declaration 17809 and then Def_Kind = N_Subtype_Indication 17810 then 17811 -- Base name of subtype on object name, which will be unique in 17812 -- the current scope. 17813 17814 -- If this is a duplicate declaration, return base type, to avoid 17815 -- generating duplicate anonymous types. 17816 17817 if Error_Posted (P) then 17818 Analyze (Subtype_Mark (Obj_Def)); 17819 return Entity (Subtype_Mark (Obj_Def)); 17820 end if; 17821 17822 Nam := 17823 New_External_Name 17824 (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T'); 17825 17826 T := Make_Defining_Identifier (Sloc (P), Nam); 17827 17828 Insert_Action (Obj_Def, 17829 Make_Subtype_Declaration (Sloc (P), 17830 Defining_Identifier => T, 17831 Subtype_Indication => Relocate_Node (Obj_Def))); 17832 17833 -- This subtype may need freezing, and this will not be done 17834 -- automatically if the object declaration is not in declarative 17835 -- part. Since this is an object declaration, the type cannot always 17836 -- be frozen here. Deferred constants do not freeze their type 17837 -- (which often enough will be private). 17838 17839 if Nkind (P) = N_Object_Declaration 17840 and then Constant_Present (P) 17841 and then No (Expression (P)) 17842 then 17843 null; 17844 17845 -- Here we freeze the base type of object type to catch premature use 17846 -- of discriminated private type without a full view. 17847 17848 else 17849 Insert_Actions (Obj_Def, Freeze_Entity (Base_Type (T), P)); 17850 end if; 17851 17852 -- Ada 2005 AI-406: the object definition in an object declaration 17853 -- can be an access definition. 17854 17855 elsif Def_Kind = N_Access_Definition then 17856 T := Access_Definition (Related_Nod, Obj_Def); 17857 17858 Set_Is_Local_Anonymous_Access 17859 (T, 17860 V => (Ada_Version < Ada_2012) 17861 or else (Nkind (P) /= N_Object_Declaration) 17862 or else Is_Library_Level_Entity (Defining_Identifier (P))); 17863 17864 -- Otherwise, the object definition is just a subtype_mark 17865 17866 else 17867 T := Process_Subtype (Obj_Def, Related_Nod); 17868 end if; 17869 17870 return T; 17871 end Find_Type_Of_Object; 17872 17873 -------------------------------- 17874 -- Find_Type_Of_Subtype_Indic -- 17875 -------------------------------- 17876 17877 function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is 17878 Typ : Entity_Id; 17879 17880 begin 17881 -- Case of subtype mark with a constraint 17882 17883 if Nkind (S) = N_Subtype_Indication then 17884 Find_Type (Subtype_Mark (S)); 17885 Typ := Entity (Subtype_Mark (S)); 17886 17887 if not 17888 Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S))) 17889 then 17890 Error_Msg_N 17891 ("incorrect constraint for this kind of type", Constraint (S)); 17892 Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); 17893 end if; 17894 17895 -- Otherwise we have a subtype mark without a constraint 17896 17897 elsif Error_Posted (S) then 17898 Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S))); 17899 return Any_Type; 17900 17901 else 17902 Find_Type (S); 17903 Typ := Entity (S); 17904 end if; 17905 17906 -- Check No_Wide_Characters restriction 17907 17908 Check_Wide_Character_Restriction (Typ, S); 17909 17910 return Typ; 17911 end Find_Type_Of_Subtype_Indic; 17912 17913 ------------------------------------- 17914 -- Floating_Point_Type_Declaration -- 17915 ------------------------------------- 17916 17917 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is 17918 Digs : constant Node_Id := Digits_Expression (Def); 17919 Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float); 17920 Digs_Val : Uint; 17921 Base_Typ : Entity_Id; 17922 Implicit_Base : Entity_Id; 17923 17924 function Can_Derive_From (E : Entity_Id) return Boolean; 17925 -- Find if given digits value, and possibly a specified range, allows 17926 -- derivation from specified type 17927 17928 procedure Convert_Bound (B : Node_Id); 17929 -- If specified, the bounds must be static but may be of different 17930 -- types. They must be converted into machine numbers of the base type, 17931 -- in accordance with RM 4.9(38). 17932 17933 function Find_Base_Type return Entity_Id; 17934 -- Find a predefined base type that Def can derive from, or generate 17935 -- an error and substitute Long_Long_Float if none exists. 17936 17937 --------------------- 17938 -- Can_Derive_From -- 17939 --------------------- 17940 17941 function Can_Derive_From (E : Entity_Id) return Boolean is 17942 Spec : constant Entity_Id := Real_Range_Specification (Def); 17943 17944 begin 17945 -- Check specified "digits" constraint 17946 17947 if Digs_Val > Digits_Value (E) then 17948 return False; 17949 end if; 17950 17951 -- Check for matching range, if specified 17952 17953 if Present (Spec) then 17954 if Expr_Value_R (Type_Low_Bound (E)) > 17955 Expr_Value_R (Low_Bound (Spec)) 17956 then 17957 return False; 17958 end if; 17959 17960 if Expr_Value_R (Type_High_Bound (E)) < 17961 Expr_Value_R (High_Bound (Spec)) 17962 then 17963 return False; 17964 end if; 17965 end if; 17966 17967 return True; 17968 end Can_Derive_From; 17969 17970 ------------------- 17971 -- Convert_Bound -- 17972 -------------------- 17973 17974 procedure Convert_Bound (B : Node_Id) is 17975 begin 17976 -- If the bound is not a literal it can only be static if it is 17977 -- a static constant, possibly of a specified type. 17978 17979 if Is_Entity_Name (B) 17980 and then Ekind (Entity (B)) = E_Constant 17981 then 17982 Rewrite (B, Constant_Value (Entity (B))); 17983 end if; 17984 17985 if Nkind (B) = N_Real_Literal then 17986 Set_Realval (B, Machine (Base_Typ, Realval (B), Round, B)); 17987 Set_Is_Machine_Number (B); 17988 Set_Etype (B, Base_Typ); 17989 end if; 17990 end Convert_Bound; 17991 17992 -------------------- 17993 -- Find_Base_Type -- 17994 -------------------- 17995 17996 function Find_Base_Type return Entity_Id is 17997 Choice : Elmt_Id := First_Elmt (Predefined_Float_Types); 17998 17999 begin 18000 -- Iterate over the predefined types in order, returning the first 18001 -- one that Def can derive from. 18002 18003 while Present (Choice) loop 18004 if Can_Derive_From (Node (Choice)) then 18005 return Node (Choice); 18006 end if; 18007 18008 Next_Elmt (Choice); 18009 end loop; 18010 18011 -- If we can't derive from any existing type, use Long_Long_Float 18012 -- and give appropriate message explaining the problem. 18013 18014 if Digs_Val > Max_Digs_Val then 18015 -- It might be the case that there is a type with the requested 18016 -- range, just not the combination of digits and range. 18017 18018 Error_Msg_N 18019 ("no predefined type has requested range and precision", 18020 Real_Range_Specification (Def)); 18021 18022 else 18023 Error_Msg_N 18024 ("range too large for any predefined type", 18025 Real_Range_Specification (Def)); 18026 end if; 18027 18028 return Standard_Long_Long_Float; 18029 end Find_Base_Type; 18030 18031 -- Start of processing for Floating_Point_Type_Declaration 18032 18033 begin 18034 Check_Restriction (No_Floating_Point, Def); 18035 18036 -- Create an implicit base type 18037 18038 Implicit_Base := 18039 Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B'); 18040 18041 -- Analyze and verify digits value 18042 18043 Analyze_And_Resolve (Digs, Any_Integer); 18044 Check_Digits_Expression (Digs); 18045 Digs_Val := Expr_Value (Digs); 18046 18047 -- Process possible range spec and find correct type to derive from 18048 18049 Process_Real_Range_Specification (Def); 18050 18051 -- Check that requested number of digits is not too high. 18052 18053 if Digs_Val > Max_Digs_Val then 18054 18055 -- The check for Max_Base_Digits may be somewhat expensive, as it 18056 -- requires reading System, so only do it when necessary. 18057 18058 declare 18059 Max_Base_Digits : constant Uint := 18060 Expr_Value 18061 (Expression 18062 (Parent (RTE (RE_Max_Base_Digits)))); 18063 18064 begin 18065 if Digs_Val > Max_Base_Digits then 18066 Error_Msg_Uint_1 := Max_Base_Digits; 18067 Error_Msg_N ("digits value out of range, maximum is ^", Digs); 18068 18069 elsif No (Real_Range_Specification (Def)) then 18070 Error_Msg_Uint_1 := Max_Digs_Val; 18071 Error_Msg_N ("types with more than ^ digits need range spec " 18072 & "(RM 3.5.7(6))", Digs); 18073 end if; 18074 end; 18075 end if; 18076 18077 -- Find a suitable type to derive from or complain and use a substitute 18078 18079 Base_Typ := Find_Base_Type; 18080 18081 -- If there are bounds given in the declaration use them as the bounds 18082 -- of the type, otherwise use the bounds of the predefined base type 18083 -- that was chosen based on the Digits value. 18084 18085 if Present (Real_Range_Specification (Def)) then 18086 Set_Scalar_Range (T, Real_Range_Specification (Def)); 18087 Set_Is_Constrained (T); 18088 18089 Convert_Bound (Type_Low_Bound (T)); 18090 Convert_Bound (Type_High_Bound (T)); 18091 18092 else 18093 Set_Scalar_Range (T, Scalar_Range (Base_Typ)); 18094 end if; 18095 18096 -- Complete definition of implicit base and declared first subtype. The 18097 -- inheritance of the rep item chain ensures that SPARK-related pragmas 18098 -- are not clobbered when the floating point type acts as a full view of 18099 -- a private type. 18100 18101 Set_Etype (Implicit_Base, Base_Typ); 18102 Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); 18103 Set_Size_Info (Implicit_Base, Base_Typ); 18104 Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); 18105 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); 18106 Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); 18107 Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); 18108 18109 Set_Ekind (T, E_Floating_Point_Subtype); 18110 Set_Etype (T, Implicit_Base); 18111 Set_Size_Info (T, Implicit_Base); 18112 Set_RM_Size (T, RM_Size (Implicit_Base)); 18113 Inherit_Rep_Item_Chain (T, Implicit_Base); 18114 Set_Digits_Value (T, Digs_Val); 18115 end Floating_Point_Type_Declaration; 18116 18117 ---------------------------- 18118 -- Get_Discriminant_Value -- 18119 ---------------------------- 18120 18121 -- This is the situation: 18122 18123 -- There is a non-derived type 18124 18125 -- type T0 (Dx, Dy, Dz...) 18126 18127 -- There are zero or more levels of derivation, with each derivation 18128 -- either purely inheriting the discriminants, or defining its own. 18129 18130 -- type Ti is new Ti-1 18131 -- or 18132 -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y) 18133 -- or 18134 -- subtype Ti is ... 18135 18136 -- The subtype issue is avoided by the use of Original_Record_Component, 18137 -- and the fact that derived subtypes also derive the constraints. 18138 18139 -- This chain leads back from 18140 18141 -- Typ_For_Constraint 18142 18143 -- Typ_For_Constraint has discriminants, and the value for each 18144 -- discriminant is given by its corresponding Elmt of Constraints. 18145 18146 -- Discriminant is some discriminant in this hierarchy 18147 18148 -- We need to return its value 18149 18150 -- We do this by recursively searching each level, and looking for 18151 -- Discriminant. Once we get to the bottom, we start backing up 18152 -- returning the value for it which may in turn be a discriminant 18153 -- further up, so on the backup we continue the substitution. 18154 18155 function Get_Discriminant_Value 18156 (Discriminant : Entity_Id; 18157 Typ_For_Constraint : Entity_Id; 18158 Constraint : Elist_Id) return Node_Id 18159 is 18160 function Root_Corresponding_Discriminant 18161 (Discr : Entity_Id) return Entity_Id; 18162 -- Given a discriminant, traverse the chain of inherited discriminants 18163 -- and return the topmost discriminant. 18164 18165 function Search_Derivation_Levels 18166 (Ti : Entity_Id; 18167 Discrim_Values : Elist_Id; 18168 Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id; 18169 -- This is the routine that performs the recursive search of levels 18170 -- as described above. 18171 18172 ------------------------------------- 18173 -- Root_Corresponding_Discriminant -- 18174 ------------------------------------- 18175 18176 function Root_Corresponding_Discriminant 18177 (Discr : Entity_Id) return Entity_Id 18178 is 18179 D : Entity_Id; 18180 18181 begin 18182 D := Discr; 18183 while Present (Corresponding_Discriminant (D)) loop 18184 D := Corresponding_Discriminant (D); 18185 end loop; 18186 18187 return D; 18188 end Root_Corresponding_Discriminant; 18189 18190 ------------------------------ 18191 -- Search_Derivation_Levels -- 18192 ------------------------------ 18193 18194 function Search_Derivation_Levels 18195 (Ti : Entity_Id; 18196 Discrim_Values : Elist_Id; 18197 Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id 18198 is 18199 Assoc : Elmt_Id; 18200 Disc : Entity_Id; 18201 Result : Node_Or_Entity_Id; 18202 Result_Entity : Node_Id; 18203 18204 begin 18205 -- If inappropriate type, return Error, this happens only in 18206 -- cascaded error situations, and we want to avoid a blow up. 18207 18208 if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then 18209 return Error; 18210 end if; 18211 18212 -- Look deeper if possible. Use Stored_Constraints only for 18213 -- untagged types. For tagged types use the given constraint. 18214 -- This asymmetry needs explanation??? 18215 18216 if not Stored_Discrim_Values 18217 and then Present (Stored_Constraint (Ti)) 18218 and then not Is_Tagged_Type (Ti) 18219 then 18220 Result := 18221 Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True); 18222 18223 else 18224 declare 18225 Td : Entity_Id := Etype (Ti); 18226 18227 begin 18228 -- If the parent type is private, the full view may include 18229 -- renamed discriminants, and it is those stored values that 18230 -- may be needed (the partial view never has more information 18231 -- than the full view). 18232 18233 if Is_Private_Type (Td) and then Present (Full_View (Td)) then 18234 Td := Full_View (Td); 18235 end if; 18236 18237 if Td = Ti then 18238 Result := Discriminant; 18239 18240 else 18241 if Present (Stored_Constraint (Ti)) then 18242 Result := 18243 Search_Derivation_Levels 18244 (Td, Stored_Constraint (Ti), True); 18245 else 18246 Result := 18247 Search_Derivation_Levels 18248 (Td, Discrim_Values, Stored_Discrim_Values); 18249 end if; 18250 end if; 18251 end; 18252 end if; 18253 18254 -- Extra underlying places to search, if not found above. For 18255 -- concurrent types, the relevant discriminant appears in the 18256 -- corresponding record. For a type derived from a private type 18257 -- without discriminant, the full view inherits the discriminants 18258 -- of the full view of the parent. 18259 18260 if Result = Discriminant then 18261 if Is_Concurrent_Type (Ti) 18262 and then Present (Corresponding_Record_Type (Ti)) 18263 then 18264 Result := 18265 Search_Derivation_Levels ( 18266 Corresponding_Record_Type (Ti), 18267 Discrim_Values, 18268 Stored_Discrim_Values); 18269 18270 elsif Is_Private_Type (Ti) 18271 and then not Has_Discriminants (Ti) 18272 and then Present (Full_View (Ti)) 18273 and then Etype (Full_View (Ti)) /= Ti 18274 then 18275 Result := 18276 Search_Derivation_Levels ( 18277 Full_View (Ti), 18278 Discrim_Values, 18279 Stored_Discrim_Values); 18280 end if; 18281 end if; 18282 18283 -- If Result is not a (reference to a) discriminant, return it, 18284 -- otherwise set Result_Entity to the discriminant. 18285 18286 if Nkind (Result) = N_Defining_Identifier then 18287 pragma Assert (Result = Discriminant); 18288 Result_Entity := Result; 18289 18290 else 18291 if not Denotes_Discriminant (Result) then 18292 return Result; 18293 end if; 18294 18295 Result_Entity := Entity (Result); 18296 end if; 18297 18298 -- See if this level of derivation actually has discriminants because 18299 -- tagged derivations can add them, hence the lower levels need not 18300 -- have any. 18301 18302 if not Has_Discriminants (Ti) then 18303 return Result; 18304 end if; 18305 18306 -- Scan Ti's discriminants for Result_Entity, and return its 18307 -- corresponding value, if any. 18308 18309 Result_Entity := Original_Record_Component (Result_Entity); 18310 18311 Assoc := First_Elmt (Discrim_Values); 18312 18313 if Stored_Discrim_Values then 18314 Disc := First_Stored_Discriminant (Ti); 18315 else 18316 Disc := First_Discriminant (Ti); 18317 end if; 18318 18319 while Present (Disc) loop 18320 18321 -- If no further associations return the discriminant, value will 18322 -- be found on the second pass. 18323 18324 if No (Assoc) then 18325 return Result; 18326 end if; 18327 18328 if Original_Record_Component (Disc) = Result_Entity then 18329 return Node (Assoc); 18330 end if; 18331 18332 Next_Elmt (Assoc); 18333 18334 if Stored_Discrim_Values then 18335 Next_Stored_Discriminant (Disc); 18336 else 18337 Next_Discriminant (Disc); 18338 end if; 18339 end loop; 18340 18341 -- Could not find it 18342 18343 return Result; 18344 end Search_Derivation_Levels; 18345 18346 -- Local Variables 18347 18348 Result : Node_Or_Entity_Id; 18349 18350 -- Start of processing for Get_Discriminant_Value 18351 18352 begin 18353 -- ??? This routine is a gigantic mess and will be deleted. For the 18354 -- time being just test for the trivial case before calling recurse. 18355 18356 -- We are now celebrating the 20th anniversary of this comment! 18357 18358 if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then 18359 declare 18360 D : Entity_Id; 18361 E : Elmt_Id; 18362 18363 begin 18364 D := First_Discriminant (Typ_For_Constraint); 18365 E := First_Elmt (Constraint); 18366 while Present (D) loop 18367 if Chars (D) = Chars (Discriminant) then 18368 return Node (E); 18369 end if; 18370 18371 Next_Discriminant (D); 18372 Next_Elmt (E); 18373 end loop; 18374 end; 18375 end if; 18376 18377 Result := Search_Derivation_Levels 18378 (Typ_For_Constraint, Constraint, False); 18379 18380 -- ??? hack to disappear when this routine is gone 18381 18382 if Nkind (Result) = N_Defining_Identifier then 18383 declare 18384 D : Entity_Id; 18385 E : Elmt_Id; 18386 18387 begin 18388 D := First_Discriminant (Typ_For_Constraint); 18389 E := First_Elmt (Constraint); 18390 while Present (D) loop 18391 if Root_Corresponding_Discriminant (D) = Discriminant then 18392 return Node (E); 18393 end if; 18394 18395 Next_Discriminant (D); 18396 Next_Elmt (E); 18397 end loop; 18398 end; 18399 end if; 18400 18401 pragma Assert (Nkind (Result) /= N_Defining_Identifier); 18402 return Result; 18403 end Get_Discriminant_Value; 18404 18405 -------------------------- 18406 -- Has_Range_Constraint -- 18407 -------------------------- 18408 18409 function Has_Range_Constraint (N : Node_Id) return Boolean is 18410 C : constant Node_Id := Constraint (N); 18411 18412 begin 18413 if Nkind (C) = N_Range_Constraint then 18414 return True; 18415 18416 elsif Nkind (C) = N_Digits_Constraint then 18417 return 18418 Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N))) 18419 or else Present (Range_Constraint (C)); 18420 18421 elsif Nkind (C) = N_Delta_Constraint then 18422 return Present (Range_Constraint (C)); 18423 18424 else 18425 return False; 18426 end if; 18427 end Has_Range_Constraint; 18428 18429 ------------------------ 18430 -- Inherit_Components -- 18431 ------------------------ 18432 18433 function Inherit_Components 18434 (N : Node_Id; 18435 Parent_Base : Entity_Id; 18436 Derived_Base : Entity_Id; 18437 Is_Tagged : Boolean; 18438 Inherit_Discr : Boolean; 18439 Discs : Elist_Id) return Elist_Id 18440 is 18441 Assoc_List : constant Elist_Id := New_Elmt_List; 18442 18443 procedure Inherit_Component 18444 (Old_C : Entity_Id; 18445 Plain_Discrim : Boolean := False; 18446 Stored_Discrim : Boolean := False); 18447 -- Inherits component Old_C from Parent_Base to the Derived_Base. If 18448 -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is 18449 -- True, Old_C is a stored discriminant. If they are both false then 18450 -- Old_C is a regular component. 18451 18452 ----------------------- 18453 -- Inherit_Component -- 18454 ----------------------- 18455 18456 procedure Inherit_Component 18457 (Old_C : Entity_Id; 18458 Plain_Discrim : Boolean := False; 18459 Stored_Discrim : Boolean := False) 18460 is 18461 procedure Set_Anonymous_Type (Id : Entity_Id); 18462 -- Id denotes the entity of an access discriminant or anonymous 18463 -- access component. Set the type of Id to either the same type of 18464 -- Old_C or create a new one depending on whether the parent and 18465 -- the child types are in the same scope. 18466 18467 ------------------------ 18468 -- Set_Anonymous_Type -- 18469 ------------------------ 18470 18471 procedure Set_Anonymous_Type (Id : Entity_Id) is 18472 Old_Typ : constant Entity_Id := Etype (Old_C); 18473 18474 begin 18475 if Scope (Parent_Base) = Scope (Derived_Base) then 18476 Set_Etype (Id, Old_Typ); 18477 18478 -- The parent and the derived type are in two different scopes. 18479 -- Reuse the type of the original discriminant / component by 18480 -- copying it in order to preserve all attributes. 18481 18482 else 18483 declare 18484 Typ : constant Entity_Id := New_Copy (Old_Typ); 18485 18486 begin 18487 Set_Etype (Id, Typ); 18488 18489 -- Since we do not generate component declarations for 18490 -- inherited components, associate the itype with the 18491 -- derived type. 18492 18493 Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base)); 18494 Set_Scope (Typ, Derived_Base); 18495 end; 18496 end if; 18497 end Set_Anonymous_Type; 18498 18499 -- Local variables and constants 18500 18501 New_C : constant Entity_Id := New_Copy (Old_C); 18502 18503 Corr_Discrim : Entity_Id; 18504 Discrim : Entity_Id; 18505 18506 -- Start of processing for Inherit_Component 18507 18508 begin 18509 pragma Assert (not Is_Tagged or not Stored_Discrim); 18510 18511 Set_Parent (New_C, Parent (Old_C)); 18512 18513 -- Regular discriminants and components must be inserted in the scope 18514 -- of the Derived_Base. Do it here. 18515 18516 if not Stored_Discrim then 18517 Enter_Name (New_C); 18518 end if; 18519 18520 -- For tagged types the Original_Record_Component must point to 18521 -- whatever this field was pointing to in the parent type. This has 18522 -- already been achieved by the call to New_Copy above. 18523 18524 if not Is_Tagged then 18525 Set_Original_Record_Component (New_C, New_C); 18526 Set_Corresponding_Record_Component (New_C, Old_C); 18527 end if; 18528 18529 -- Set the proper type of an access discriminant 18530 18531 if Ekind (New_C) = E_Discriminant 18532 and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type 18533 then 18534 Set_Anonymous_Type (New_C); 18535 end if; 18536 18537 -- If we have inherited a component then see if its Etype contains 18538 -- references to Parent_Base discriminants. In this case, replace 18539 -- these references with the constraints given in Discs. We do not 18540 -- do this for the partial view of private types because this is 18541 -- not needed (only the components of the full view will be used 18542 -- for code generation) and cause problem. We also avoid this 18543 -- transformation in some error situations. 18544 18545 if Ekind (New_C) = E_Component then 18546 18547 -- Set the proper type of an anonymous access component 18548 18549 if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then 18550 Set_Anonymous_Type (New_C); 18551 18552 elsif (Is_Private_Type (Derived_Base) 18553 and then not Is_Generic_Type (Derived_Base)) 18554 or else (Is_Empty_Elmt_List (Discs) 18555 and then not Expander_Active) 18556 then 18557 Set_Etype (New_C, Etype (Old_C)); 18558 18559 else 18560 -- The current component introduces a circularity of the 18561 -- following kind: 18562 18563 -- limited with Pack_2; 18564 -- package Pack_1 is 18565 -- type T_1 is tagged record 18566 -- Comp : access Pack_2.T_2; 18567 -- ... 18568 -- end record; 18569 -- end Pack_1; 18570 18571 -- with Pack_1; 18572 -- package Pack_2 is 18573 -- type T_2 is new Pack_1.T_1 with ...; 18574 -- end Pack_2; 18575 18576 Set_Etype 18577 (New_C, 18578 Constrain_Component_Type 18579 (Old_C, Derived_Base, N, Parent_Base, Discs)); 18580 end if; 18581 end if; 18582 18583 -- In derived tagged types it is illegal to reference a non 18584 -- discriminant component in the parent type. To catch this, mark 18585 -- these components with an Ekind of E_Void. This will be reset in 18586 -- Record_Type_Definition after processing the record extension of 18587 -- the derived type. 18588 18589 -- If the declaration is a private extension, there is no further 18590 -- record extension to process, and the components retain their 18591 -- current kind, because they are visible at this point. 18592 18593 if Is_Tagged and then Ekind (New_C) = E_Component 18594 and then Nkind (N) /= N_Private_Extension_Declaration 18595 then 18596 Set_Ekind (New_C, E_Void); 18597 end if; 18598 18599 if Plain_Discrim then 18600 Set_Corresponding_Discriminant (New_C, Old_C); 18601 Build_Discriminal (New_C); 18602 18603 -- If we are explicitly inheriting a stored discriminant it will be 18604 -- completely hidden. 18605 18606 elsif Stored_Discrim then 18607 Set_Corresponding_Discriminant (New_C, Empty); 18608 Set_Discriminal (New_C, Empty); 18609 Set_Is_Completely_Hidden (New_C); 18610 18611 -- Set the Original_Record_Component of each discriminant in the 18612 -- derived base to point to the corresponding stored that we just 18613 -- created. 18614 18615 Discrim := First_Discriminant (Derived_Base); 18616 while Present (Discrim) loop 18617 Corr_Discrim := Corresponding_Discriminant (Discrim); 18618 18619 -- Corr_Discrim could be missing in an error situation 18620 18621 if Present (Corr_Discrim) 18622 and then Original_Record_Component (Corr_Discrim) = Old_C 18623 then 18624 Set_Original_Record_Component (Discrim, New_C); 18625 Set_Corresponding_Record_Component (Discrim, Empty); 18626 end if; 18627 18628 Next_Discriminant (Discrim); 18629 end loop; 18630 18631 Append_Entity (New_C, Derived_Base); 18632 end if; 18633 18634 if not Is_Tagged then 18635 Append_Elmt (Old_C, Assoc_List); 18636 Append_Elmt (New_C, Assoc_List); 18637 end if; 18638 end Inherit_Component; 18639 18640 -- Variables local to Inherit_Component 18641 18642 Loc : constant Source_Ptr := Sloc (N); 18643 18644 Parent_Discrim : Entity_Id; 18645 Stored_Discrim : Entity_Id; 18646 D : Entity_Id; 18647 Component : Entity_Id; 18648 18649 -- Start of processing for Inherit_Components 18650 18651 begin 18652 if not Is_Tagged then 18653 Append_Elmt (Parent_Base, Assoc_List); 18654 Append_Elmt (Derived_Base, Assoc_List); 18655 end if; 18656 18657 -- Inherit parent discriminants if needed 18658 18659 if Inherit_Discr then 18660 Parent_Discrim := First_Discriminant (Parent_Base); 18661 while Present (Parent_Discrim) loop 18662 Inherit_Component (Parent_Discrim, Plain_Discrim => True); 18663 Next_Discriminant (Parent_Discrim); 18664 end loop; 18665 end if; 18666 18667 -- Create explicit stored discrims for untagged types when necessary 18668 18669 if not Has_Unknown_Discriminants (Derived_Base) 18670 and then Has_Discriminants (Parent_Base) 18671 and then not Is_Tagged 18672 and then 18673 (not Inherit_Discr 18674 or else First_Discriminant (Parent_Base) /= 18675 First_Stored_Discriminant (Parent_Base)) 18676 then 18677 Stored_Discrim := First_Stored_Discriminant (Parent_Base); 18678 while Present (Stored_Discrim) loop 18679 Inherit_Component (Stored_Discrim, Stored_Discrim => True); 18680 Next_Stored_Discriminant (Stored_Discrim); 18681 end loop; 18682 end if; 18683 18684 -- See if we can apply the second transformation for derived types, as 18685 -- explained in point 6. in the comments above Build_Derived_Record_Type 18686 -- This is achieved by appending Derived_Base discriminants into Discs, 18687 -- which has the side effect of returning a non empty Discs list to the 18688 -- caller of Inherit_Components, which is what we want. This must be 18689 -- done for private derived types if there are explicit stored 18690 -- discriminants, to ensure that we can retrieve the values of the 18691 -- constraints provided in the ancestors. 18692 18693 if Inherit_Discr 18694 and then Is_Empty_Elmt_List (Discs) 18695 and then Present (First_Discriminant (Derived_Base)) 18696 and then 18697 (not Is_Private_Type (Derived_Base) 18698 or else Is_Completely_Hidden 18699 (First_Stored_Discriminant (Derived_Base)) 18700 or else Is_Generic_Type (Derived_Base)) 18701 then 18702 D := First_Discriminant (Derived_Base); 18703 while Present (D) loop 18704 Append_Elmt (New_Occurrence_Of (D, Loc), Discs); 18705 Next_Discriminant (D); 18706 end loop; 18707 end if; 18708 18709 -- Finally, inherit non-discriminant components unless they are not 18710 -- visible because defined or inherited from the full view of the 18711 -- parent. Don't inherit the _parent field of the parent type. 18712 18713 Component := First_Entity (Parent_Base); 18714 while Present (Component) loop 18715 18716 -- Ada 2005 (AI-251): Do not inherit components associated with 18717 -- secondary tags of the parent. 18718 18719 if Ekind (Component) = E_Component 18720 and then Present (Related_Type (Component)) 18721 then 18722 null; 18723 18724 elsif Ekind (Component) /= E_Component 18725 or else Chars (Component) = Name_uParent 18726 then 18727 null; 18728 18729 -- If the derived type is within the parent type's declarative 18730 -- region, then the components can still be inherited even though 18731 -- they aren't visible at this point. This can occur for cases 18732 -- such as within public child units where the components must 18733 -- become visible upon entering the child unit's private part. 18734 18735 elsif not Is_Visible_Component (Component) 18736 and then not In_Open_Scopes (Scope (Parent_Base)) 18737 then 18738 null; 18739 18740 elsif Ekind (Derived_Base) in E_Private_Type | E_Limited_Private_Type 18741 then 18742 null; 18743 18744 else 18745 Inherit_Component (Component); 18746 end if; 18747 18748 Next_Entity (Component); 18749 end loop; 18750 18751 -- For tagged derived types, inherited discriminants cannot be used in 18752 -- component declarations of the record extension part. To achieve this 18753 -- we mark the inherited discriminants as not visible. 18754 18755 if Is_Tagged and then Inherit_Discr then 18756 D := First_Discriminant (Derived_Base); 18757 while Present (D) loop 18758 Set_Is_Immediately_Visible (D, False); 18759 Next_Discriminant (D); 18760 end loop; 18761 end if; 18762 18763 return Assoc_List; 18764 end Inherit_Components; 18765 18766 ---------------------- 18767 -- Is_EVF_Procedure -- 18768 ---------------------- 18769 18770 function Is_EVF_Procedure (Subp : Entity_Id) return Boolean is 18771 Formal : Entity_Id; 18772 18773 begin 18774 -- Examine the formals of an Extensions_Visible False procedure looking 18775 -- for a controlling OUT parameter. 18776 18777 if Ekind (Subp) = E_Procedure 18778 and then Extensions_Visible_Status (Subp) = Extensions_Visible_False 18779 then 18780 Formal := First_Formal (Subp); 18781 while Present (Formal) loop 18782 if Ekind (Formal) = E_Out_Parameter 18783 and then Is_Controlling_Formal (Formal) 18784 then 18785 return True; 18786 end if; 18787 18788 Next_Formal (Formal); 18789 end loop; 18790 end if; 18791 18792 return False; 18793 end Is_EVF_Procedure; 18794 18795 ----------------------- 18796 -- Is_Null_Extension -- 18797 ----------------------- 18798 18799 function Is_Null_Extension (T : Entity_Id) return Boolean is 18800 Type_Decl : constant Node_Id := Parent (Base_Type (T)); 18801 Comp_List : Node_Id; 18802 Comp : Node_Id; 18803 18804 begin 18805 if Nkind (Type_Decl) /= N_Full_Type_Declaration 18806 or else not Is_Tagged_Type (T) 18807 or else Nkind (Type_Definition (Type_Decl)) /= 18808 N_Derived_Type_Definition 18809 or else No (Record_Extension_Part (Type_Definition (Type_Decl))) 18810 then 18811 return False; 18812 end if; 18813 18814 Comp_List := 18815 Component_List (Record_Extension_Part (Type_Definition (Type_Decl))); 18816 18817 if Present (Discriminant_Specifications (Type_Decl)) then 18818 return False; 18819 18820 elsif Present (Comp_List) 18821 and then Is_Non_Empty_List (Component_Items (Comp_List)) 18822 then 18823 Comp := First (Component_Items (Comp_List)); 18824 18825 -- Only user-defined components are relevant. The component list 18826 -- may also contain a parent component and internal components 18827 -- corresponding to secondary tags, but these do not determine 18828 -- whether this is a null extension. 18829 18830 while Present (Comp) loop 18831 if Comes_From_Source (Comp) then 18832 return False; 18833 end if; 18834 18835 Next (Comp); 18836 end loop; 18837 18838 return True; 18839 18840 else 18841 return True; 18842 end if; 18843 end Is_Null_Extension; 18844 18845 -------------------------- 18846 -- Is_Private_Primitive -- 18847 -------------------------- 18848 18849 function Is_Private_Primitive (Prim : Entity_Id) return Boolean is 18850 Prim_Scope : constant Entity_Id := Scope (Prim); 18851 Priv_Entity : Entity_Id; 18852 begin 18853 if Is_Package_Or_Generic_Package (Prim_Scope) then 18854 Priv_Entity := First_Private_Entity (Prim_Scope); 18855 18856 while Present (Priv_Entity) loop 18857 if Priv_Entity = Prim then 18858 return True; 18859 end if; 18860 18861 Next_Entity (Priv_Entity); 18862 end loop; 18863 end if; 18864 18865 return False; 18866 end Is_Private_Primitive; 18867 18868 ------------------------------ 18869 -- Is_Valid_Constraint_Kind -- 18870 ------------------------------ 18871 18872 function Is_Valid_Constraint_Kind 18873 (T_Kind : Type_Kind; 18874 Constraint_Kind : Node_Kind) return Boolean 18875 is 18876 begin 18877 case T_Kind is 18878 when Enumeration_Kind 18879 | Integer_Kind 18880 => 18881 return Constraint_Kind = N_Range_Constraint; 18882 18883 when Decimal_Fixed_Point_Kind => 18884 return Constraint_Kind in N_Digits_Constraint | N_Range_Constraint; 18885 18886 when Ordinary_Fixed_Point_Kind => 18887 return Constraint_Kind in N_Delta_Constraint | N_Range_Constraint; 18888 18889 when Float_Kind => 18890 return Constraint_Kind in N_Digits_Constraint | N_Range_Constraint; 18891 18892 when Access_Kind 18893 | Array_Kind 18894 | Class_Wide_Kind 18895 | Concurrent_Kind 18896 | Private_Kind 18897 | E_Incomplete_Type 18898 | E_Record_Subtype 18899 | E_Record_Type 18900 => 18901 return Constraint_Kind = N_Index_Or_Discriminant_Constraint; 18902 18903 when others => 18904 return True; -- Error will be detected later 18905 end case; 18906 end Is_Valid_Constraint_Kind; 18907 18908 -------------------------- 18909 -- Is_Visible_Component -- 18910 -------------------------- 18911 18912 function Is_Visible_Component 18913 (C : Entity_Id; 18914 N : Node_Id := Empty) return Boolean 18915 is 18916 Original_Comp : Entity_Id := Empty; 18917 Original_Type : Entity_Id; 18918 Type_Scope : Entity_Id; 18919 18920 function Is_Local_Type (Typ : Entity_Id) return Boolean; 18921 -- Check whether parent type of inherited component is declared locally, 18922 -- possibly within a nested package or instance. The current scope is 18923 -- the derived record itself. 18924 18925 ------------------- 18926 -- Is_Local_Type -- 18927 ------------------- 18928 18929 function Is_Local_Type (Typ : Entity_Id) return Boolean is 18930 Scop : Entity_Id; 18931 18932 begin 18933 Scop := Scope (Typ); 18934 while Present (Scop) 18935 and then Scop /= Standard_Standard 18936 loop 18937 if Scop = Scope (Current_Scope) then 18938 return True; 18939 end if; 18940 18941 Scop := Scope (Scop); 18942 end loop; 18943 18944 return False; 18945 end Is_Local_Type; 18946 18947 -- Start of processing for Is_Visible_Component 18948 18949 begin 18950 if Ekind (C) in E_Component | E_Discriminant then 18951 Original_Comp := Original_Record_Component (C); 18952 end if; 18953 18954 if No (Original_Comp) then 18955 18956 -- Premature usage, or previous error 18957 18958 return False; 18959 18960 else 18961 Original_Type := Scope (Original_Comp); 18962 Type_Scope := Scope (Base_Type (Scope (C))); 18963 end if; 18964 18965 -- This test only concerns tagged types 18966 18967 if not Is_Tagged_Type (Original_Type) then 18968 18969 -- Check if this is a renamed discriminant (hidden either by the 18970 -- derived type or by some ancestor), unless we are analyzing code 18971 -- generated by the expander since it may reference such components 18972 -- (for example see the expansion of Deep_Adjust). 18973 18974 if Ekind (C) = E_Discriminant and then Present (N) then 18975 return 18976 not Comes_From_Source (N) 18977 or else not Is_Completely_Hidden (C); 18978 else 18979 return True; 18980 end if; 18981 18982 -- If it is _Parent or _Tag, there is no visibility issue 18983 18984 elsif not Comes_From_Source (Original_Comp) then 18985 return True; 18986 18987 -- Discriminants are visible unless the (private) type has unknown 18988 -- discriminants. If the discriminant reference is inserted for a 18989 -- discriminant check on a full view it is also visible. 18990 18991 elsif Ekind (Original_Comp) = E_Discriminant 18992 and then 18993 (not Has_Unknown_Discriminants (Original_Type) 18994 or else (Present (N) 18995 and then Nkind (N) = N_Selected_Component 18996 and then Nkind (Prefix (N)) = N_Type_Conversion 18997 and then not Comes_From_Source (Prefix (N)))) 18998 then 18999 return True; 19000 19001 -- If the component has been declared in an ancestor which is currently 19002 -- a private type, then it is not visible. The same applies if the 19003 -- component's containing type is not in an open scope and the original 19004 -- component's enclosing type is a visible full view of a private type 19005 -- (which can occur in cases where an attempt is being made to reference 19006 -- a component in a sibling package that is inherited from a visible 19007 -- component of a type in an ancestor package; the component in the 19008 -- sibling package should not be visible even though the component it 19009 -- inherited from is visible), but instance bodies are not subject to 19010 -- this second case since they have the Has_Private_View mechanism to 19011 -- ensure proper visibility. This does not apply however in the case 19012 -- where the scope of the type is a private child unit, or when the 19013 -- parent comes from a local package in which the ancestor is currently 19014 -- visible. The latter suppression of visibility is needed for cases 19015 -- that are tested in B730006. 19016 19017 elsif Is_Private_Type (Original_Type) 19018 or else 19019 (not Is_Private_Descendant (Type_Scope) 19020 and then not In_Open_Scopes (Type_Scope) 19021 and then Has_Private_Declaration (Original_Type) 19022 and then not In_Instance_Body) 19023 then 19024 -- If the type derives from an entity in a formal package, there 19025 -- are no additional visible components. 19026 19027 if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) = 19028 N_Formal_Package_Declaration 19029 then 19030 return False; 19031 19032 -- if we are not in the private part of the current package, there 19033 -- are no additional visible components. 19034 19035 elsif Ekind (Scope (Current_Scope)) = E_Package 19036 and then not In_Private_Part (Scope (Current_Scope)) 19037 then 19038 return False; 19039 else 19040 return 19041 Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) 19042 and then In_Open_Scopes (Scope (Original_Type)) 19043 and then Is_Local_Type (Type_Scope); 19044 end if; 19045 19046 -- There is another weird way in which a component may be invisible when 19047 -- the private and the full view are not derived from the same ancestor. 19048 -- Here is an example : 19049 19050 -- type A1 is tagged record F1 : integer; end record; 19051 -- type A2 is new A1 with record F2 : integer; end record; 19052 -- type T is new A1 with private; 19053 -- private 19054 -- type T is new A2 with null record; 19055 19056 -- In this case, the full view of T inherits F1 and F2 but the private 19057 -- view inherits only F1 19058 19059 else 19060 declare 19061 Ancestor : Entity_Id := Scope (C); 19062 19063 begin 19064 loop 19065 if Ancestor = Original_Type then 19066 return True; 19067 19068 -- The ancestor may have a partial view of the original type, 19069 -- but if the full view is in scope, as in a child body, the 19070 -- component is visible. 19071 19072 elsif In_Private_Part (Scope (Original_Type)) 19073 and then Full_View (Ancestor) = Original_Type 19074 then 19075 return True; 19076 19077 elsif Ancestor = Etype (Ancestor) then 19078 19079 -- No further ancestors to examine 19080 19081 return False; 19082 end if; 19083 19084 Ancestor := Etype (Ancestor); 19085 end loop; 19086 end; 19087 end if; 19088 end Is_Visible_Component; 19089 19090 -------------------------- 19091 -- Make_Class_Wide_Type -- 19092 -------------------------- 19093 19094 procedure Make_Class_Wide_Type (T : Entity_Id) is 19095 CW_Type : Entity_Id; 19096 CW_Name : Name_Id; 19097 Next_E : Entity_Id; 19098 Prev_E : Entity_Id; 19099 19100 begin 19101 if Present (Class_Wide_Type (T)) then 19102 19103 -- The class-wide type is a partially decorated entity created for a 19104 -- unanalyzed tagged type referenced through a limited with clause. 19105 -- When the tagged type is analyzed, its class-wide type needs to be 19106 -- redecorated. Note that we reuse the entity created by Decorate_ 19107 -- Tagged_Type in order to preserve all links. 19108 19109 if Materialize_Entity (Class_Wide_Type (T)) then 19110 CW_Type := Class_Wide_Type (T); 19111 Set_Materialize_Entity (CW_Type, False); 19112 19113 -- The class wide type can have been defined by the partial view, in 19114 -- which case everything is already done. 19115 19116 else 19117 return; 19118 end if; 19119 19120 -- Default case, we need to create a new class-wide type 19121 19122 else 19123 CW_Type := 19124 New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T'); 19125 end if; 19126 19127 -- Inherit root type characteristics 19128 19129 CW_Name := Chars (CW_Type); 19130 Next_E := Next_Entity (CW_Type); 19131 Prev_E := Prev_Entity (CW_Type); 19132 Copy_Node (T, CW_Type); 19133 Set_Comes_From_Source (CW_Type, False); 19134 Set_Chars (CW_Type, CW_Name); 19135 Set_Parent (CW_Type, Parent (T)); 19136 Set_Prev_Entity (CW_Type, Prev_E); 19137 Set_Next_Entity (CW_Type, Next_E); 19138 19139 -- Ensure we have a new freeze node for the class-wide type. The partial 19140 -- view may have freeze action of its own, requiring a proper freeze 19141 -- node, and the same freeze node cannot be shared between the two 19142 -- types. 19143 19144 Set_Has_Delayed_Freeze (CW_Type); 19145 Set_Freeze_Node (CW_Type, Empty); 19146 19147 -- Customize the class-wide type: It has no prim. op., it cannot be 19148 -- abstract, its Etype points back to the specific root type, and it 19149 -- cannot have any invariants. 19150 19151 Set_Ekind (CW_Type, E_Class_Wide_Type); 19152 Set_Is_Tagged_Type (CW_Type, True); 19153 Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); 19154 Set_Is_Abstract_Type (CW_Type, False); 19155 Set_Is_Constrained (CW_Type, False); 19156 Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); 19157 Set_Default_SSO (CW_Type); 19158 Set_Has_Inheritable_Invariants (CW_Type, False); 19159 Set_Has_Inherited_Invariants (CW_Type, False); 19160 Set_Has_Own_Invariants (CW_Type, False); 19161 19162 if Ekind (T) = E_Class_Wide_Subtype then 19163 Set_Etype (CW_Type, Etype (Base_Type (T))); 19164 else 19165 Set_Etype (CW_Type, T); 19166 end if; 19167 19168 Set_No_Tagged_Streams_Pragma (CW_Type, No_Tagged_Streams); 19169 19170 -- If this is the class_wide type of a constrained subtype, it does 19171 -- not have discriminants. 19172 19173 Set_Has_Discriminants (CW_Type, 19174 Has_Discriminants (T) and then not Is_Constrained (T)); 19175 19176 Set_Has_Unknown_Discriminants (CW_Type, True); 19177 Set_Class_Wide_Type (T, CW_Type); 19178 Set_Equivalent_Type (CW_Type, Empty); 19179 19180 -- The class-wide type of a class-wide type is itself (RM 3.9(14)) 19181 19182 Set_Class_Wide_Type (CW_Type, CW_Type); 19183 end Make_Class_Wide_Type; 19184 19185 ---------------- 19186 -- Make_Index -- 19187 ---------------- 19188 19189 procedure Make_Index 19190 (N : Node_Id; 19191 Related_Nod : Node_Id; 19192 Related_Id : Entity_Id := Empty; 19193 Suffix_Index : Pos := 1) 19194 is 19195 R : Node_Id; 19196 T : Entity_Id; 19197 Def_Id : Entity_Id := Empty; 19198 Found : Boolean := False; 19199 19200 begin 19201 -- For a discrete range used in a constrained array definition and 19202 -- defined by a range, an implicit conversion to the predefined type 19203 -- INTEGER is assumed if each bound is either a numeric literal, a named 19204 -- number, or an attribute, and the type of both bounds (prior to the 19205 -- implicit conversion) is the type universal_integer. Otherwise, both 19206 -- bounds must be of the same discrete type, other than universal 19207 -- integer; this type must be determinable independently of the 19208 -- context, but using the fact that the type must be discrete and that 19209 -- both bounds must have the same type. 19210 19211 -- Character literals also have a universal type in the absence of 19212 -- of additional context, and are resolved to Standard_Character. 19213 19214 if Nkind (N) = N_Range then 19215 19216 -- The index is given by a range constraint. The bounds are known 19217 -- to be of a consistent type. 19218 19219 if not Is_Overloaded (N) then 19220 T := Etype (N); 19221 19222 -- For universal bounds, choose the specific predefined type 19223 19224 if T = Universal_Integer then 19225 T := Standard_Integer; 19226 19227 elsif T = Any_Character then 19228 Ambiguous_Character (Low_Bound (N)); 19229 19230 T := Standard_Character; 19231 end if; 19232 19233 -- The node may be overloaded because some user-defined operators 19234 -- are available, but if a universal interpretation exists it is 19235 -- also the selected one. 19236 19237 elsif Universal_Interpretation (N) = Universal_Integer then 19238 T := Standard_Integer; 19239 19240 else 19241 T := Any_Type; 19242 19243 declare 19244 Ind : Interp_Index; 19245 It : Interp; 19246 19247 begin 19248 Get_First_Interp (N, Ind, It); 19249 while Present (It.Typ) loop 19250 if Is_Discrete_Type (It.Typ) then 19251 19252 if Found 19253 and then not Covers (It.Typ, T) 19254 and then not Covers (T, It.Typ) 19255 then 19256 Error_Msg_N ("ambiguous bounds in discrete range", N); 19257 exit; 19258 else 19259 T := It.Typ; 19260 Found := True; 19261 end if; 19262 end if; 19263 19264 Get_Next_Interp (Ind, It); 19265 end loop; 19266 19267 if T = Any_Type then 19268 Error_Msg_N ("discrete type required for range", N); 19269 Set_Etype (N, Any_Type); 19270 return; 19271 19272 elsif T = Universal_Integer then 19273 T := Standard_Integer; 19274 end if; 19275 end; 19276 end if; 19277 19278 if not Is_Discrete_Type (T) then 19279 Error_Msg_N ("discrete type required for range", N); 19280 Set_Etype (N, Any_Type); 19281 return; 19282 end if; 19283 19284 -- If the range bounds are "T'Low .. T'High" where T is a name of 19285 -- a discrete type, then use T as the type of the index. 19286 19287 if Nkind (Low_Bound (N)) = N_Attribute_Reference 19288 and then Attribute_Name (Low_Bound (N)) = Name_First 19289 and then Is_Entity_Name (Prefix (Low_Bound (N))) 19290 and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N)))) 19291 19292 and then Nkind (High_Bound (N)) = N_Attribute_Reference 19293 and then Attribute_Name (High_Bound (N)) = Name_Last 19294 and then Is_Entity_Name (Prefix (High_Bound (N))) 19295 and then Entity (Prefix (High_Bound (N))) = Def_Id 19296 then 19297 Def_Id := Entity (Prefix (Low_Bound (N))); 19298 end if; 19299 19300 R := N; 19301 Process_Range_Expr_In_Decl (R, T); 19302 19303 elsif Nkind (N) = N_Subtype_Indication then 19304 19305 -- The index is given by a subtype with a range constraint 19306 19307 T := Base_Type (Entity (Subtype_Mark (N))); 19308 19309 if not Is_Discrete_Type (T) then 19310 Error_Msg_N ("discrete type required for range", N); 19311 Set_Etype (N, Any_Type); 19312 return; 19313 end if; 19314 19315 R := Range_Expression (Constraint (N)); 19316 19317 Resolve (R, T); 19318 Process_Range_Expr_In_Decl (R, Entity (Subtype_Mark (N))); 19319 19320 elsif Nkind (N) = N_Attribute_Reference then 19321 19322 -- Catch beginner's error (use of attribute other than 'Range) 19323 19324 if Attribute_Name (N) /= Name_Range then 19325 Error_Msg_N ("expect attribute ''Range", N); 19326 Set_Etype (N, Any_Type); 19327 return; 19328 end if; 19329 19330 -- If the node denotes the range of a type mark, that is also the 19331 -- resulting type, and we do not need to create an Itype for it. 19332 19333 if Is_Entity_Name (Prefix (N)) 19334 and then Comes_From_Source (N) 19335 and then Is_Discrete_Type (Entity (Prefix (N))) 19336 then 19337 Def_Id := Entity (Prefix (N)); 19338 end if; 19339 19340 Analyze_And_Resolve (N); 19341 T := Etype (N); 19342 R := N; 19343 19344 -- If none of the above, must be a subtype. We convert this to a 19345 -- range attribute reference because in the case of declared first 19346 -- named subtypes, the types in the range reference can be different 19347 -- from the type of the entity. A range attribute normalizes the 19348 -- reference and obtains the correct types for the bounds. 19349 19350 -- This transformation is in the nature of an expansion, is only 19351 -- done if expansion is active. In particular, it is not done on 19352 -- formal generic types, because we need to retain the name of the 19353 -- original index for instantiation purposes. 19354 19355 else 19356 if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then 19357 Error_Msg_N ("invalid subtype mark in discrete range ", N); 19358 Set_Etype (N, Any_Integer); 19359 return; 19360 19361 else 19362 -- The type mark may be that of an incomplete type. It is only 19363 -- now that we can get the full view, previous analysis does 19364 -- not look specifically for a type mark. 19365 19366 Set_Entity (N, Get_Full_View (Entity (N))); 19367 Set_Etype (N, Entity (N)); 19368 Def_Id := Entity (N); 19369 19370 if not Is_Discrete_Type (Def_Id) then 19371 Error_Msg_N ("discrete type required for index", N); 19372 Set_Etype (N, Any_Type); 19373 return; 19374 end if; 19375 end if; 19376 19377 if Expander_Active then 19378 Rewrite (N, 19379 Make_Attribute_Reference (Sloc (N), 19380 Attribute_Name => Name_Range, 19381 Prefix => Relocate_Node (N))); 19382 19383 -- The original was a subtype mark that does not freeze. This 19384 -- means that the rewritten version must not freeze either. 19385 19386 Set_Must_Not_Freeze (N); 19387 Set_Must_Not_Freeze (Prefix (N)); 19388 Analyze_And_Resolve (N); 19389 T := Etype (N); 19390 R := N; 19391 19392 -- If expander is inactive, type is legal, nothing else to construct 19393 19394 else 19395 return; 19396 end if; 19397 end if; 19398 19399 if not Is_Discrete_Type (T) then 19400 Error_Msg_N ("discrete type required for range", N); 19401 Set_Etype (N, Any_Type); 19402 return; 19403 19404 elsif T = Any_Type then 19405 Set_Etype (N, Any_Type); 19406 return; 19407 end if; 19408 19409 -- We will now create the appropriate Itype to describe the range, but 19410 -- first a check. If we originally had a subtype, then we just label 19411 -- the range with this subtype. Not only is there no need to construct 19412 -- a new subtype, but it is wrong to do so for two reasons: 19413 19414 -- 1. A legality concern, if we have a subtype, it must not freeze, 19415 -- and the Itype would cause freezing incorrectly 19416 19417 -- 2. An efficiency concern, if we created an Itype, it would not be 19418 -- recognized as the same type for the purposes of eliminating 19419 -- checks in some circumstances. 19420 19421 -- We signal this case by setting the subtype entity in Def_Id 19422 19423 if No (Def_Id) then 19424 Def_Id := 19425 Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index); 19426 Set_Etype (Def_Id, Base_Type (T)); 19427 19428 if Is_Signed_Integer_Type (T) then 19429 Set_Ekind (Def_Id, E_Signed_Integer_Subtype); 19430 19431 elsif Is_Modular_Integer_Type (T) then 19432 Set_Ekind (Def_Id, E_Modular_Integer_Subtype); 19433 19434 else 19435 Set_Ekind (Def_Id, E_Enumeration_Subtype); 19436 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 19437 Set_First_Literal (Def_Id, First_Literal (T)); 19438 end if; 19439 19440 Set_Size_Info (Def_Id, (T)); 19441 Set_RM_Size (Def_Id, RM_Size (T)); 19442 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 19443 19444 Set_Scalar_Range (Def_Id, R); 19445 Conditional_Delay (Def_Id, T); 19446 19447 -- In the subtype indication case inherit properties of the parent 19448 19449 if Nkind (N) = N_Subtype_Indication then 19450 19451 -- It is enough to inherit predicate flags and not the predicate 19452 -- functions, because predicates on an index type are illegal 19453 -- anyway and the flags are enough to detect them. 19454 19455 Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N))); 19456 19457 -- If the immediate parent of the new subtype is nonstatic, then 19458 -- the subtype we create is nonstatic as well, even if its bounds 19459 -- are static. 19460 19461 if not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) then 19462 Set_Is_Non_Static_Subtype (Def_Id); 19463 end if; 19464 end if; 19465 end if; 19466 19467 -- Final step is to label the index with this constructed type 19468 19469 Set_Etype (N, Def_Id); 19470 end Make_Index; 19471 19472 ------------------------------ 19473 -- Modular_Type_Declaration -- 19474 ------------------------------ 19475 19476 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is 19477 Mod_Expr : constant Node_Id := Expression (Def); 19478 M_Val : Uint; 19479 19480 procedure Set_Modular_Size (Bits : Int); 19481 -- Sets RM_Size to Bits, and Esize to normal word size above this 19482 19483 ---------------------- 19484 -- Set_Modular_Size -- 19485 ---------------------- 19486 19487 procedure Set_Modular_Size (Bits : Int) is 19488 Siz : Int; 19489 19490 begin 19491 Set_RM_Size (T, UI_From_Int (Bits)); 19492 19493 if Bits < System_Max_Binary_Modulus_Power then 19494 Siz := 8; 19495 19496 while Siz < 128 loop 19497 exit when Bits <= Siz; 19498 Siz := Siz * 2; 19499 end loop; 19500 19501 Init_Esize (T, Siz); 19502 19503 else 19504 Init_Esize (T, System_Max_Binary_Modulus_Power); 19505 end if; 19506 19507 if not Non_Binary_Modulus (T) and then Esize (T) = RM_Size (T) then 19508 Set_Is_Known_Valid (T); 19509 end if; 19510 end Set_Modular_Size; 19511 19512 -- Start of processing for Modular_Type_Declaration 19513 19514 begin 19515 -- If the mod expression is (exactly) 2 * literal, where literal is 19516 -- 128 or less,then almost certainly the * was meant to be **. Warn. 19517 19518 if Warn_On_Suspicious_Modulus_Value 19519 and then Nkind (Mod_Expr) = N_Op_Multiply 19520 and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal 19521 and then Intval (Left_Opnd (Mod_Expr)) = Uint_2 19522 and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal 19523 and then Intval (Right_Opnd (Mod_Expr)) <= Uint_128 19524 then 19525 Error_Msg_N 19526 ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr); 19527 end if; 19528 19529 -- Proceed with analysis of mod expression 19530 19531 Analyze_And_Resolve (Mod_Expr, Any_Integer); 19532 Set_Etype (T, T); 19533 Set_Ekind (T, E_Modular_Integer_Type); 19534 Init_Alignment (T); 19535 Set_Is_Constrained (T); 19536 19537 if not Is_OK_Static_Expression (Mod_Expr) then 19538 Flag_Non_Static_Expr 19539 ("non-static expression used for modular type bound!", Mod_Expr); 19540 M_Val := 2 ** System_Max_Binary_Modulus_Power; 19541 else 19542 M_Val := Expr_Value (Mod_Expr); 19543 end if; 19544 19545 if M_Val < 1 then 19546 Error_Msg_N ("modulus value must be positive", Mod_Expr); 19547 M_Val := 2 ** System_Max_Binary_Modulus_Power; 19548 end if; 19549 19550 if M_Val > 2 ** Standard_Long_Integer_Size then 19551 Check_Restriction (No_Long_Long_Integers, Mod_Expr); 19552 end if; 19553 19554 Set_Modulus (T, M_Val); 19555 19556 -- Create bounds for the modular type based on the modulus given in 19557 -- the type declaration and then analyze and resolve those bounds. 19558 19559 Set_Scalar_Range (T, 19560 Make_Range (Sloc (Mod_Expr), 19561 Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0), 19562 High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1))); 19563 19564 -- Properly analyze the literals for the range. We do this manually 19565 -- because we can't go calling Resolve, since we are resolving these 19566 -- bounds with the type, and this type is certainly not complete yet. 19567 19568 Set_Etype (Low_Bound (Scalar_Range (T)), T); 19569 Set_Etype (High_Bound (Scalar_Range (T)), T); 19570 Set_Is_Static_Expression (Low_Bound (Scalar_Range (T))); 19571 Set_Is_Static_Expression (High_Bound (Scalar_Range (T))); 19572 19573 -- Loop through powers of two to find number of bits required 19574 19575 for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop 19576 19577 -- Binary case 19578 19579 if M_Val = 2 ** Bits then 19580 Set_Modular_Size (Bits); 19581 return; 19582 19583 -- Nonbinary case 19584 19585 elsif M_Val < 2 ** Bits then 19586 Set_Non_Binary_Modulus (T); 19587 19588 if Bits > System_Max_Nonbinary_Modulus_Power then 19589 Error_Msg_Uint_1 := 19590 UI_From_Int (System_Max_Nonbinary_Modulus_Power); 19591 Error_Msg_F 19592 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr); 19593 Set_Modular_Size (System_Max_Binary_Modulus_Power); 19594 return; 19595 19596 else 19597 -- In the nonbinary case, set size as per RM 13.3(55) 19598 19599 Set_Modular_Size (Bits); 19600 return; 19601 end if; 19602 end if; 19603 19604 end loop; 19605 19606 -- If we fall through, then the size exceed System.Max_Binary_Modulus 19607 -- so we just signal an error and set the maximum size. 19608 19609 Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power); 19610 Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr); 19611 19612 Set_Modular_Size (System_Max_Binary_Modulus_Power); 19613 Init_Alignment (T); 19614 19615 end Modular_Type_Declaration; 19616 19617 -------------------------- 19618 -- New_Concatenation_Op -- 19619 -------------------------- 19620 19621 procedure New_Concatenation_Op (Typ : Entity_Id) is 19622 Loc : constant Source_Ptr := Sloc (Typ); 19623 Op : Entity_Id; 19624 19625 function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id; 19626 -- Create abbreviated declaration for the formal of a predefined 19627 -- Operator 'Op' of type 'Typ' 19628 19629 -------------------- 19630 -- Make_Op_Formal -- 19631 -------------------- 19632 19633 function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is 19634 Formal : Entity_Id; 19635 begin 19636 Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P'); 19637 Set_Etype (Formal, Typ); 19638 Set_Mechanism (Formal, Default_Mechanism); 19639 return Formal; 19640 end Make_Op_Formal; 19641 19642 -- Start of processing for New_Concatenation_Op 19643 19644 begin 19645 Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); 19646 19647 Set_Ekind (Op, E_Operator); 19648 Set_Scope (Op, Current_Scope); 19649 Set_Etype (Op, Typ); 19650 Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); 19651 Set_Is_Immediately_Visible (Op); 19652 Set_Is_Intrinsic_Subprogram (Op); 19653 Set_Has_Completion (Op); 19654 Append_Entity (Op, Current_Scope); 19655 19656 Set_Name_Entity_Id (Name_Op_Concat, Op); 19657 19658 Append_Entity (Make_Op_Formal (Typ, Op), Op); 19659 Append_Entity (Make_Op_Formal (Typ, Op), Op); 19660 end New_Concatenation_Op; 19661 19662 ------------------------- 19663 -- OK_For_Limited_Init -- 19664 ------------------------- 19665 19666 -- ???Check all calls of this, and compare the conditions under which it's 19667 -- called. 19668 19669 function OK_For_Limited_Init 19670 (Typ : Entity_Id; 19671 Exp : Node_Id) return Boolean 19672 is 19673 begin 19674 return Is_CPP_Constructor_Call (Exp) 19675 or else (Ada_Version >= Ada_2005 19676 and then not Debug_Flag_Dot_L 19677 and then OK_For_Limited_Init_In_05 (Typ, Exp)); 19678 end OK_For_Limited_Init; 19679 19680 ------------------------------- 19681 -- OK_For_Limited_Init_In_05 -- 19682 ------------------------------- 19683 19684 function OK_For_Limited_Init_In_05 19685 (Typ : Entity_Id; 19686 Exp : Node_Id) return Boolean 19687 is 19688 begin 19689 -- An object of a limited interface type can be initialized with any 19690 -- expression of a nonlimited descendant type. However this does not 19691 -- apply if this is a view conversion of some other expression. This 19692 -- is checked below. 19693 19694 if Is_Class_Wide_Type (Typ) 19695 and then Is_Limited_Interface (Typ) 19696 and then not Is_Limited_Type (Etype (Exp)) 19697 and then Nkind (Exp) /= N_Type_Conversion 19698 then 19699 return True; 19700 end if; 19701 19702 -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in 19703 -- case of limited aggregates (including extension aggregates), and 19704 -- function calls. The function call may have been given in prefixed 19705 -- notation, in which case the original node is an indexed component. 19706 -- If the function is parameterless, the original node was an explicit 19707 -- dereference. The function may also be parameterless, in which case 19708 -- the source node is just an identifier. 19709 19710 -- A branch of a conditional expression may have been removed if the 19711 -- condition is statically known. This happens during expansion, and 19712 -- thus will not happen if previous errors were encountered. The check 19713 -- will have been performed on the chosen branch, which replaces the 19714 -- original conditional expression. 19715 19716 if No (Exp) then 19717 return True; 19718 end if; 19719 19720 case Nkind (Original_Node (Exp)) is 19721 when N_Aggregate 19722 | N_Extension_Aggregate 19723 | N_Function_Call 19724 | N_Op 19725 => 19726 return True; 19727 19728 when N_Identifier => 19729 return Present (Entity (Original_Node (Exp))) 19730 and then Ekind (Entity (Original_Node (Exp))) = E_Function; 19731 19732 when N_Qualified_Expression => 19733 return 19734 OK_For_Limited_Init_In_05 19735 (Typ, Expression (Original_Node (Exp))); 19736 19737 -- Ada 2005 (AI-251): If a class-wide interface object is initialized 19738 -- with a function call, the expander has rewritten the call into an 19739 -- N_Type_Conversion node to force displacement of the pointer to 19740 -- reference the component containing the secondary dispatch table. 19741 -- Otherwise a type conversion is not a legal context. 19742 -- A return statement for a build-in-place function returning a 19743 -- synchronized type also introduces an unchecked conversion. 19744 19745 when N_Type_Conversion 19746 | N_Unchecked_Type_Conversion 19747 => 19748 return not Comes_From_Source (Exp) 19749 and then 19750 -- If the conversion has been rewritten, check Original_Node 19751 19752 ((Original_Node (Exp) /= Exp 19753 and then 19754 OK_For_Limited_Init_In_05 (Typ, Original_Node (Exp))) 19755 19756 -- Otherwise, check the expression of the compiler-generated 19757 -- conversion (which is a conversion that we want to ignore 19758 -- for purposes of the limited-initialization restrictions). 19759 19760 or else 19761 (Original_Node (Exp) = Exp 19762 and then 19763 OK_For_Limited_Init_In_05 (Typ, Expression (Exp)))); 19764 19765 when N_Explicit_Dereference 19766 | N_Indexed_Component 19767 | N_Selected_Component 19768 => 19769 return Nkind (Exp) = N_Function_Call; 19770 19771 -- A use of 'Input is a function call, hence allowed. Normally the 19772 -- attribute will be changed to a call, but the attribute by itself 19773 -- can occur with -gnatc. 19774 19775 when N_Attribute_Reference => 19776 return Attribute_Name (Original_Node (Exp)) = Name_Input; 19777 19778 -- "return raise ..." is OK 19779 19780 when N_Raise_Expression => 19781 return True; 19782 19783 -- For a case expression, all dependent expressions must be legal 19784 19785 when N_Case_Expression => 19786 declare 19787 Alt : Node_Id; 19788 19789 begin 19790 Alt := First (Alternatives (Original_Node (Exp))); 19791 while Present (Alt) loop 19792 if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then 19793 return False; 19794 end if; 19795 19796 Next (Alt); 19797 end loop; 19798 19799 return True; 19800 end; 19801 19802 -- For an if expression, all dependent expressions must be legal 19803 19804 when N_If_Expression => 19805 declare 19806 Then_Expr : constant Node_Id := 19807 Next (First (Expressions (Original_Node (Exp)))); 19808 Else_Expr : constant Node_Id := Next (Then_Expr); 19809 begin 19810 return OK_For_Limited_Init_In_05 (Typ, Then_Expr) 19811 and then 19812 OK_For_Limited_Init_In_05 (Typ, Else_Expr); 19813 end; 19814 19815 when others => 19816 return False; 19817 end case; 19818 end OK_For_Limited_Init_In_05; 19819 19820 ------------------------------------------- 19821 -- Ordinary_Fixed_Point_Type_Declaration -- 19822 ------------------------------------------- 19823 19824 procedure Ordinary_Fixed_Point_Type_Declaration 19825 (T : Entity_Id; 19826 Def : Node_Id) 19827 is 19828 Loc : constant Source_Ptr := Sloc (Def); 19829 Delta_Expr : constant Node_Id := Delta_Expression (Def); 19830 RRS : constant Node_Id := Real_Range_Specification (Def); 19831 Implicit_Base : Entity_Id; 19832 Delta_Val : Ureal; 19833 Small_Val : Ureal; 19834 Low_Val : Ureal; 19835 High_Val : Ureal; 19836 19837 begin 19838 Check_Restriction (No_Fixed_Point, Def); 19839 19840 -- Create implicit base type 19841 19842 Implicit_Base := 19843 Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B'); 19844 Set_Etype (Implicit_Base, Implicit_Base); 19845 19846 -- Analyze and process delta expression 19847 19848 Analyze_And_Resolve (Delta_Expr, Any_Real); 19849 19850 Check_Delta_Expression (Delta_Expr); 19851 Delta_Val := Expr_Value_R (Delta_Expr); 19852 19853 Set_Delta_Value (Implicit_Base, Delta_Val); 19854 19855 -- Compute default small from given delta, which is the largest power 19856 -- of two that does not exceed the given delta value. 19857 19858 declare 19859 Tmp : Ureal; 19860 Scale : Int; 19861 19862 begin 19863 Tmp := Ureal_1; 19864 Scale := 0; 19865 19866 if Delta_Val < Ureal_1 then 19867 while Delta_Val < Tmp loop 19868 Tmp := Tmp / Ureal_2; 19869 Scale := Scale + 1; 19870 end loop; 19871 19872 else 19873 loop 19874 Tmp := Tmp * Ureal_2; 19875 exit when Tmp > Delta_Val; 19876 Scale := Scale - 1; 19877 end loop; 19878 end if; 19879 19880 Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2); 19881 end; 19882 19883 Set_Small_Value (Implicit_Base, Small_Val); 19884 19885 -- If no range was given, set a dummy range 19886 19887 if RRS <= Empty_Or_Error then 19888 Low_Val := -Small_Val; 19889 High_Val := Small_Val; 19890 19891 -- Otherwise analyze and process given range 19892 19893 else 19894 declare 19895 Low : constant Node_Id := Low_Bound (RRS); 19896 High : constant Node_Id := High_Bound (RRS); 19897 19898 begin 19899 Analyze_And_Resolve (Low, Any_Real); 19900 Analyze_And_Resolve (High, Any_Real); 19901 Check_Real_Bound (Low); 19902 Check_Real_Bound (High); 19903 19904 -- Obtain and set the range 19905 19906 Low_Val := Expr_Value_R (Low); 19907 High_Val := Expr_Value_R (High); 19908 19909 if Low_Val > High_Val then 19910 Error_Msg_NE ("??fixed point type& has null range", Def, T); 19911 end if; 19912 end; 19913 end if; 19914 19915 -- The range for both the implicit base and the declared first subtype 19916 -- cannot be set yet, so we use the special routine Set_Fixed_Range to 19917 -- set a temporary range in place. Note that the bounds of the base 19918 -- type will be widened to be symmetrical and to fill the available 19919 -- bits when the type is frozen. 19920 19921 -- We could do this with all discrete types, and probably should, but 19922 -- we absolutely have to do it for fixed-point, since the end-points 19923 -- of the range and the size are determined by the small value, which 19924 -- could be reset before the freeze point. 19925 19926 Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); 19927 Set_Fixed_Range (T, Loc, Low_Val, High_Val); 19928 19929 -- Complete definition of first subtype. The inheritance of the rep item 19930 -- chain ensures that SPARK-related pragmas are not clobbered when the 19931 -- ordinary fixed point type acts as a full view of a private type. 19932 19933 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); 19934 Set_Etype (T, Implicit_Base); 19935 Init_Size_Align (T); 19936 Inherit_Rep_Item_Chain (T, Implicit_Base); 19937 Set_Small_Value (T, Small_Val); 19938 Set_Delta_Value (T, Delta_Val); 19939 Set_Is_Constrained (T); 19940 end Ordinary_Fixed_Point_Type_Declaration; 19941 19942 ---------------------------------- 19943 -- Preanalyze_Assert_Expression -- 19944 ---------------------------------- 19945 19946 procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is 19947 begin 19948 In_Assertion_Expr := In_Assertion_Expr + 1; 19949 Preanalyze_Spec_Expression (N, T); 19950 In_Assertion_Expr := In_Assertion_Expr - 1; 19951 end Preanalyze_Assert_Expression; 19952 19953 ----------------------------------- 19954 -- Preanalyze_Default_Expression -- 19955 ----------------------------------- 19956 19957 procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is 19958 Save_In_Default_Expr : constant Boolean := In_Default_Expr; 19959 Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; 19960 19961 begin 19962 In_Default_Expr := True; 19963 In_Spec_Expression := True; 19964 19965 Preanalyze_With_Freezing_And_Resolve (N, T); 19966 19967 In_Default_Expr := Save_In_Default_Expr; 19968 In_Spec_Expression := Save_In_Spec_Expression; 19969 end Preanalyze_Default_Expression; 19970 19971 -------------------------------- 19972 -- Preanalyze_Spec_Expression -- 19973 -------------------------------- 19974 19975 procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is 19976 Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; 19977 begin 19978 In_Spec_Expression := True; 19979 Preanalyze_And_Resolve (N, T); 19980 In_Spec_Expression := Save_In_Spec_Expression; 19981 end Preanalyze_Spec_Expression; 19982 19983 ---------------------------------------- 19984 -- Prepare_Private_Subtype_Completion -- 19985 ---------------------------------------- 19986 19987 procedure Prepare_Private_Subtype_Completion 19988 (Id : Entity_Id; 19989 Related_Nod : Node_Id) 19990 is 19991 Id_B : constant Entity_Id := Base_Type (Id); 19992 Full_B : constant Entity_Id := Full_View (Id_B); 19993 Full : Entity_Id; 19994 19995 begin 19996 if Present (Full_B) then 19997 19998 -- The Base_Type is already completed, we can complete the subtype 19999 -- now. We have to create a new entity with the same name, Thus we 20000 -- can't use Create_Itype. 20001 20002 Full := Make_Defining_Identifier (Sloc (Id), Chars (Id)); 20003 Set_Is_Itype (Full); 20004 Set_Associated_Node_For_Itype (Full, Related_Nod); 20005 Complete_Private_Subtype (Id, Full, Full_B, Related_Nod); 20006 Set_Full_View (Id, Full); 20007 end if; 20008 20009 -- The parent subtype may be private, but the base might not, in some 20010 -- nested instances. In that case, the subtype does not need to be 20011 -- exchanged. It would still be nice to make private subtypes and their 20012 -- bases consistent at all times ??? 20013 20014 if Is_Private_Type (Id_B) then 20015 Append_Elmt (Id, Private_Dependents (Id_B)); 20016 end if; 20017 end Prepare_Private_Subtype_Completion; 20018 20019 --------------------------- 20020 -- Process_Discriminants -- 20021 --------------------------- 20022 20023 procedure Process_Discriminants 20024 (N : Node_Id; 20025 Prev : Entity_Id := Empty) 20026 is 20027 Elist : constant Elist_Id := New_Elmt_List; 20028 Id : Node_Id; 20029 Discr : Node_Id; 20030 Discr_Number : Uint; 20031 Discr_Type : Entity_Id; 20032 Default_Present : Boolean := False; 20033 Default_Not_Present : Boolean := False; 20034 20035 begin 20036 -- A composite type other than an array type can have discriminants. 20037 -- On entry, the current scope is the composite type. 20038 20039 -- The discriminants are initially entered into the scope of the type 20040 -- via Enter_Name with the default Ekind of E_Void to prevent premature 20041 -- use, as explained at the end of this procedure. 20042 20043 Discr := First (Discriminant_Specifications (N)); 20044 while Present (Discr) loop 20045 Enter_Name (Defining_Identifier (Discr)); 20046 20047 -- For navigation purposes we add a reference to the discriminant 20048 -- in the entity for the type. If the current declaration is a 20049 -- completion, place references on the partial view. Otherwise the 20050 -- type is the current scope. 20051 20052 if Present (Prev) then 20053 20054 -- The references go on the partial view, if present. If the 20055 -- partial view has discriminants, the references have been 20056 -- generated already. 20057 20058 if not Has_Discriminants (Prev) then 20059 Generate_Reference (Prev, Defining_Identifier (Discr), 'd'); 20060 end if; 20061 else 20062 Generate_Reference 20063 (Current_Scope, Defining_Identifier (Discr), 'd'); 20064 end if; 20065 20066 if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then 20067 Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr)); 20068 20069 -- Ada 2005 (AI-254) 20070 20071 if Present (Access_To_Subprogram_Definition 20072 (Discriminant_Type (Discr))) 20073 and then Protected_Present (Access_To_Subprogram_Definition 20074 (Discriminant_Type (Discr))) 20075 then 20076 Discr_Type := 20077 Replace_Anonymous_Access_To_Protected_Subprogram (Discr); 20078 end if; 20079 20080 else 20081 Find_Type (Discriminant_Type (Discr)); 20082 Discr_Type := Etype (Discriminant_Type (Discr)); 20083 20084 if Error_Posted (Discriminant_Type (Discr)) then 20085 Discr_Type := Any_Type; 20086 end if; 20087 end if; 20088 20089 -- Handling of discriminants that are access types 20090 20091 if Is_Access_Type (Discr_Type) then 20092 20093 -- Ada 2005 (AI-230): Access discriminant allowed in non- 20094 -- limited record types 20095 20096 if Ada_Version < Ada_2005 then 20097 Check_Access_Discriminant_Requires_Limited 20098 (Discr, Discriminant_Type (Discr)); 20099 end if; 20100 20101 if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then 20102 Error_Msg_N 20103 ("(Ada 83) access discriminant not allowed", Discr); 20104 end if; 20105 20106 -- If not access type, must be a discrete type 20107 20108 elsif not Is_Discrete_Type (Discr_Type) then 20109 Error_Msg_N 20110 ("discriminants must have a discrete or access type", 20111 Discriminant_Type (Discr)); 20112 end if; 20113 20114 Set_Etype (Defining_Identifier (Discr), Discr_Type); 20115 20116 -- If a discriminant specification includes the assignment compound 20117 -- delimiter followed by an expression, the expression is the default 20118 -- expression of the discriminant; the default expression must be of 20119 -- the type of the discriminant. (RM 3.7.1) Since this expression is 20120 -- a default expression, we do the special preanalysis, since this 20121 -- expression does not freeze (see section "Handling of Default and 20122 -- Per-Object Expressions" in spec of package Sem). 20123 20124 if Present (Expression (Discr)) then 20125 Preanalyze_Default_Expression (Expression (Discr), Discr_Type); 20126 20127 -- Legaity checks 20128 20129 if Nkind (N) = N_Formal_Type_Declaration then 20130 Error_Msg_N 20131 ("discriminant defaults not allowed for formal type", 20132 Expression (Discr)); 20133 20134 -- Flag an error for a tagged type with defaulted discriminants, 20135 -- excluding limited tagged types when compiling for Ada 2012 20136 -- (see AI05-0214). 20137 20138 elsif Is_Tagged_Type (Current_Scope) 20139 and then (not Is_Limited_Type (Current_Scope) 20140 or else Ada_Version < Ada_2012) 20141 and then Comes_From_Source (N) 20142 then 20143 -- Note: see similar test in Check_Or_Process_Discriminants, to 20144 -- handle the (illegal) case of the completion of an untagged 20145 -- view with discriminants with defaults by a tagged full view. 20146 -- We skip the check if Discr does not come from source, to 20147 -- account for the case of an untagged derived type providing 20148 -- defaults for a renamed discriminant from a private untagged 20149 -- ancestor with a tagged full view (ACATS B460006). 20150 20151 if Ada_Version >= Ada_2012 then 20152 Error_Msg_N 20153 ("discriminants of nonlimited tagged type cannot have" 20154 & " defaults", 20155 Expression (Discr)); 20156 else 20157 Error_Msg_N 20158 ("discriminants of tagged type cannot have defaults", 20159 Expression (Discr)); 20160 end if; 20161 20162 else 20163 Default_Present := True; 20164 Append_Elmt (Expression (Discr), Elist); 20165 20166 -- Tag the defining identifiers for the discriminants with 20167 -- their corresponding default expressions from the tree. 20168 20169 Set_Discriminant_Default_Value 20170 (Defining_Identifier (Discr), Expression (Discr)); 20171 end if; 20172 20173 -- In gnatc or GNATprove mode, make sure set Do_Range_Check flag 20174 -- gets set unless we can be sure that no range check is required. 20175 20176 if not Expander_Active 20177 and then not 20178 Is_In_Range 20179 (Expression (Discr), Discr_Type, Assume_Valid => True) 20180 then 20181 Set_Do_Range_Check (Expression (Discr)); 20182 end if; 20183 20184 -- No default discriminant value given 20185 20186 else 20187 Default_Not_Present := True; 20188 end if; 20189 20190 -- Ada 2005 (AI-231): Create an Itype that is a duplicate of 20191 -- Discr_Type but with the null-exclusion attribute 20192 20193 if Ada_Version >= Ada_2005 then 20194 20195 -- Ada 2005 (AI-231): Static checks 20196 20197 if Can_Never_Be_Null (Discr_Type) then 20198 Null_Exclusion_Static_Checks (Discr); 20199 20200 elsif Is_Access_Type (Discr_Type) 20201 and then Null_Exclusion_Present (Discr) 20202 20203 -- No need to check itypes because in their case this check 20204 -- was done at their point of creation 20205 20206 and then not Is_Itype (Discr_Type) 20207 then 20208 if Can_Never_Be_Null (Discr_Type) then 20209 Error_Msg_NE 20210 ("`NOT NULL` not allowed (& already excludes null)", 20211 Discr, 20212 Discr_Type); 20213 end if; 20214 20215 Set_Etype (Defining_Identifier (Discr), 20216 Create_Null_Excluding_Itype 20217 (T => Discr_Type, 20218 Related_Nod => Discr)); 20219 20220 -- Check for improper null exclusion if the type is otherwise 20221 -- legal for a discriminant. 20222 20223 elsif Null_Exclusion_Present (Discr) 20224 and then Is_Discrete_Type (Discr_Type) 20225 then 20226 Error_Msg_N 20227 ("null exclusion can only apply to an access type", Discr); 20228 end if; 20229 20230 -- Ada 2005 (AI-402): access discriminants of nonlimited types 20231 -- can't have defaults. Synchronized types, or types that are 20232 -- explicitly limited are fine, but special tests apply to derived 20233 -- types in generics: in a generic body we have to assume the 20234 -- worst, and therefore defaults are not allowed if the parent is 20235 -- a generic formal private type (see ACATS B370001). 20236 20237 if Is_Access_Type (Discr_Type) and then Default_Present then 20238 if Ekind (Discr_Type) /= E_Anonymous_Access_Type 20239 or else Is_Limited_Record (Current_Scope) 20240 or else Is_Concurrent_Type (Current_Scope) 20241 or else Is_Concurrent_Record_Type (Current_Scope) 20242 or else Ekind (Current_Scope) = E_Limited_Private_Type 20243 then 20244 if not Is_Derived_Type (Current_Scope) 20245 or else not Is_Generic_Type (Etype (Current_Scope)) 20246 or else not In_Package_Body (Scope (Etype (Current_Scope))) 20247 or else Limited_Present 20248 (Type_Definition (Parent (Current_Scope))) 20249 then 20250 null; 20251 20252 else 20253 Error_Msg_N 20254 ("access discriminants of nonlimited types cannot " 20255 & "have defaults", Expression (Discr)); 20256 end if; 20257 20258 elsif Present (Expression (Discr)) then 20259 Error_Msg_N 20260 ("(Ada 2005) access discriminants of nonlimited types " 20261 & "cannot have defaults", Expression (Discr)); 20262 end if; 20263 end if; 20264 end if; 20265 20266 -- A discriminant cannot be effectively volatile (SPARK RM 7.1.3(4)). 20267 -- This check is relevant only when SPARK_Mode is on as it is not a 20268 -- standard Ada legality rule. The only way for a discriminant to be 20269 -- effectively volatile is to have an effectively volatile type, so 20270 -- we check this directly, because the Ekind of Discr might not be 20271 -- set yet (to help preventing cascaded errors on derived types). 20272 20273 if SPARK_Mode = On 20274 and then Is_Effectively_Volatile (Discr_Type) 20275 then 20276 Error_Msg_N ("discriminant cannot be volatile", Discr); 20277 end if; 20278 20279 Next (Discr); 20280 end loop; 20281 20282 -- An element list consisting of the default expressions of the 20283 -- discriminants is constructed in the above loop and used to set 20284 -- the Discriminant_Constraint attribute for the type. If an object 20285 -- is declared of this (record or task) type without any explicit 20286 -- discriminant constraint given, this element list will form the 20287 -- actual parameters for the corresponding initialization procedure 20288 -- for the type. 20289 20290 Set_Discriminant_Constraint (Current_Scope, Elist); 20291 Set_Stored_Constraint (Current_Scope, No_Elist); 20292 20293 -- Default expressions must be provided either for all or for none 20294 -- of the discriminants of a discriminant part. (RM 3.7.1) 20295 20296 if Default_Present and then Default_Not_Present then 20297 Error_Msg_N 20298 ("incomplete specification of defaults for discriminants", N); 20299 end if; 20300 20301 -- The use of the name of a discriminant is not allowed in default 20302 -- expressions of a discriminant part if the specification of the 20303 -- discriminant is itself given in the discriminant part. (RM 3.7.1) 20304 20305 -- To detect this, the discriminant names are entered initially with an 20306 -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any 20307 -- attempt to use a void entity (for example in an expression that is 20308 -- type-checked) produces the error message: premature usage. Now after 20309 -- completing the semantic analysis of the discriminant part, we can set 20310 -- the Ekind of all the discriminants appropriately. 20311 20312 Discr := First (Discriminant_Specifications (N)); 20313 Discr_Number := Uint_1; 20314 while Present (Discr) loop 20315 Id := Defining_Identifier (Discr); 20316 Set_Ekind (Id, E_Discriminant); 20317 Init_Component_Location (Id); 20318 Init_Esize (Id); 20319 Set_Discriminant_Number (Id, Discr_Number); 20320 20321 -- Make sure this is always set, even in illegal programs 20322 20323 Set_Corresponding_Discriminant (Id, Empty); 20324 20325 -- Initialize the Original_Record_Component to the entity itself. 20326 -- Inherit_Components will propagate the right value to 20327 -- discriminants in derived record types. 20328 20329 Set_Original_Record_Component (Id, Id); 20330 20331 -- Create the discriminal for the discriminant 20332 20333 Build_Discriminal (Id); 20334 20335 Next (Discr); 20336 Discr_Number := Discr_Number + 1; 20337 end loop; 20338 20339 Set_Has_Discriminants (Current_Scope); 20340 end Process_Discriminants; 20341 20342 ----------------------- 20343 -- Process_Full_View -- 20344 ----------------------- 20345 20346 -- WARNING: This routine manages Ghost regions. Return statements must be 20347 -- replaced by gotos which jump to the end of the routine and restore the 20348 -- Ghost mode. 20349 20350 procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is 20351 procedure Collect_Implemented_Interfaces 20352 (Typ : Entity_Id; 20353 Ifaces : Elist_Id); 20354 -- Ada 2005: Gather all the interfaces that Typ directly or 20355 -- inherently implements. Duplicate entries are not added to 20356 -- the list Ifaces. 20357 20358 ------------------------------------ 20359 -- Collect_Implemented_Interfaces -- 20360 ------------------------------------ 20361 20362 procedure Collect_Implemented_Interfaces 20363 (Typ : Entity_Id; 20364 Ifaces : Elist_Id) 20365 is 20366 Iface : Entity_Id; 20367 Iface_Elmt : Elmt_Id; 20368 20369 begin 20370 -- Abstract interfaces are only associated with tagged record types 20371 20372 if not Is_Tagged_Type (Typ) or else not Is_Record_Type (Typ) then 20373 return; 20374 end if; 20375 20376 -- Recursively climb to the ancestors 20377 20378 if Etype (Typ) /= Typ 20379 20380 -- Protect the frontend against wrong cyclic declarations like: 20381 20382 -- type B is new A with private; 20383 -- type C is new A with private; 20384 -- private 20385 -- type B is new C with null record; 20386 -- type C is new B with null record; 20387 20388 and then Etype (Typ) /= Priv_T 20389 and then Etype (Typ) /= Full_T 20390 then 20391 -- Keep separate the management of private type declarations 20392 20393 if Ekind (Typ) = E_Record_Type_With_Private then 20394 20395 -- Handle the following illegal usage: 20396 -- type Private_Type is tagged private; 20397 -- private 20398 -- type Private_Type is new Type_Implementing_Iface; 20399 20400 if Present (Full_View (Typ)) 20401 and then Etype (Typ) /= Full_View (Typ) 20402 then 20403 if Is_Interface (Etype (Typ)) then 20404 Append_Unique_Elmt (Etype (Typ), Ifaces); 20405 end if; 20406 20407 Collect_Implemented_Interfaces (Etype (Typ), Ifaces); 20408 end if; 20409 20410 -- Non-private types 20411 20412 else 20413 if Is_Interface (Etype (Typ)) then 20414 Append_Unique_Elmt (Etype (Typ), Ifaces); 20415 end if; 20416 20417 Collect_Implemented_Interfaces (Etype (Typ), Ifaces); 20418 end if; 20419 end if; 20420 20421 -- Handle entities in the list of abstract interfaces 20422 20423 if Present (Interfaces (Typ)) then 20424 Iface_Elmt := First_Elmt (Interfaces (Typ)); 20425 while Present (Iface_Elmt) loop 20426 Iface := Node (Iface_Elmt); 20427 20428 pragma Assert (Is_Interface (Iface)); 20429 20430 if not Contain_Interface (Iface, Ifaces) then 20431 Append_Elmt (Iface, Ifaces); 20432 Collect_Implemented_Interfaces (Iface, Ifaces); 20433 end if; 20434 20435 Next_Elmt (Iface_Elmt); 20436 end loop; 20437 end if; 20438 end Collect_Implemented_Interfaces; 20439 20440 -- Local variables 20441 20442 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 20443 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 20444 -- Save the Ghost-related attributes to restore on exit 20445 20446 Full_Indic : Node_Id; 20447 Full_Parent : Entity_Id; 20448 Priv_Parent : Entity_Id; 20449 20450 -- Start of processing for Process_Full_View 20451 20452 begin 20453 Mark_And_Set_Ghost_Completion (N, Priv_T); 20454 20455 -- First some sanity checks that must be done after semantic 20456 -- decoration of the full view and thus cannot be placed with other 20457 -- similar checks in Find_Type_Name 20458 20459 if not Is_Limited_Type (Priv_T) 20460 and then (Is_Limited_Type (Full_T) 20461 or else Is_Limited_Composite (Full_T)) 20462 then 20463 if In_Instance then 20464 null; 20465 else 20466 Error_Msg_N 20467 ("completion of nonlimited type cannot be limited", Full_T); 20468 Explain_Limited_Type (Full_T, Full_T); 20469 end if; 20470 20471 elsif Is_Abstract_Type (Full_T) 20472 and then not Is_Abstract_Type (Priv_T) 20473 then 20474 Error_Msg_N 20475 ("completion of nonabstract type cannot be abstract", Full_T); 20476 20477 elsif Is_Tagged_Type (Priv_T) 20478 and then Is_Limited_Type (Priv_T) 20479 and then not Is_Limited_Type (Full_T) 20480 then 20481 -- If pragma CPP_Class was applied to the private declaration 20482 -- propagate the limitedness to the full-view 20483 20484 if Is_CPP_Class (Priv_T) then 20485 Set_Is_Limited_Record (Full_T); 20486 20487 -- GNAT allow its own definition of Limited_Controlled to disobey 20488 -- this rule in order in ease the implementation. This test is safe 20489 -- because Root_Controlled is defined in a child of System that 20490 -- normal programs are not supposed to use. 20491 20492 elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then 20493 Set_Is_Limited_Composite (Full_T); 20494 else 20495 Error_Msg_N 20496 ("completion of limited tagged type must be limited", Full_T); 20497 end if; 20498 20499 elsif Is_Generic_Type (Priv_T) then 20500 Error_Msg_N ("generic type cannot have a completion", Full_T); 20501 end if; 20502 20503 -- Check that ancestor interfaces of private and full views are 20504 -- consistent. We omit this check for synchronized types because 20505 -- they are performed on the corresponding record type when frozen. 20506 20507 if Ada_Version >= Ada_2005 20508 and then Is_Tagged_Type (Priv_T) 20509 and then Is_Tagged_Type (Full_T) 20510 and then not Is_Concurrent_Type (Full_T) 20511 then 20512 declare 20513 Iface : Entity_Id; 20514 Priv_T_Ifaces : constant Elist_Id := New_Elmt_List; 20515 Full_T_Ifaces : constant Elist_Id := New_Elmt_List; 20516 20517 begin 20518 Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces); 20519 Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces); 20520 20521 -- Ada 2005 (AI-251): The partial view shall be a descendant of 20522 -- an interface type if and only if the full type is descendant 20523 -- of the interface type (AARM 7.3 (7.3/2)). 20524 20525 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); 20526 20527 if Present (Iface) then 20528 Error_Msg_NE 20529 ("interface in partial view& not implemented by full type " 20530 & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); 20531 end if; 20532 20533 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); 20534 20535 if Present (Iface) then 20536 Error_Msg_NE 20537 ("interface & not implemented by partial view " 20538 & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); 20539 end if; 20540 end; 20541 end if; 20542 20543 if Is_Tagged_Type (Priv_T) 20544 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 20545 and then Is_Derived_Type (Full_T) 20546 then 20547 Priv_Parent := Etype (Priv_T); 20548 20549 -- The full view of a private extension may have been transformed 20550 -- into an unconstrained derived type declaration and a subtype 20551 -- declaration (see build_derived_record_type for details). 20552 20553 if Nkind (N) = N_Subtype_Declaration then 20554 Full_Indic := Subtype_Indication (N); 20555 Full_Parent := Etype (Base_Type (Full_T)); 20556 else 20557 Full_Indic := Subtype_Indication (Type_Definition (N)); 20558 Full_Parent := Etype (Full_T); 20559 end if; 20560 20561 -- Check that the parent type of the full type is a descendant of 20562 -- the ancestor subtype given in the private extension. If either 20563 -- entity has an Etype equal to Any_Type then we had some previous 20564 -- error situation [7.3(8)]. 20565 20566 if Priv_Parent = Any_Type or else Full_Parent = Any_Type then 20567 goto Leave; 20568 20569 -- Ada 2005 (AI-251): Interfaces in the full type can be given in 20570 -- any order. Therefore we don't have to check that its parent must 20571 -- be a descendant of the parent of the private type declaration. 20572 20573 elsif Is_Interface (Priv_Parent) 20574 and then Is_Interface (Full_Parent) 20575 then 20576 null; 20577 20578 -- Ada 2005 (AI-251): If the parent of the private type declaration 20579 -- is an interface there is no need to check that it is an ancestor 20580 -- of the associated full type declaration. The required tests for 20581 -- this case are performed by Build_Derived_Record_Type. 20582 20583 elsif not Is_Interface (Base_Type (Priv_Parent)) 20584 and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) 20585 then 20586 Error_Msg_N 20587 ("parent of full type must descend from parent of private " 20588 & "extension", Full_Indic); 20589 20590 -- First check a formal restriction, and then proceed with checking 20591 -- Ada rules. Since the formal restriction is not a serious error, we 20592 -- don't prevent further error detection for this check, hence the 20593 -- ELSE. 20594 20595 else 20596 -- Check the rules of 7.3(10): if the private extension inherits 20597 -- known discriminants, then the full type must also inherit those 20598 -- discriminants from the same (ancestor) type, and the parent 20599 -- subtype of the full type must be constrained if and only if 20600 -- the ancestor subtype of the private extension is constrained. 20601 20602 if No (Discriminant_Specifications (Parent (Priv_T))) 20603 and then not Has_Unknown_Discriminants (Priv_T) 20604 and then Has_Discriminants (Base_Type (Priv_Parent)) 20605 then 20606 declare 20607 Priv_Indic : constant Node_Id := 20608 Subtype_Indication (Parent (Priv_T)); 20609 20610 Priv_Constr : constant Boolean := 20611 Is_Constrained (Priv_Parent) 20612 or else 20613 Nkind (Priv_Indic) = N_Subtype_Indication 20614 or else 20615 Is_Constrained (Entity (Priv_Indic)); 20616 20617 Full_Constr : constant Boolean := 20618 Is_Constrained (Full_Parent) 20619 or else 20620 Nkind (Full_Indic) = N_Subtype_Indication 20621 or else 20622 Is_Constrained (Entity (Full_Indic)); 20623 20624 Priv_Discr : Entity_Id; 20625 Full_Discr : Entity_Id; 20626 20627 begin 20628 Priv_Discr := First_Discriminant (Priv_Parent); 20629 Full_Discr := First_Discriminant (Full_Parent); 20630 while Present (Priv_Discr) and then Present (Full_Discr) loop 20631 if Original_Record_Component (Priv_Discr) = 20632 Original_Record_Component (Full_Discr) 20633 or else 20634 Corresponding_Discriminant (Priv_Discr) = 20635 Corresponding_Discriminant (Full_Discr) 20636 then 20637 null; 20638 else 20639 exit; 20640 end if; 20641 20642 Next_Discriminant (Priv_Discr); 20643 Next_Discriminant (Full_Discr); 20644 end loop; 20645 20646 if Present (Priv_Discr) or else Present (Full_Discr) then 20647 Error_Msg_N 20648 ("full view must inherit discriminants of the parent " 20649 & "type used in the private extension", Full_Indic); 20650 20651 elsif Priv_Constr and then not Full_Constr then 20652 Error_Msg_N 20653 ("parent subtype of full type must be constrained", 20654 Full_Indic); 20655 20656 elsif Full_Constr and then not Priv_Constr then 20657 Error_Msg_N 20658 ("parent subtype of full type must be unconstrained", 20659 Full_Indic); 20660 end if; 20661 end; 20662 20663 -- Check the rules of 7.3(12): if a partial view has neither 20664 -- known or unknown discriminants, then the full type 20665 -- declaration shall define a definite subtype. 20666 20667 elsif not Has_Unknown_Discriminants (Priv_T) 20668 and then not Has_Discriminants (Priv_T) 20669 and then not Is_Constrained (Full_T) 20670 then 20671 Error_Msg_N 20672 ("full view must define a constrained type if partial view " 20673 & "has no discriminants", Full_T); 20674 end if; 20675 20676 -- ??????? Do we implement the following properly ????? 20677 -- If the ancestor subtype of a private extension has constrained 20678 -- discriminants, then the parent subtype of the full view shall 20679 -- impose a statically matching constraint on those discriminants 20680 -- [7.3(13)]. 20681 end if; 20682 20683 else 20684 -- For untagged types, verify that a type without discriminants is 20685 -- not completed with an unconstrained type. A separate error message 20686 -- is produced if the full type has defaulted discriminants. 20687 20688 if Is_Definite_Subtype (Priv_T) 20689 and then not Is_Definite_Subtype (Full_T) 20690 then 20691 Error_Msg_Sloc := Sloc (Parent (Priv_T)); 20692 Error_Msg_NE 20693 ("full view of& not compatible with declaration#", 20694 Full_T, Priv_T); 20695 20696 if not Is_Tagged_Type (Full_T) then 20697 Error_Msg_N 20698 ("\one is constrained, the other unconstrained", Full_T); 20699 end if; 20700 end if; 20701 end if; 20702 20703 -- AI-419: verify that the use of "limited" is consistent 20704 20705 declare 20706 Orig_Decl : constant Node_Id := Original_Node (N); 20707 20708 begin 20709 if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 20710 and then Nkind (Orig_Decl) = N_Full_Type_Declaration 20711 and then Nkind 20712 (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition 20713 then 20714 if not Limited_Present (Parent (Priv_T)) 20715 and then not Synchronized_Present (Parent (Priv_T)) 20716 and then Limited_Present (Type_Definition (Orig_Decl)) 20717 then 20718 Error_Msg_N 20719 ("full view of non-limited extension cannot be limited", N); 20720 20721 -- Conversely, if the partial view carries the limited keyword, 20722 -- the full view must as well, even if it may be redundant. 20723 20724 elsif Limited_Present (Parent (Priv_T)) 20725 and then not Limited_Present (Type_Definition (Orig_Decl)) 20726 then 20727 Error_Msg_N 20728 ("full view of limited extension must be explicitly limited", 20729 N); 20730 end if; 20731 end if; 20732 end; 20733 20734 -- Ada 2005 (AI-443): A synchronized private extension must be 20735 -- completed by a task or protected type. 20736 20737 if Ada_Version >= Ada_2005 20738 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 20739 and then Synchronized_Present (Parent (Priv_T)) 20740 and then not Is_Concurrent_Type (Full_T) 20741 then 20742 Error_Msg_N ("full view of synchronized extension must " & 20743 "be synchronized type", N); 20744 end if; 20745 20746 -- Ada 2005 AI-363: if the full view has discriminants with 20747 -- defaults, it is illegal to declare constrained access subtypes 20748 -- whose designated type is the current type. This allows objects 20749 -- of the type that are declared in the heap to be unconstrained. 20750 20751 if not Has_Unknown_Discriminants (Priv_T) 20752 and then not Has_Discriminants (Priv_T) 20753 and then Has_Discriminants (Full_T) 20754 and then 20755 Present (Discriminant_Default_Value (First_Discriminant (Full_T))) 20756 then 20757 Set_Has_Constrained_Partial_View (Full_T); 20758 Set_Has_Constrained_Partial_View (Priv_T); 20759 end if; 20760 20761 -- Create a full declaration for all its subtypes recorded in 20762 -- Private_Dependents and swap them similarly to the base type. These 20763 -- are subtypes that have been define before the full declaration of 20764 -- the private type. We also swap the entry in Private_Dependents list 20765 -- so we can properly restore the private view on exit from the scope. 20766 20767 declare 20768 Priv_Elmt : Elmt_Id; 20769 Priv_Scop : Entity_Id; 20770 Priv : Entity_Id; 20771 Full : Entity_Id; 20772 20773 begin 20774 Priv_Elmt := First_Elmt (Private_Dependents (Priv_T)); 20775 while Present (Priv_Elmt) loop 20776 Priv := Node (Priv_Elmt); 20777 Priv_Scop := Scope (Priv); 20778 20779 if Ekind (Priv) in E_Private_Subtype 20780 | E_Limited_Private_Subtype 20781 | E_Record_Subtype_With_Private 20782 then 20783 Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); 20784 Set_Is_Itype (Full); 20785 Set_Parent (Full, Parent (Priv)); 20786 Set_Associated_Node_For_Itype (Full, N); 20787 20788 -- Now we need to complete the private subtype, but since the 20789 -- base type has already been swapped, we must also swap the 20790 -- subtypes (and thus, reverse the arguments in the call to 20791 -- Complete_Private_Subtype). Also note that we may need to 20792 -- re-establish the scope of the private subtype. 20793 20794 Copy_And_Swap (Priv, Full); 20795 20796 if not In_Open_Scopes (Priv_Scop) then 20797 Push_Scope (Priv_Scop); 20798 20799 else 20800 -- Reset Priv_Scop to Empty to indicate no scope was pushed 20801 20802 Priv_Scop := Empty; 20803 end if; 20804 20805 Complete_Private_Subtype (Full, Priv, Full_T, N); 20806 Set_Full_View (Full, Priv); 20807 20808 if Present (Priv_Scop) then 20809 Pop_Scope; 20810 end if; 20811 20812 Replace_Elmt (Priv_Elmt, Full); 20813 end if; 20814 20815 Next_Elmt (Priv_Elmt); 20816 end loop; 20817 end; 20818 20819 -- If the private view was tagged, copy the new primitive operations 20820 -- from the private view to the full view. 20821 20822 if Is_Tagged_Type (Full_T) then 20823 declare 20824 Disp_Typ : Entity_Id; 20825 Full_List : Elist_Id; 20826 Prim : Entity_Id; 20827 Prim_Elmt : Elmt_Id; 20828 Priv_List : Elist_Id; 20829 20830 function Contains 20831 (E : Entity_Id; 20832 L : Elist_Id) return Boolean; 20833 -- Determine whether list L contains element E 20834 20835 -------------- 20836 -- Contains -- 20837 -------------- 20838 20839 function Contains 20840 (E : Entity_Id; 20841 L : Elist_Id) return Boolean 20842 is 20843 List_Elmt : Elmt_Id; 20844 20845 begin 20846 List_Elmt := First_Elmt (L); 20847 while Present (List_Elmt) loop 20848 if Node (List_Elmt) = E then 20849 return True; 20850 end if; 20851 20852 Next_Elmt (List_Elmt); 20853 end loop; 20854 20855 return False; 20856 end Contains; 20857 20858 -- Start of processing 20859 20860 begin 20861 if Is_Tagged_Type (Priv_T) then 20862 Priv_List := Primitive_Operations (Priv_T); 20863 Prim_Elmt := First_Elmt (Priv_List); 20864 20865 -- In the case of a concurrent type completing a private tagged 20866 -- type, primitives may have been declared in between the two 20867 -- views. These subprograms need to be wrapped the same way 20868 -- entries and protected procedures are handled because they 20869 -- cannot be directly shared by the two views. 20870 20871 if Is_Concurrent_Type (Full_T) then 20872 declare 20873 Conc_Typ : constant Entity_Id := 20874 Corresponding_Record_Type (Full_T); 20875 Curr_Nod : Node_Id := Parent (Conc_Typ); 20876 Wrap_Spec : Node_Id; 20877 20878 begin 20879 while Present (Prim_Elmt) loop 20880 Prim := Node (Prim_Elmt); 20881 20882 if Comes_From_Source (Prim) 20883 and then not Is_Abstract_Subprogram (Prim) 20884 then 20885 Wrap_Spec := 20886 Make_Subprogram_Declaration (Sloc (Prim), 20887 Specification => 20888 Build_Wrapper_Spec 20889 (Subp_Id => Prim, 20890 Obj_Typ => Conc_Typ, 20891 Formals => 20892 Parameter_Specifications 20893 (Parent (Prim)))); 20894 20895 Insert_After (Curr_Nod, Wrap_Spec); 20896 Curr_Nod := Wrap_Spec; 20897 20898 Analyze (Wrap_Spec); 20899 20900 -- Remove the wrapper from visibility to avoid 20901 -- spurious conflict with the wrapped entity. 20902 20903 Set_Is_Immediately_Visible 20904 (Defining_Entity (Specification (Wrap_Spec)), 20905 False); 20906 end if; 20907 20908 Next_Elmt (Prim_Elmt); 20909 end loop; 20910 20911 goto Leave; 20912 end; 20913 20914 -- For non-concurrent types, transfer explicit primitives, but 20915 -- omit those inherited from the parent of the private view 20916 -- since they will be re-inherited later on. 20917 20918 else 20919 Full_List := Primitive_Operations (Full_T); 20920 while Present (Prim_Elmt) loop 20921 Prim := Node (Prim_Elmt); 20922 20923 if Comes_From_Source (Prim) 20924 and then not Contains (Prim, Full_List) 20925 then 20926 Append_Elmt (Prim, Full_List); 20927 end if; 20928 20929 Next_Elmt (Prim_Elmt); 20930 end loop; 20931 end if; 20932 20933 -- Untagged private view 20934 20935 else 20936 Full_List := Primitive_Operations (Full_T); 20937 20938 -- In this case the partial view is untagged, so here we locate 20939 -- all of the earlier primitives that need to be treated as 20940 -- dispatching (those that appear between the two views). Note 20941 -- that these additional operations must all be new operations 20942 -- (any earlier operations that override inherited operations 20943 -- of the full view will already have been inserted in the 20944 -- primitives list, marked by Check_Operation_From_Private_View 20945 -- as dispatching. Note that implicit "/=" operators are 20946 -- excluded from being added to the primitives list since they 20947 -- shouldn't be treated as dispatching (tagged "/=" is handled 20948 -- specially). 20949 20950 Prim := Next_Entity (Full_T); 20951 while Present (Prim) and then Prim /= Priv_T loop 20952 if Ekind (Prim) in E_Procedure | E_Function then 20953 Disp_Typ := Find_Dispatching_Type (Prim); 20954 20955 if Disp_Typ = Full_T 20956 and then (Chars (Prim) /= Name_Op_Ne 20957 or else Comes_From_Source (Prim)) 20958 then 20959 Check_Controlling_Formals (Full_T, Prim); 20960 20961 if Is_Suitable_Primitive (Prim) 20962 and then not Is_Dispatching_Operation (Prim) 20963 then 20964 Append_Elmt (Prim, Full_List); 20965 Set_Is_Dispatching_Operation (Prim); 20966 Set_DT_Position_Value (Prim, No_Uint); 20967 end if; 20968 20969 elsif Is_Dispatching_Operation (Prim) 20970 and then Disp_Typ /= Full_T 20971 then 20972 -- Verify that it is not otherwise controlled by a 20973 -- formal or a return value of type T. 20974 20975 Check_Controlling_Formals (Disp_Typ, Prim); 20976 end if; 20977 end if; 20978 20979 Next_Entity (Prim); 20980 end loop; 20981 end if; 20982 20983 -- For the tagged case, the two views can share the same primitive 20984 -- operations list and the same class-wide type. Update attributes 20985 -- of the class-wide type which depend on the full declaration. 20986 20987 if Is_Tagged_Type (Priv_T) then 20988 Set_Direct_Primitive_Operations (Priv_T, Full_List); 20989 Set_Class_Wide_Type 20990 (Base_Type (Full_T), Class_Wide_Type (Priv_T)); 20991 20992 Propagate_Concurrent_Flags (Class_Wide_Type (Priv_T), Full_T); 20993 end if; 20994 end; 20995 end if; 20996 20997 -- Ada 2005 AI 161: Check preelaborable initialization consistency 20998 20999 if Known_To_Have_Preelab_Init (Priv_T) then 21000 21001 -- Case where there is a pragma Preelaborable_Initialization. We 21002 -- always allow this in predefined units, which is cheating a bit, 21003 -- but it means we don't have to struggle to meet the requirements in 21004 -- the RM for having Preelaborable Initialization. Otherwise we 21005 -- require that the type meets the RM rules. But we can't check that 21006 -- yet, because of the rule about overriding Initialize, so we simply 21007 -- set a flag that will be checked at freeze time. 21008 21009 if not In_Predefined_Unit (Full_T) then 21010 Set_Must_Have_Preelab_Init (Full_T); 21011 end if; 21012 end if; 21013 21014 -- If pragma CPP_Class was applied to the private type declaration, 21015 -- propagate it now to the full type declaration. 21016 21017 if Is_CPP_Class (Priv_T) then 21018 Set_Is_CPP_Class (Full_T); 21019 Set_Convention (Full_T, Convention_CPP); 21020 21021 -- Check that components of imported CPP types do not have default 21022 -- expressions. 21023 21024 Check_CPP_Type_Has_No_Defaults (Full_T); 21025 end if; 21026 21027 -- If the private view has user specified stream attributes, then so has 21028 -- the full view. 21029 21030 -- Why the test, how could these flags be already set in Full_T ??? 21031 21032 if Has_Specified_Stream_Read (Priv_T) then 21033 Set_Has_Specified_Stream_Read (Full_T); 21034 end if; 21035 21036 if Has_Specified_Stream_Write (Priv_T) then 21037 Set_Has_Specified_Stream_Write (Full_T); 21038 end if; 21039 21040 if Has_Specified_Stream_Input (Priv_T) then 21041 Set_Has_Specified_Stream_Input (Full_T); 21042 end if; 21043 21044 if Has_Specified_Stream_Output (Priv_T) then 21045 Set_Has_Specified_Stream_Output (Full_T); 21046 end if; 21047 21048 -- Propagate Default_Initial_Condition-related attributes from the 21049 -- partial view to the full view. 21050 21051 Propagate_DIC_Attributes (Full_T, From_Typ => Priv_T); 21052 21053 -- And to the underlying full view, if any 21054 21055 if Is_Private_Type (Full_T) 21056 and then Present (Underlying_Full_View (Full_T)) 21057 then 21058 Propagate_DIC_Attributes 21059 (Underlying_Full_View (Full_T), From_Typ => Priv_T); 21060 end if; 21061 21062 -- Propagate invariant-related attributes from the partial view to the 21063 -- full view. 21064 21065 Propagate_Invariant_Attributes (Full_T, From_Typ => Priv_T); 21066 21067 -- And to the underlying full view, if any 21068 21069 if Is_Private_Type (Full_T) 21070 and then Present (Underlying_Full_View (Full_T)) 21071 then 21072 Propagate_Invariant_Attributes 21073 (Underlying_Full_View (Full_T), From_Typ => Priv_T); 21074 end if; 21075 21076 -- AI12-0041: Detect an attempt to inherit a class-wide type invariant 21077 -- in the full view without advertising the inheritance in the partial 21078 -- view. This can only occur when the partial view has no parent type 21079 -- and the full view has an interface as a parent. Any other scenarios 21080 -- are illegal because implemented interfaces must match between the 21081 -- two views. 21082 21083 if Is_Tagged_Type (Priv_T) and then Is_Tagged_Type (Full_T) then 21084 declare 21085 Full_Par : constant Entity_Id := Etype (Full_T); 21086 Priv_Par : constant Entity_Id := Etype (Priv_T); 21087 21088 begin 21089 if not Is_Interface (Priv_Par) 21090 and then Is_Interface (Full_Par) 21091 and then Has_Inheritable_Invariants (Full_Par) 21092 then 21093 Error_Msg_N 21094 ("hidden inheritance of class-wide type invariants not " 21095 & "allowed", N); 21096 end if; 21097 end; 21098 end if; 21099 21100 -- Propagate predicates to full type, and predicate function if already 21101 -- defined. It is not clear that this can actually happen? the partial 21102 -- view cannot be frozen yet, and the predicate function has not been 21103 -- built. Still it is a cheap check and seems safer to make it. 21104 21105 Propagate_Predicate_Attributes (Full_T, Priv_T); 21106 21107 if Is_Private_Type (Full_T) 21108 and then Present (Underlying_Full_View (Full_T)) 21109 then 21110 Propagate_Predicate_Attributes 21111 (Underlying_Full_View (Full_T), Priv_T); 21112 end if; 21113 21114 <<Leave>> 21115 Restore_Ghost_Region (Saved_GM, Saved_IGR); 21116 end Process_Full_View; 21117 21118 ----------------------------------- 21119 -- Process_Incomplete_Dependents -- 21120 ----------------------------------- 21121 21122 procedure Process_Incomplete_Dependents 21123 (N : Node_Id; 21124 Full_T : Entity_Id; 21125 Inc_T : Entity_Id) 21126 is 21127 Inc_Elmt : Elmt_Id; 21128 Priv_Dep : Entity_Id; 21129 New_Subt : Entity_Id; 21130 21131 Disc_Constraint : Elist_Id; 21132 21133 begin 21134 if No (Private_Dependents (Inc_T)) then 21135 return; 21136 end if; 21137 21138 -- Itypes that may be generated by the completion of an incomplete 21139 -- subtype are not used by the back-end and not attached to the tree. 21140 -- They are created only for constraint-checking purposes. 21141 21142 Inc_Elmt := First_Elmt (Private_Dependents (Inc_T)); 21143 while Present (Inc_Elmt) loop 21144 Priv_Dep := Node (Inc_Elmt); 21145 21146 if Ekind (Priv_Dep) = E_Subprogram_Type then 21147 21148 -- An Access_To_Subprogram type may have a return type or a 21149 -- parameter type that is incomplete. Replace with the full view. 21150 21151 if Etype (Priv_Dep) = Inc_T then 21152 Set_Etype (Priv_Dep, Full_T); 21153 end if; 21154 21155 declare 21156 Formal : Entity_Id; 21157 21158 begin 21159 Formal := First_Formal (Priv_Dep); 21160 while Present (Formal) loop 21161 if Etype (Formal) = Inc_T then 21162 Set_Etype (Formal, Full_T); 21163 end if; 21164 21165 Next_Formal (Formal); 21166 end loop; 21167 end; 21168 21169 elsif Is_Overloadable (Priv_Dep) then 21170 21171 -- If a subprogram in the incomplete dependents list is primitive 21172 -- for a tagged full type then mark it as a dispatching operation, 21173 -- check whether it overrides an inherited subprogram, and check 21174 -- restrictions on its controlling formals. Note that a protected 21175 -- operation is never dispatching: only its wrapper operation 21176 -- (which has convention Ada) is. 21177 21178 if Is_Tagged_Type (Full_T) 21179 and then Is_Primitive (Priv_Dep) 21180 and then Convention (Priv_Dep) /= Convention_Protected 21181 then 21182 Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T); 21183 Set_Is_Dispatching_Operation (Priv_Dep); 21184 Check_Controlling_Formals (Full_T, Priv_Dep); 21185 end if; 21186 21187 elsif Ekind (Priv_Dep) = E_Subprogram_Body then 21188 21189 -- Can happen during processing of a body before the completion 21190 -- of a TA type. Ignore, because spec is also on dependent list. 21191 21192 return; 21193 21194 -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a 21195 -- corresponding subtype of the full view. 21196 21197 elsif Ekind (Priv_Dep) = E_Incomplete_Subtype 21198 and then Comes_From_Source (Priv_Dep) 21199 then 21200 Set_Subtype_Indication 21201 (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep))); 21202 Set_Etype (Priv_Dep, Full_T); 21203 Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); 21204 Set_Analyzed (Parent (Priv_Dep), False); 21205 21206 -- Reanalyze the declaration, suppressing the call to Enter_Name 21207 -- to avoid duplicate names. 21208 21209 Analyze_Subtype_Declaration 21210 (N => Parent (Priv_Dep), 21211 Skip => True); 21212 21213 -- Dependent is a subtype 21214 21215 else 21216 -- We build a new subtype indication using the full view of the 21217 -- incomplete parent. The discriminant constraints have been 21218 -- elaborated already at the point of the subtype declaration. 21219 21220 New_Subt := Create_Itype (E_Void, N); 21221 21222 if Has_Discriminants (Full_T) then 21223 Disc_Constraint := Discriminant_Constraint (Priv_Dep); 21224 else 21225 Disc_Constraint := No_Elist; 21226 end if; 21227 21228 Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N); 21229 Set_Full_View (Priv_Dep, New_Subt); 21230 end if; 21231 21232 Next_Elmt (Inc_Elmt); 21233 end loop; 21234 end Process_Incomplete_Dependents; 21235 21236 -------------------------------- 21237 -- Process_Range_Expr_In_Decl -- 21238 -------------------------------- 21239 21240 procedure Process_Range_Expr_In_Decl 21241 (R : Node_Id; 21242 T : Entity_Id; 21243 Subtyp : Entity_Id := Empty; 21244 Check_List : List_Id := No_List; 21245 R_Check_Off : Boolean := False) 21246 is 21247 Lo, Hi : Node_Id; 21248 R_Checks : Check_Result; 21249 Insert_Node : Node_Id; 21250 Def_Id : Entity_Id; 21251 21252 begin 21253 Analyze_And_Resolve (R, Base_Type (T)); 21254 21255 if Nkind (R) = N_Range then 21256 Lo := Low_Bound (R); 21257 Hi := High_Bound (R); 21258 21259 -- Validity checks on the range of a quantified expression are 21260 -- delayed until the construct is transformed into a loop. 21261 21262 if Nkind (Parent (R)) = N_Loop_Parameter_Specification 21263 and then Nkind (Parent (Parent (R))) = N_Quantified_Expression 21264 then 21265 null; 21266 21267 -- We need to ensure validity of the bounds here, because if we 21268 -- go ahead and do the expansion, then the expanded code will get 21269 -- analyzed with range checks suppressed and we miss the check. 21270 21271 -- WARNING: The capture of the range bounds with xxx_FIRST/_LAST and 21272 -- the temporaries generated by routine Remove_Side_Effects by means 21273 -- of validity checks must use the same names. When a range appears 21274 -- in the parent of a generic, the range is processed with checks 21275 -- disabled as part of the generic context and with checks enabled 21276 -- for code generation purposes. This leads to link issues as the 21277 -- generic contains references to xxx_FIRST/_LAST, but the inlined 21278 -- template sees the temporaries generated by Remove_Side_Effects. 21279 21280 else 21281 Validity_Check_Range (R, Subtyp); 21282 end if; 21283 21284 -- If there were errors in the declaration, try and patch up some 21285 -- common mistakes in the bounds. The cases handled are literals 21286 -- which are Integer where the expected type is Real and vice versa. 21287 -- These corrections allow the compilation process to proceed further 21288 -- along since some basic assumptions of the format of the bounds 21289 -- are guaranteed. 21290 21291 if Etype (R) = Any_Type then 21292 if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then 21293 Rewrite (Lo, 21294 Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo)))); 21295 21296 elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then 21297 Rewrite (Hi, 21298 Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi)))); 21299 21300 elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then 21301 Rewrite (Lo, 21302 Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo)))); 21303 21304 elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then 21305 Rewrite (Hi, 21306 Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi)))); 21307 end if; 21308 21309 Set_Etype (Lo, T); 21310 Set_Etype (Hi, T); 21311 end if; 21312 21313 -- If the bounds of the range have been mistakenly given as string 21314 -- literals (perhaps in place of character literals), then an error 21315 -- has already been reported, but we rewrite the string literal as a 21316 -- bound of the range's type to avoid blowups in later processing 21317 -- that looks at static values. 21318 21319 if Nkind (Lo) = N_String_Literal then 21320 Rewrite (Lo, 21321 Make_Attribute_Reference (Sloc (Lo), 21322 Prefix => New_Occurrence_Of (T, Sloc (Lo)), 21323 Attribute_Name => Name_First)); 21324 Analyze_And_Resolve (Lo); 21325 end if; 21326 21327 if Nkind (Hi) = N_String_Literal then 21328 Rewrite (Hi, 21329 Make_Attribute_Reference (Sloc (Hi), 21330 Prefix => New_Occurrence_Of (T, Sloc (Hi)), 21331 Attribute_Name => Name_First)); 21332 Analyze_And_Resolve (Hi); 21333 end if; 21334 21335 -- If bounds aren't scalar at this point then exit, avoiding 21336 -- problems with further processing of the range in this procedure. 21337 21338 if not Is_Scalar_Type (Etype (Lo)) then 21339 return; 21340 end if; 21341 21342 -- Resolve (actually Sem_Eval) has checked that the bounds are in 21343 -- then range of the base type. Here we check whether the bounds 21344 -- are in the range of the subtype itself. Note that if the bounds 21345 -- represent the null range the Constraint_Error exception should 21346 -- not be raised. 21347 21348 -- ??? The following code should be cleaned up as follows 21349 21350 -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it 21351 -- is done in the call to Range_Check (R, T); below 21352 21353 -- 2. The use of R_Check_Off should be investigated and possibly 21354 -- removed, this would clean up things a bit. 21355 21356 if Is_Null_Range (Lo, Hi) then 21357 null; 21358 21359 else 21360 -- Capture values of bounds and generate temporaries for them 21361 -- if needed, before applying checks, since checks may cause 21362 -- duplication of the expression without forcing evaluation. 21363 21364 -- The forced evaluation removes side effects from expressions, 21365 -- which should occur also in GNATprove mode. Otherwise, we end up 21366 -- with unexpected insertions of actions at places where this is 21367 -- not supposed to occur, e.g. on default parameters of a call. 21368 21369 if Expander_Active or GNATprove_Mode then 21370 21371 -- Call Force_Evaluation to create declarations as needed to 21372 -- deal with side effects, and also create typ_FIRST/LAST 21373 -- entities for bounds if we have a subtype name. 21374 21375 -- Note: we do this transformation even if expansion is not 21376 -- active if we are in GNATprove_Mode since the transformation 21377 -- is in general required to ensure that the resulting tree has 21378 -- proper Ada semantics. 21379 21380 Force_Evaluation 21381 (Lo, Related_Id => Subtyp, Is_Low_Bound => True); 21382 Force_Evaluation 21383 (Hi, Related_Id => Subtyp, Is_High_Bound => True); 21384 end if; 21385 21386 -- We use a flag here instead of suppressing checks on the type 21387 -- because the type we check against isn't necessarily the place 21388 -- where we put the check. 21389 21390 if not R_Check_Off then 21391 R_Checks := Get_Range_Checks (R, T); 21392 21393 -- Look up tree to find an appropriate insertion point. We 21394 -- can't just use insert_actions because later processing 21395 -- depends on the insertion node. Prior to Ada 2012 the 21396 -- insertion point could only be a declaration or a loop, but 21397 -- quantified expressions can appear within any context in an 21398 -- expression, and the insertion point can be any statement, 21399 -- pragma, or declaration. 21400 21401 Insert_Node := Parent (R); 21402 while Present (Insert_Node) loop 21403 exit when 21404 Nkind (Insert_Node) in N_Declaration 21405 and then 21406 Nkind (Insert_Node) not in N_Component_Declaration 21407 | N_Loop_Parameter_Specification 21408 | N_Function_Specification 21409 | N_Procedure_Specification; 21410 21411 exit when Nkind (Insert_Node) in 21412 N_Later_Decl_Item | 21413 N_Statement_Other_Than_Procedure_Call | 21414 N_Procedure_Call_Statement | 21415 N_Pragma; 21416 21417 Insert_Node := Parent (Insert_Node); 21418 end loop; 21419 21420 -- Why would Type_Decl not be present??? Without this test, 21421 -- short regression tests fail. 21422 21423 if Present (Insert_Node) then 21424 21425 -- Case of loop statement. Verify that the range is part 21426 -- of the subtype indication of the iteration scheme. 21427 21428 if Nkind (Insert_Node) = N_Loop_Statement then 21429 declare 21430 Indic : Node_Id; 21431 21432 begin 21433 Indic := Parent (R); 21434 while Present (Indic) 21435 and then Nkind (Indic) /= N_Subtype_Indication 21436 loop 21437 Indic := Parent (Indic); 21438 end loop; 21439 21440 if Present (Indic) then 21441 Def_Id := Etype (Subtype_Mark (Indic)); 21442 21443 Insert_Range_Checks 21444 (R_Checks, 21445 Insert_Node, 21446 Def_Id, 21447 Sloc (Insert_Node), 21448 Do_Before => True); 21449 end if; 21450 end; 21451 21452 -- Case of declarations. If the declaration is for a type 21453 -- and involves discriminants, the checks are premature at 21454 -- the declaration point and need to wait for the expansion 21455 -- of the initialization procedure, which will pass in the 21456 -- list to put them on; otherwise, the checks are done at 21457 -- the declaration point and there is no need to do them 21458 -- again in the initialization procedure. 21459 21460 elsif Nkind (Insert_Node) in N_Declaration then 21461 Def_Id := Defining_Identifier (Insert_Node); 21462 21463 if (Ekind (Def_Id) = E_Record_Type 21464 and then Depends_On_Discriminant (R)) 21465 or else 21466 (Ekind (Def_Id) = E_Protected_Type 21467 and then Has_Discriminants (Def_Id)) 21468 then 21469 if Present (Check_List) then 21470 Append_Range_Checks 21471 (R_Checks, 21472 Check_List, Def_Id, Sloc (Insert_Node)); 21473 end if; 21474 21475 else 21476 if No (Check_List) then 21477 Insert_Range_Checks 21478 (R_Checks, 21479 Insert_Node, Def_Id, Sloc (Insert_Node)); 21480 end if; 21481 end if; 21482 21483 -- Case of statements. Drop the checks, as the range appears 21484 -- in the context of a quantified expression. Insertion will 21485 -- take place when expression is expanded. 21486 21487 else 21488 null; 21489 end if; 21490 end if; 21491 end if; 21492 end if; 21493 21494 -- Case of other than an explicit N_Range node 21495 21496 -- The forced evaluation removes side effects from expressions, which 21497 -- should occur also in GNATprove mode. Otherwise, we end up with 21498 -- unexpected insertions of actions at places where this is not 21499 -- supposed to occur, e.g. on default parameters of a call. 21500 21501 elsif Expander_Active or GNATprove_Mode then 21502 Get_Index_Bounds (R, Lo, Hi); 21503 Force_Evaluation (Lo); 21504 Force_Evaluation (Hi); 21505 end if; 21506 end Process_Range_Expr_In_Decl; 21507 21508 -------------------------------------- 21509 -- Process_Real_Range_Specification -- 21510 -------------------------------------- 21511 21512 procedure Process_Real_Range_Specification (Def : Node_Id) is 21513 Spec : constant Node_Id := Real_Range_Specification (Def); 21514 Lo : Node_Id; 21515 Hi : Node_Id; 21516 Err : Boolean := False; 21517 21518 procedure Analyze_Bound (N : Node_Id); 21519 -- Analyze and check one bound 21520 21521 ------------------- 21522 -- Analyze_Bound -- 21523 ------------------- 21524 21525 procedure Analyze_Bound (N : Node_Id) is 21526 begin 21527 Analyze_And_Resolve (N, Any_Real); 21528 21529 if not Is_OK_Static_Expression (N) then 21530 Flag_Non_Static_Expr 21531 ("bound in real type definition is not static!", N); 21532 Err := True; 21533 end if; 21534 end Analyze_Bound; 21535 21536 -- Start of processing for Process_Real_Range_Specification 21537 21538 begin 21539 if Present (Spec) then 21540 Lo := Low_Bound (Spec); 21541 Hi := High_Bound (Spec); 21542 Analyze_Bound (Lo); 21543 Analyze_Bound (Hi); 21544 21545 -- If error, clear away junk range specification 21546 21547 if Err then 21548 Set_Real_Range_Specification (Def, Empty); 21549 end if; 21550 end if; 21551 end Process_Real_Range_Specification; 21552 21553 --------------------- 21554 -- Process_Subtype -- 21555 --------------------- 21556 21557 function Process_Subtype 21558 (S : Node_Id; 21559 Related_Nod : Node_Id; 21560 Related_Id : Entity_Id := Empty; 21561 Suffix : Character := ' ') return Entity_Id 21562 is 21563 procedure Check_Incomplete (T : Node_Id); 21564 -- Called to verify that an incomplete type is not used prematurely 21565 21566 ---------------------- 21567 -- Check_Incomplete -- 21568 ---------------------- 21569 21570 procedure Check_Incomplete (T : Node_Id) is 21571 begin 21572 -- Ada 2005 (AI-412): Incomplete subtypes are legal 21573 21574 if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type 21575 and then 21576 not (Ada_Version >= Ada_2005 21577 and then 21578 (Nkind (Parent (T)) = N_Subtype_Declaration 21579 or else (Nkind (Parent (T)) = N_Subtype_Indication 21580 and then Nkind (Parent (Parent (T))) = 21581 N_Subtype_Declaration))) 21582 then 21583 Error_Msg_N ("invalid use of type before its full declaration", T); 21584 end if; 21585 end Check_Incomplete; 21586 21587 -- Local variables 21588 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 -- Start of processing for Process_Subtype 21598 21599 begin 21600 -- Case of no constraints present 21601 21602 if Nkind (S) /= N_Subtype_Indication then 21603 Find_Type (S); 21604 21605 -- No way to proceed if the subtype indication is malformed. This 21606 -- will happen for example when the subtype indication in an object 21607 -- declaration is missing altogether and the expression is analyzed 21608 -- as if it were that indication. 21609 21610 if not Is_Entity_Name (S) then 21611 return Any_Type; 21612 end if; 21613 21614 Check_Incomplete (S); 21615 P := Parent (S); 21616 21617 -- The following mirroring of assertion in Null_Exclusion_Present is 21618 -- ugly, can't we have a range, a static predicate or even a flag??? 21619 21620 May_Have_Null_Exclusion := 21621 Present (P) 21622 and then 21623 Nkind (P) in N_Access_Definition 21624 | N_Access_Function_Definition 21625 | N_Access_Procedure_Definition 21626 | N_Access_To_Object_Definition 21627 | N_Allocator 21628 | N_Component_Definition 21629 | N_Derived_Type_Definition 21630 | N_Discriminant_Specification 21631 | N_Formal_Object_Declaration 21632 | N_Function_Specification 21633 | N_Object_Declaration 21634 | N_Object_Renaming_Declaration 21635 | N_Parameter_Specification 21636 | N_Subtype_Declaration; 21637 21638 -- Ada 2005 (AI-231): Static check 21639 21640 if Ada_Version >= Ada_2005 21641 and then May_Have_Null_Exclusion 21642 and then Null_Exclusion_Present (P) 21643 and then Nkind (P) /= N_Access_To_Object_Definition 21644 and then not Is_Access_Type (Entity (S)) 21645 then 21646 Error_Msg_N ("`NOT NULL` only allowed for an access type", S); 21647 end if; 21648 21649 -- Create an Itype that is a duplicate of Entity (S) but with the 21650 -- null-exclusion attribute. 21651 21652 if May_Have_Null_Exclusion 21653 and then Is_Access_Type (Entity (S)) 21654 and then Null_Exclusion_Present (P) 21655 21656 -- No need to check the case of an access to object definition. 21657 -- It is correct to define double not-null pointers. 21658 21659 -- Example: 21660 -- type Not_Null_Int_Ptr is not null access Integer; 21661 -- type Acc is not null access Not_Null_Int_Ptr; 21662 21663 and then Nkind (P) /= N_Access_To_Object_Definition 21664 then 21665 if Can_Never_Be_Null (Entity (S)) then 21666 case Nkind (Related_Nod) is 21667 when N_Full_Type_Declaration => 21668 if Nkind (Type_Definition (Related_Nod)) 21669 in N_Array_Type_Definition 21670 then 21671 Error_Node := 21672 Subtype_Indication 21673 (Component_Definition 21674 (Type_Definition (Related_Nod))); 21675 else 21676 Error_Node := 21677 Subtype_Indication (Type_Definition (Related_Nod)); 21678 end if; 21679 21680 when N_Subtype_Declaration => 21681 Error_Node := Subtype_Indication (Related_Nod); 21682 21683 when N_Object_Declaration => 21684 Error_Node := Object_Definition (Related_Nod); 21685 21686 when N_Component_Declaration => 21687 Error_Node := 21688 Subtype_Indication (Component_Definition (Related_Nod)); 21689 21690 when N_Allocator => 21691 Error_Node := Expression (Related_Nod); 21692 21693 when others => 21694 pragma Assert (False); 21695 Error_Node := Related_Nod; 21696 end case; 21697 21698 Error_Msg_NE 21699 ("`NOT NULL` not allowed (& already excludes null)", 21700 Error_Node, 21701 Entity (S)); 21702 end if; 21703 21704 Set_Etype (S, 21705 Create_Null_Excluding_Itype 21706 (T => Entity (S), 21707 Related_Nod => P)); 21708 Set_Entity (S, Etype (S)); 21709 end if; 21710 21711 return Entity (S); 21712 21713 -- Case of constraint present, so that we have an N_Subtype_Indication 21714 -- node (this node is created only if constraints are present). 21715 21716 else 21717 Find_Type (Subtype_Mark (S)); 21718 21719 if Nkind (Parent (S)) /= N_Access_To_Object_Definition 21720 and then not 21721 (Nkind (Parent (S)) = N_Subtype_Declaration 21722 and then Is_Itype (Defining_Identifier (Parent (S)))) 21723 then 21724 Check_Incomplete (Subtype_Mark (S)); 21725 end if; 21726 21727 P := Parent (S); 21728 Subtype_Mark_Id := Entity (Subtype_Mark (S)); 21729 21730 -- Explicit subtype declaration case 21731 21732 if Nkind (P) = N_Subtype_Declaration then 21733 Def_Id := Defining_Identifier (P); 21734 21735 -- Explicit derived type definition case 21736 21737 elsif Nkind (P) = N_Derived_Type_Definition then 21738 Def_Id := Defining_Identifier (Parent (P)); 21739 21740 -- Implicit case, the Def_Id must be created as an implicit type. 21741 -- The one exception arises in the case of concurrent types, array 21742 -- and access types, where other subsidiary implicit types may be 21743 -- created and must appear before the main implicit type. In these 21744 -- cases we leave Def_Id set to Empty as a signal that Create_Itype 21745 -- has not yet been called to create Def_Id. 21746 21747 else 21748 if Is_Array_Type (Subtype_Mark_Id) 21749 or else Is_Concurrent_Type (Subtype_Mark_Id) 21750 or else Is_Access_Type (Subtype_Mark_Id) 21751 then 21752 Def_Id := Empty; 21753 21754 -- For the other cases, we create a new unattached Itype, 21755 -- and set the indication to ensure it gets attached later. 21756 21757 else 21758 Def_Id := 21759 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 21760 end if; 21761 end if; 21762 21763 -- If the kind of constraint is invalid for this kind of type, 21764 -- then give an error, and then pretend no constraint was given. 21765 21766 if not Is_Valid_Constraint_Kind 21767 (Ekind (Subtype_Mark_Id), Nkind (Constraint (S))) 21768 then 21769 Error_Msg_N 21770 ("incorrect constraint for this kind of type", Constraint (S)); 21771 21772 Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); 21773 21774 -- Set Ekind of orphan itype, to prevent cascaded errors 21775 21776 if Present (Def_Id) then 21777 Set_Ekind (Def_Id, Ekind (Any_Type)); 21778 end if; 21779 21780 -- Make recursive call, having got rid of the bogus constraint 21781 21782 return Process_Subtype (S, Related_Nod, Related_Id, Suffix); 21783 end if; 21784 21785 -- Remaining processing depends on type. Select on Base_Type kind to 21786 -- ensure getting to the concrete type kind in the case of a private 21787 -- subtype (needed when only doing semantic analysis). 21788 21789 case Ekind (Base_Type (Subtype_Mark_Id)) is 21790 when Access_Kind => 21791 21792 -- If this is a constraint on a class-wide type, discard it. 21793 -- There is currently no way to express a partial discriminant 21794 -- constraint on a type with unknown discriminants. This is 21795 -- a pathology that the ACATS wisely decides not to test. 21796 21797 if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then 21798 if Comes_From_Source (S) then 21799 Error_Msg_N 21800 ("constraint on class-wide type ignored??", 21801 Constraint (S)); 21802 end if; 21803 21804 if Nkind (P) = N_Subtype_Declaration then 21805 Set_Subtype_Indication (P, 21806 New_Occurrence_Of (Subtype_Mark_Id, Sloc (S))); 21807 end if; 21808 21809 return Subtype_Mark_Id; 21810 end if; 21811 21812 Constrain_Access (Def_Id, S, Related_Nod); 21813 21814 if Expander_Active 21815 and then Is_Itype (Designated_Type (Def_Id)) 21816 and then Nkind (Related_Nod) = N_Subtype_Declaration 21817 and then not Is_Incomplete_Type (Designated_Type (Def_Id)) 21818 then 21819 Build_Itype_Reference 21820 (Designated_Type (Def_Id), Related_Nod); 21821 end if; 21822 21823 when Array_Kind => 21824 Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); 21825 21826 when Decimal_Fixed_Point_Kind => 21827 Constrain_Decimal (Def_Id, S); 21828 21829 when Enumeration_Kind => 21830 Constrain_Enumeration (Def_Id, S); 21831 21832 when Ordinary_Fixed_Point_Kind => 21833 Constrain_Ordinary_Fixed (Def_Id, S); 21834 21835 when Float_Kind => 21836 Constrain_Float (Def_Id, S); 21837 21838 when Integer_Kind => 21839 Constrain_Integer (Def_Id, S); 21840 21841 when Class_Wide_Kind 21842 | E_Incomplete_Type 21843 | E_Record_Subtype 21844 | E_Record_Type 21845 => 21846 Constrain_Discriminated_Type (Def_Id, S, Related_Nod); 21847 21848 if Ekind (Def_Id) = E_Incomplete_Type then 21849 Set_Private_Dependents (Def_Id, New_Elmt_List); 21850 end if; 21851 21852 when Private_Kind => 21853 21854 -- A private type with unknown discriminants may be completed 21855 -- by an unconstrained array type. 21856 21857 if Has_Unknown_Discriminants (Subtype_Mark_Id) 21858 and then Present (Full_View (Subtype_Mark_Id)) 21859 and then Is_Array_Type (Full_View (Subtype_Mark_Id)) 21860 then 21861 Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); 21862 21863 -- ... but more commonly is completed by a discriminated record 21864 -- type. 21865 21866 else 21867 Constrain_Discriminated_Type (Def_Id, S, Related_Nod); 21868 end if; 21869 21870 -- The base type may be private but Def_Id may be a full view 21871 -- in an instance. 21872 21873 if Is_Private_Type (Def_Id) then 21874 Set_Private_Dependents (Def_Id, New_Elmt_List); 21875 end if; 21876 21877 -- In case of an invalid constraint prevent further processing 21878 -- since the type constructed is missing expected fields. 21879 21880 if Etype (Def_Id) = Any_Type then 21881 return Def_Id; 21882 end if; 21883 21884 -- If the full view is that of a task with discriminants, 21885 -- we must constrain both the concurrent type and its 21886 -- corresponding record type. Otherwise we will just propagate 21887 -- the constraint to the full view, if available. 21888 21889 if Present (Full_View (Subtype_Mark_Id)) 21890 and then Has_Discriminants (Subtype_Mark_Id) 21891 and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id)) 21892 then 21893 Full_View_Id := 21894 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 21895 21896 Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id)); 21897 Constrain_Concurrent (Full_View_Id, S, 21898 Related_Nod, Related_Id, Suffix); 21899 Set_Entity (Subtype_Mark (S), Subtype_Mark_Id); 21900 Set_Full_View (Def_Id, Full_View_Id); 21901 21902 -- Introduce an explicit reference to the private subtype, 21903 -- to prevent scope anomalies in gigi if first use appears 21904 -- in a nested context, e.g. a later function body. 21905 -- Should this be generated in other contexts than a full 21906 -- type declaration? 21907 21908 if Is_Itype (Def_Id) 21909 and then 21910 Nkind (Parent (P)) = N_Full_Type_Declaration 21911 then 21912 Build_Itype_Reference (Def_Id, Parent (P)); 21913 end if; 21914 21915 else 21916 Prepare_Private_Subtype_Completion (Def_Id, Related_Nod); 21917 end if; 21918 21919 when Concurrent_Kind => 21920 Constrain_Concurrent (Def_Id, S, 21921 Related_Nod, Related_Id, Suffix); 21922 21923 when others => 21924 Error_Msg_N ("invalid subtype mark in subtype indication", S); 21925 end case; 21926 21927 -- Size, Alignment, Representation aspects and Convention are always 21928 -- inherited from the base type. 21929 21930 Set_Size_Info (Def_Id, (Subtype_Mark_Id)); 21931 Set_Rep_Info (Def_Id, (Subtype_Mark_Id)); 21932 Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); 21933 21934 -- The anonymous subtype created for the subtype indication 21935 -- inherits the predicates of the parent. 21936 21937 if Has_Predicates (Subtype_Mark_Id) then 21938 Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); 21939 21940 -- Indicate where the predicate function may be found 21941 21942 if No (Predicate_Function (Def_Id)) and then Is_Itype (Def_Id) then 21943 Set_Predicated_Parent (Def_Id, Subtype_Mark_Id); 21944 end if; 21945 end if; 21946 21947 return Def_Id; 21948 end if; 21949 end Process_Subtype; 21950 21951 ----------------------------- 21952 -- Record_Type_Declaration -- 21953 ----------------------------- 21954 21955 procedure Record_Type_Declaration 21956 (T : Entity_Id; 21957 N : Node_Id; 21958 Prev : Entity_Id) 21959 is 21960 Def : constant Node_Id := Type_Definition (N); 21961 Is_Tagged : Boolean; 21962 Tag_Comp : Entity_Id; 21963 21964 begin 21965 -- These flags must be initialized before calling Process_Discriminants 21966 -- because this routine makes use of them. 21967 21968 Set_Ekind (T, E_Record_Type); 21969 Set_Etype (T, T); 21970 Init_Size_Align (T); 21971 Set_Interfaces (T, No_Elist); 21972 Set_Stored_Constraint (T, No_Elist); 21973 Set_Default_SSO (T); 21974 Set_No_Reordering (T, No_Component_Reordering); 21975 21976 -- Normal case 21977 21978 if Ada_Version < Ada_2005 or else not Interface_Present (Def) then 21979 -- The flag Is_Tagged_Type might have already been set by 21980 -- Find_Type_Name if it detected an error for declaration T. This 21981 -- arises in the case of private tagged types where the full view 21982 -- omits the word tagged. 21983 21984 Is_Tagged := 21985 Tagged_Present (Def) 21986 or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T)); 21987 21988 Set_Is_Limited_Record (T, Limited_Present (Def)); 21989 21990 if Is_Tagged then 21991 Set_Is_Tagged_Type (T, True); 21992 Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); 21993 end if; 21994 21995 -- Type is abstract if full declaration carries keyword, or if 21996 -- previous partial view did. 21997 21998 Set_Is_Abstract_Type (T, Is_Abstract_Type (T) 21999 or else Abstract_Present (Def)); 22000 22001 else 22002 Is_Tagged := True; 22003 Analyze_Interface_Declaration (T, Def); 22004 22005 if Present (Discriminant_Specifications (N)) then 22006 Error_Msg_N 22007 ("interface types cannot have discriminants", 22008 Defining_Identifier 22009 (First (Discriminant_Specifications (N)))); 22010 end if; 22011 end if; 22012 22013 -- First pass: if there are self-referential access components, 22014 -- create the required anonymous access type declarations, and if 22015 -- need be an incomplete type declaration for T itself. 22016 22017 Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def)); 22018 22019 if Ada_Version >= Ada_2005 22020 and then Present (Interface_List (Def)) 22021 then 22022 Check_Interfaces (N, Def); 22023 22024 declare 22025 Ifaces_List : Elist_Id; 22026 22027 begin 22028 -- Ada 2005 (AI-251): Collect the list of progenitors that are not 22029 -- already in the parents. 22030 22031 Collect_Interfaces 22032 (T => T, 22033 Ifaces_List => Ifaces_List, 22034 Exclude_Parents => True); 22035 22036 Set_Interfaces (T, Ifaces_List); 22037 end; 22038 end if; 22039 22040 -- Records constitute a scope for the component declarations within. 22041 -- The scope is created prior to the processing of these declarations. 22042 -- Discriminants are processed first, so that they are visible when 22043 -- processing the other components. The Ekind of the record type itself 22044 -- is set to E_Record_Type (subtypes appear as E_Record_Subtype). 22045 22046 -- Enter record scope 22047 22048 Push_Scope (T); 22049 22050 -- If an incomplete or private type declaration was already given for 22051 -- the type, then this scope already exists, and the discriminants have 22052 -- been declared within. We must verify that the full declaration 22053 -- matches the incomplete one. 22054 22055 Check_Or_Process_Discriminants (N, T, Prev); 22056 22057 Set_Is_Constrained (T, not Has_Discriminants (T)); 22058 Set_Has_Delayed_Freeze (T, True); 22059 22060 -- For tagged types add a manually analyzed component corresponding 22061 -- to the component _tag, the corresponding piece of tree will be 22062 -- expanded as part of the freezing actions if it is not a CPP_Class. 22063 22064 if Is_Tagged then 22065 22066 -- Do not add the tag unless we are in expansion mode 22067 22068 if Expander_Active then 22069 Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag); 22070 Enter_Name (Tag_Comp); 22071 22072 Set_Ekind (Tag_Comp, E_Component); 22073 Set_Is_Tag (Tag_Comp); 22074 Set_Is_Aliased (Tag_Comp); 22075 Set_Is_Independent (Tag_Comp); 22076 Set_Etype (Tag_Comp, RTE (RE_Tag)); 22077 Set_DT_Entry_Count (Tag_Comp, No_Uint); 22078 Set_Original_Record_Component (Tag_Comp, Tag_Comp); 22079 Init_Component_Location (Tag_Comp); 22080 22081 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the 22082 -- implemented interfaces. 22083 22084 if Has_Interfaces (T) then 22085 Add_Interface_Tag_Components (N, T); 22086 end if; 22087 end if; 22088 22089 Make_Class_Wide_Type (T); 22090 Set_Direct_Primitive_Operations (T, New_Elmt_List); 22091 end if; 22092 22093 -- We must suppress range checks when processing record components in 22094 -- the presence of discriminants, since we don't want spurious checks to 22095 -- be generated during their analysis, but Suppress_Range_Checks flags 22096 -- must be reset the after processing the record definition. 22097 22098 -- Note: this is the only use of Kill_Range_Checks, and is a bit odd, 22099 -- couldn't we just use the normal range check suppression method here. 22100 -- That would seem cleaner ??? 22101 22102 if Has_Discriminants (T) and then not Range_Checks_Suppressed (T) then 22103 Set_Kill_Range_Checks (T, True); 22104 Record_Type_Definition (Def, Prev); 22105 Set_Kill_Range_Checks (T, False); 22106 else 22107 Record_Type_Definition (Def, Prev); 22108 end if; 22109 22110 -- Exit from record scope 22111 22112 End_Scope; 22113 22114 -- Ada 2005 (AI-251 and AI-345): Derive the interface subprograms of all 22115 -- the implemented interfaces and associate them an aliased entity. 22116 22117 if Is_Tagged 22118 and then not Is_Empty_List (Interface_List (Def)) 22119 then 22120 Derive_Progenitor_Subprograms (T, T); 22121 end if; 22122 22123 Check_Function_Writable_Actuals (N); 22124 end Record_Type_Declaration; 22125 22126 ---------------------------- 22127 -- Record_Type_Definition -- 22128 ---------------------------- 22129 22130 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is 22131 Component : Entity_Id; 22132 Ctrl_Components : Boolean := False; 22133 Final_Storage_Only : Boolean; 22134 T : Entity_Id; 22135 22136 begin 22137 if Ekind (Prev_T) = E_Incomplete_Type then 22138 T := Full_View (Prev_T); 22139 else 22140 T := Prev_T; 22141 end if; 22142 22143 Final_Storage_Only := not Is_Controlled (T); 22144 22145 -- Ada 2005: Check whether an explicit Limited is present in a derived 22146 -- type declaration. 22147 22148 if Nkind (Parent (Def)) = N_Derived_Type_Definition 22149 and then Limited_Present (Parent (Def)) 22150 then 22151 Set_Is_Limited_Record (T); 22152 end if; 22153 22154 -- If the component list of a record type is defined by the reserved 22155 -- word null and there is no discriminant part, then the record type has 22156 -- no components and all records of the type are null records (RM 3.7) 22157 -- This procedure is also called to process the extension part of a 22158 -- record extension, in which case the current scope may have inherited 22159 -- components. 22160 22161 if Present (Def) 22162 and then Present (Component_List (Def)) 22163 and then not Null_Present (Component_List (Def)) 22164 then 22165 Analyze_Declarations (Component_Items (Component_List (Def))); 22166 22167 if Present (Variant_Part (Component_List (Def))) then 22168 Analyze (Variant_Part (Component_List (Def))); 22169 end if; 22170 end if; 22171 22172 -- After completing the semantic analysis of the record definition, 22173 -- record components, both new and inherited, are accessible. Set their 22174 -- kind accordingly. Exclude malformed itypes from illegal declarations, 22175 -- whose Ekind may be void. 22176 22177 Component := First_Entity (Current_Scope); 22178 while Present (Component) loop 22179 if Ekind (Component) = E_Void 22180 and then not Is_Itype (Component) 22181 then 22182 Set_Ekind (Component, E_Component); 22183 Init_Component_Location (Component); 22184 end if; 22185 22186 Propagate_Concurrent_Flags (T, Etype (Component)); 22187 22188 if Ekind (Component) /= E_Component then 22189 null; 22190 22191 -- Do not set Has_Controlled_Component on a class-wide equivalent 22192 -- type. See Make_CW_Equivalent_Type. 22193 22194 elsif not Is_Class_Wide_Equivalent_Type (T) 22195 and then (Has_Controlled_Component (Etype (Component)) 22196 or else (Chars (Component) /= Name_uParent 22197 and then Is_Controlled (Etype (Component)))) 22198 then 22199 Set_Has_Controlled_Component (T, True); 22200 Final_Storage_Only := 22201 Final_Storage_Only 22202 and then Finalize_Storage_Only (Etype (Component)); 22203 Ctrl_Components := True; 22204 end if; 22205 22206 Next_Entity (Component); 22207 end loop; 22208 22209 -- A Type is Finalize_Storage_Only only if all its controlled components 22210 -- are also. 22211 22212 if Ctrl_Components then 22213 Set_Finalize_Storage_Only (T, Final_Storage_Only); 22214 end if; 22215 22216 -- Place reference to end record on the proper entity, which may 22217 -- be a partial view. 22218 22219 if Present (Def) then 22220 Process_End_Label (Def, 'e', Prev_T); 22221 end if; 22222 end Record_Type_Definition; 22223 22224 --------------------------- 22225 -- Replace_Discriminants -- 22226 --------------------------- 22227 22228 procedure Replace_Discriminants (Typ : Entity_Id; Decl : Node_Id) is 22229 function Process (N : Node_Id) return Traverse_Result; 22230 22231 ------------- 22232 -- Process -- 22233 ------------- 22234 22235 function Process (N : Node_Id) return Traverse_Result is 22236 Comp : Entity_Id; 22237 22238 begin 22239 if Nkind (N) = N_Discriminant_Specification then 22240 Comp := First_Discriminant (Typ); 22241 while Present (Comp) loop 22242 if Original_Record_Component (Comp) = Defining_Identifier (N) 22243 or else Chars (Comp) = Chars (Defining_Identifier (N)) 22244 then 22245 Set_Defining_Identifier (N, Comp); 22246 exit; 22247 end if; 22248 22249 Next_Discriminant (Comp); 22250 end loop; 22251 22252 elsif Nkind (N) = N_Variant_Part then 22253 Comp := First_Discriminant (Typ); 22254 while Present (Comp) loop 22255 if Original_Record_Component (Comp) = Entity (Name (N)) 22256 or else Chars (Comp) = Chars (Name (N)) 22257 then 22258 -- Make sure to preserve the type coming from the parent on 22259 -- the Name, even if the subtype of the discriminant can be 22260 -- constrained, so that discrete choices inherited from the 22261 -- parent in the variant part are not flagged as violating 22262 -- the constraints of the subtype. 22263 22264 declare 22265 Typ : constant Entity_Id := Etype (Name (N)); 22266 begin 22267 Rewrite (Name (N), New_Occurrence_Of (Comp, Sloc (N))); 22268 Set_Etype (Name (N), Typ); 22269 end; 22270 exit; 22271 end if; 22272 22273 Next_Discriminant (Comp); 22274 end loop; 22275 end if; 22276 22277 return OK; 22278 end Process; 22279 22280 procedure Replace is new Traverse_Proc (Process); 22281 22282 -- Start of processing for Replace_Discriminants 22283 22284 begin 22285 Replace (Decl); 22286 end Replace_Discriminants; 22287 22288 ------------------------------- 22289 -- Set_Completion_Referenced -- 22290 ------------------------------- 22291 22292 procedure Set_Completion_Referenced (E : Entity_Id) is 22293 begin 22294 -- If in main unit, mark entity that is a completion as referenced, 22295 -- warnings go on the partial view when needed. 22296 22297 if In_Extended_Main_Source_Unit (E) then 22298 Set_Referenced (E); 22299 end if; 22300 end Set_Completion_Referenced; 22301 22302 --------------------- 22303 -- Set_Default_SSO -- 22304 --------------------- 22305 22306 procedure Set_Default_SSO (T : Entity_Id) is 22307 begin 22308 case Opt.Default_SSO is 22309 when ' ' => 22310 null; 22311 when 'L' => 22312 Set_SSO_Set_Low_By_Default (T, True); 22313 when 'H' => 22314 Set_SSO_Set_High_By_Default (T, True); 22315 when others => 22316 raise Program_Error; 22317 end case; 22318 end Set_Default_SSO; 22319 22320 --------------------- 22321 -- Set_Fixed_Range -- 22322 --------------------- 22323 22324 -- The range for fixed-point types is complicated by the fact that we 22325 -- do not know the exact end points at the time of the declaration. This 22326 -- is true for three reasons: 22327 22328 -- A size clause may affect the fudging of the end-points. 22329 -- A small clause may affect the values of the end-points. 22330 -- We try to include the end-points if it does not affect the size. 22331 22332 -- This means that the actual end-points must be established at the 22333 -- point when the type is frozen. Meanwhile, we first narrow the range 22334 -- as permitted (so that it will fit if necessary in a small specified 22335 -- size), and then build a range subtree with these narrowed bounds. 22336 -- Set_Fixed_Range constructs the range from real literal values, and 22337 -- sets the range as the Scalar_Range of the given fixed-point type entity. 22338 22339 -- The parent of this range is set to point to the entity so that it is 22340 -- properly hooked into the tree (unlike normal Scalar_Range entries for 22341 -- other scalar types, which are just pointers to the range in the 22342 -- original tree, this would otherwise be an orphan). 22343 22344 -- The tree is left unanalyzed. When the type is frozen, the processing 22345 -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not 22346 -- analyzed, and uses this as an indication that it should complete 22347 -- work on the range (it will know the final small and size values). 22348 22349 procedure Set_Fixed_Range 22350 (E : Entity_Id; 22351 Loc : Source_Ptr; 22352 Lo : Ureal; 22353 Hi : Ureal) 22354 is 22355 S : constant Node_Id := 22356 Make_Range (Loc, 22357 Low_Bound => Make_Real_Literal (Loc, Lo), 22358 High_Bound => Make_Real_Literal (Loc, Hi)); 22359 begin 22360 Set_Scalar_Range (E, S); 22361 Set_Parent (S, E); 22362 22363 -- Before the freeze point, the bounds of a fixed point are universal 22364 -- and carry the corresponding type. 22365 22366 Set_Etype (Low_Bound (S), Universal_Real); 22367 Set_Etype (High_Bound (S), Universal_Real); 22368 end Set_Fixed_Range; 22369 22370 ---------------------------------- 22371 -- Set_Scalar_Range_For_Subtype -- 22372 ---------------------------------- 22373 22374 procedure Set_Scalar_Range_For_Subtype 22375 (Def_Id : Entity_Id; 22376 R : Node_Id; 22377 Subt : Entity_Id) 22378 is 22379 Kind : constant Entity_Kind := Ekind (Def_Id); 22380 22381 begin 22382 -- Defend against previous error 22383 22384 if Nkind (R) = N_Error then 22385 return; 22386 end if; 22387 22388 Set_Scalar_Range (Def_Id, R); 22389 22390 -- We need to link the range into the tree before resolving it so 22391 -- that types that are referenced, including importantly the subtype 22392 -- itself, are properly frozen (Freeze_Expression requires that the 22393 -- expression be properly linked into the tree). Of course if it is 22394 -- already linked in, then we do not disturb the current link. 22395 22396 if No (Parent (R)) then 22397 Set_Parent (R, Def_Id); 22398 end if; 22399 22400 -- Reset the kind of the subtype during analysis of the range, to 22401 -- catch possible premature use in the bounds themselves. 22402 22403 Set_Ekind (Def_Id, E_Void); 22404 Process_Range_Expr_In_Decl (R, Subt, Subtyp => Def_Id); 22405 Set_Ekind (Def_Id, Kind); 22406 end Set_Scalar_Range_For_Subtype; 22407 22408 -------------------------------------------------------- 22409 -- Set_Stored_Constraint_From_Discriminant_Constraint -- 22410 -------------------------------------------------------- 22411 22412 procedure Set_Stored_Constraint_From_Discriminant_Constraint 22413 (E : Entity_Id) 22414 is 22415 begin 22416 -- Make sure set if encountered during Expand_To_Stored_Constraint 22417 22418 Set_Stored_Constraint (E, No_Elist); 22419 22420 -- Give it the right value 22421 22422 if Is_Constrained (E) and then Has_Discriminants (E) then 22423 Set_Stored_Constraint (E, 22424 Expand_To_Stored_Constraint (E, Discriminant_Constraint (E))); 22425 end if; 22426 end Set_Stored_Constraint_From_Discriminant_Constraint; 22427 22428 ------------------------------------- 22429 -- Signed_Integer_Type_Declaration -- 22430 ------------------------------------- 22431 22432 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is 22433 Implicit_Base : Entity_Id; 22434 Base_Typ : Entity_Id; 22435 Lo_Val : Uint; 22436 Hi_Val : Uint; 22437 Errs : Boolean := False; 22438 Lo : Node_Id; 22439 Hi : Node_Id; 22440 22441 function Can_Derive_From (E : Entity_Id) return Boolean; 22442 -- Determine whether given bounds allow derivation from specified type 22443 22444 procedure Check_Bound (Expr : Node_Id); 22445 -- Check bound to make sure it is integral and static. If not, post 22446 -- appropriate error message and set Errs flag 22447 22448 --------------------- 22449 -- Can_Derive_From -- 22450 --------------------- 22451 22452 -- Note we check both bounds against both end values, to deal with 22453 -- strange types like ones with a range of 0 .. -12341234. 22454 22455 function Can_Derive_From (E : Entity_Id) return Boolean is 22456 Lo : constant Uint := Expr_Value (Type_Low_Bound (E)); 22457 Hi : constant Uint := Expr_Value (Type_High_Bound (E)); 22458 begin 22459 return Lo <= Lo_Val and then Lo_Val <= Hi 22460 and then 22461 Lo <= Hi_Val and then Hi_Val <= Hi; 22462 end Can_Derive_From; 22463 22464 ----------------- 22465 -- Check_Bound -- 22466 ----------------- 22467 22468 procedure Check_Bound (Expr : Node_Id) is 22469 begin 22470 -- If a range constraint is used as an integer type definition, each 22471 -- bound of the range must be defined by a static expression of some 22472 -- integer type, but the two bounds need not have the same integer 22473 -- type (Negative bounds are allowed.) (RM 3.5.4) 22474 22475 if not Is_Integer_Type (Etype (Expr)) then 22476 Error_Msg_N 22477 ("integer type definition bounds must be of integer type", Expr); 22478 Errs := True; 22479 22480 elsif not Is_OK_Static_Expression (Expr) then 22481 Flag_Non_Static_Expr 22482 ("non-static expression used for integer type bound!", Expr); 22483 Errs := True; 22484 22485 -- Otherwise the bounds are folded into literals 22486 22487 elsif Is_Entity_Name (Expr) then 22488 Fold_Uint (Expr, Expr_Value (Expr), True); 22489 end if; 22490 end Check_Bound; 22491 22492 -- Start of processing for Signed_Integer_Type_Declaration 22493 22494 begin 22495 -- Create an anonymous base type 22496 22497 Implicit_Base := 22498 Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B'); 22499 22500 -- Analyze and check the bounds, they can be of any integer type 22501 22502 Lo := Low_Bound (Def); 22503 Hi := High_Bound (Def); 22504 22505 -- Arbitrarily use Integer as the type if either bound had an error 22506 22507 if Hi = Error or else Lo = Error then 22508 Base_Typ := Any_Integer; 22509 Set_Error_Posted (T, True); 22510 Errs := True; 22511 22512 -- Here both bounds are OK expressions 22513 22514 else 22515 Analyze_And_Resolve (Lo, Any_Integer); 22516 Analyze_And_Resolve (Hi, Any_Integer); 22517 22518 Check_Bound (Lo); 22519 Check_Bound (Hi); 22520 22521 if Errs then 22522 Hi := Type_High_Bound (Standard_Long_Long_Long_Integer); 22523 Lo := Type_Low_Bound (Standard_Long_Long_Long_Integer); 22524 end if; 22525 22526 -- Find type to derive from 22527 22528 Lo_Val := Expr_Value (Lo); 22529 Hi_Val := Expr_Value (Hi); 22530 22531 if Can_Derive_From (Standard_Short_Short_Integer) then 22532 Base_Typ := Base_Type (Standard_Short_Short_Integer); 22533 22534 elsif Can_Derive_From (Standard_Short_Integer) then 22535 Base_Typ := Base_Type (Standard_Short_Integer); 22536 22537 elsif Can_Derive_From (Standard_Integer) then 22538 Base_Typ := Base_Type (Standard_Integer); 22539 22540 elsif Can_Derive_From (Standard_Long_Integer) then 22541 Base_Typ := Base_Type (Standard_Long_Integer); 22542 22543 elsif Can_Derive_From (Standard_Long_Long_Integer) then 22544 Check_Restriction (No_Long_Long_Integers, Def); 22545 Base_Typ := Base_Type (Standard_Long_Long_Integer); 22546 22547 elsif Can_Derive_From (Standard_Long_Long_Long_Integer) then 22548 Check_Restriction (No_Long_Long_Integers, Def); 22549 Base_Typ := Base_Type (Standard_Long_Long_Long_Integer); 22550 22551 else 22552 Base_Typ := Base_Type (Standard_Long_Long_Long_Integer); 22553 Error_Msg_N ("integer type definition bounds out of range", Def); 22554 Hi := Type_High_Bound (Standard_Long_Long_Long_Integer); 22555 Lo := Type_Low_Bound (Standard_Long_Long_Long_Integer); 22556 end if; 22557 end if; 22558 22559 -- Set the type of the bounds to the implicit base: we cannot set it to 22560 -- the new type, because this would be a forward reference for the code 22561 -- generator and, if the original type is user-defined, this could even 22562 -- lead to spurious semantic errors. Furthermore we do not set it to be 22563 -- universal, because this could make it much larger than needed here. 22564 22565 if not Errs then 22566 Set_Etype (Lo, Implicit_Base); 22567 Set_Etype (Hi, Implicit_Base); 22568 end if; 22569 22570 -- Complete both implicit base and declared first subtype entities. The 22571 -- inheritance of the rep item chain ensures that SPARK-related pragmas 22572 -- are not clobbered when the signed integer type acts as a full view of 22573 -- a private type. 22574 22575 Set_Etype (Implicit_Base, Base_Typ); 22576 Set_Size_Info (Implicit_Base, Base_Typ); 22577 Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); 22578 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); 22579 Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); 22580 22581 Set_Ekind (T, E_Signed_Integer_Subtype); 22582 Set_Etype (T, Implicit_Base); 22583 Set_Size_Info (T, Implicit_Base); 22584 Inherit_Rep_Item_Chain (T, Implicit_Base); 22585 Set_Scalar_Range (T, Def); 22586 Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); 22587 Set_Is_Constrained (T); 22588 end Signed_Integer_Type_Declaration; 22589 22590end Sem_Ch3; 22591