-- is associated with one of the protected operations, and must
-- be available in the scope that encloses the protected declaration.
-- Otherwise the type is in the scope enclosing the subprogram.
+
-- If the function has formals, The return type of a subprogram
-- declaration is analyzed in the scope of the subprogram (see
-- Process_Formals) and thus the protected type, if present, is
Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod)));
-- Similarly, if the access definition is the return result of a
- -- function, create an itype reference for it because it
- -- will be used within the function body. For a regular function that
- -- is not a compilation unit, insert reference after the declaration.
- -- For a protected operation, insert it after the enclosing protected
- -- type declaration. In either case, do not create a reference for a
- -- type obtained through a limited_with clause, because this would
- -- introduce semantic dependencies.
+ -- function, create an itype reference for it because it will be used
+ -- within the function body. For a regular function that is not a
+ -- compilation unit, insert reference after the declaration. For a
+ -- protected operation, insert it after the enclosing protected type
+ -- declaration. In either case, do not create a reference for a type
+ -- obtained through a limited_with clause, because this would introduce
+ -- semantic dependencies.
+
+ -- Similarly, do not create a reference if the designated type is a
+ -- generic formal, because no use of it will reach the backend.
elsif Nkind (Related_Nod) = N_Function_Specification
and then not From_With_Type (Desig_Type)
+ and then not Is_Generic_Type (Desig_Type)
then
if Present (Enclosing_Prot_Type) then
Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type));
Build_Itype_Reference (Anon_Type, Parent (Related_Nod));
end if;
- -- Finally, create an itype reference for an object declaration of
- -- an anonymous access type. This is strictly necessary only for
- -- deferred constants, but in any case will avoid out-of-scope
- -- problems in the back-end.
+ -- Finally, create an itype reference for an object declaration of an
+ -- anonymous access type. This is strictly necessary only for deferred
+ -- constants, but in any case will avoid out-of-scope problems in the
+ -- back-end.
elsif Nkind (Related_Nod) = N_Object_Declaration then
Build_Itype_Reference (Anon_Type, Related_Nod);
end if;
end Add_Interface_Tag_Components;
+ -------------------------------------
+ -- Add_Internal_Interface_Entities --
+ -------------------------------------
+
+ procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is
+ Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface_Prim : Entity_Id;
+ Ifaces_List : Elist_Id;
+ New_Subp : Entity_Id := Empty;
+ Prim : Entity_Id;
+
+ begin
+ pragma Assert (Ada_Version >= Ada_05
+ and then Is_Record_Type (Tagged_Type)
+ and then Is_Tagged_Type (Tagged_Type)
+ and then Has_Interfaces (Tagged_Type)
+ and then not Is_Interface (Tagged_Type));
+
+ Collect_Interfaces (Tagged_Type, Ifaces_List);
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ -- Exclude from this processing interfaces that are parents of
+ -- Tagged_Type because their primitives are located in the primary
+ -- dispatch table (and hence no auxiliary internal entities are
+ -- required to handle secondary dispatch tables in such case).
+
+ if not Is_Ancestor (Iface, Tagged_Type) then
+ Elmt := First_Elmt (Primitive_Operations (Iface));
+ while Present (Elmt) loop
+ Iface_Prim := Node (Elmt);
+
+ if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
+ Prim :=
+ Find_Primitive_Covering_Interface
+ (Tagged_Type => Tagged_Type,
+ Iface_Prim => Iface_Prim);
+
+ pragma Assert (Present (Prim));
+
+ Derive_Subprogram
+ (New_Subp => New_Subp,
+ Parent_Subp => Iface_Prim,
+ Derived_Type => Tagged_Type,
+ Parent_Type => Iface);
+
+ -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
+ -- associated with interface types. These entities are
+ -- only registered in the list of primitives of its
+ -- corresponding tagged type because they are only used
+ -- to fill the contents of the secondary dispatch tables.
+ -- Therefore they are removed from the homonym chains.
+
+ Set_Is_Hidden (New_Subp);
+ Set_Is_Internal (New_Subp);
+ Set_Alias (New_Subp, Prim);
+ Set_Is_Abstract_Subprogram (New_Subp,
+ Is_Abstract_Subprogram (Prim));
+ Set_Interface_Alias (New_Subp, Iface_Prim);
+
+ -- Internal entities associated with interface types are
+ -- only registered in the list of primitives of the tagged
+ -- type. They are only used to fill the contents of the
+ -- secondary dispatch tables. Therefore they are not needed
+ -- in the homonym chains.
+
+ Remove_Homonym (New_Subp);
+
+ -- Hidden entities associated with interfaces must have set
+ -- the Has_Delay_Freeze attribute to ensure that, in case of
+ -- locally defined tagged types (or compiling with static
+ -- dispatch tables generation disabled) the corresponding
+ -- entry of the secondary dispatch table is filled when
+ -- such an entity is frozen.
+
+ Set_Has_Delayed_Freeze (New_Subp);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end Add_Internal_Interface_Entities;
+
-----------------------------------
-- Analyze_Component_Declaration --
-----------------------------------
and then Is_Access_Constant (Etype (E))
then
Error_Msg_N
- ("access to variable cannot be initialized " &
- "with an access-to-constant expression", E);
+ ("access to variable cannot be initialized "
+ & "with an access-to-constant expression", E);
end if;
if not Assignment_OK (N) then
Check_Unset_Reference (E);
- -- If this is a variable, then set current value
+ -- If this is a variable, then set current value. If this is a
+ -- declared constant of a scalar type with a static expression,
+ -- indicate that it is always valid.
if not Constant_Present (N) then
if Compile_Time_Known_Value (E) then
Set_Current_Value (Id, E);
end if;
+
+ elsif Is_Scalar_Type (T)
+ and then Is_OK_Static_Expression (E)
+ then
+ Set_Is_Known_Valid (Id);
end if;
-- Deal with setting of null flags
Parent_Type : Entity_Id;
Derived_Type : Entity_Id)
is
- D_Constraint : Node_Id;
- Disc_Spec : Node_Id;
- Old_Disc : Entity_Id;
- New_Disc : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Corr_Record : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
+
+ Corr_Decl : Node_Id;
+ Corr_Decl_Needed : Boolean;
+ -- If the derived type has fewer discriminants than its parent, the
+ -- corresponding record is also a derived type, in order to account for
+ -- the bound discriminants. We create a full type declaration for it in
+ -- this case.
Constraint_Present : constant Boolean :=
- Nkind (Subtype_Indication (Type_Definition (N)))
- = N_Subtype_Indication;
+ Nkind (Subtype_Indication (Type_Definition (N))) =
+ N_Subtype_Indication;
+
+ D_Constraint : Node_Id;
+ New_Constraint : Elist_Id;
+ Old_Disc : Entity_Id;
+ New_Disc : Entity_Id;
+ New_N : Node_Id;
begin
Set_Stored_Constraint (Derived_Type, No_Elist);
+ Corr_Decl_Needed := False;
+ Old_Disc := Empty;
+
+ if Present (Discriminant_Specifications (N))
+ and then Constraint_Present
+ then
+ Old_Disc := First_Discriminant (Parent_Type);
+ New_Disc := First (Discriminant_Specifications (N));
+ while Present (New_Disc) and then Present (Old_Disc) loop
+ Next_Discriminant (Old_Disc);
+ Next (New_Disc);
+ end loop;
+ end if;
+
+ if Present (Old_Disc) then
+
+ -- The new type has fewer discriminants, so we need to create a new
+ -- corresponding record, which is derived from the corresponding
+ -- record of the parent, and has a stored constraint that captures
+ -- the values of the discriminant constraints.
+
+ -- The type declaration for the derived corresponding record has
+ -- the same discriminant part and constraints as the current
+ -- declaration. Copy the unanalyzed tree to build declaration.
+
+ Corr_Decl_Needed := True;
+ New_N := Copy_Separate_Tree (N);
+
+ Corr_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Corr_Record,
+ Discriminant_Specifications =>
+ Discriminant_Specifications (New_N),
+ Type_Definition =>
+ Make_Derived_Type_Definition (Loc,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (Corresponding_Record_Type (Parent_Type), Loc),
+ Constraint =>
+ Constraint
+ (Subtype_Indication (Type_Definition (New_N))))));
+ end if;
-- Copy Storage_Size and Relative_Deadline variables if task case
if Present (Discriminant_Specifications (N)) then
Push_Scope (Derived_Type);
Check_Or_Process_Discriminants (N, Derived_Type);
+
+ if Constraint_Present then
+ New_Constraint :=
+ Expand_To_Stored_Constraint
+ (Parent_Type,
+ Build_Discriminant_Constraints
+ (Parent_Type,
+ Subtype_Indication (Type_Definition (N)), True));
+ end if;
+
End_Scope;
elsif Constraint_Present then
end;
end if;
- -- All attributes are inherited from parent. In particular,
- -- entries and the corresponding record type are the same.
- -- Discriminants may be renamed, and must be treated separately.
+ -- By default, operations and private data are inherited from parent.
+ -- However, in the presence of bound discriminants, a new corresponding
+ -- record will be created, see below.
Set_Has_Discriminants
(Derived_Type, Has_Discriminants (Parent_Type));
(Constraints
(Constraint (Subtype_Indication (Type_Definition (N)))));
- Old_Disc := First_Discriminant (Parent_Type);
- New_Disc := First_Discriminant (Derived_Type);
- Disc_Spec := First (Discriminant_Specifications (N));
- while Present (Old_Disc) and then Present (Disc_Spec) loop
- if Nkind (Discriminant_Type (Disc_Spec)) /=
- N_Access_Definition
- then
- Analyze (Discriminant_Type (Disc_Spec));
+ Old_Disc := First_Discriminant (Parent_Type);
- if not Subtypes_Statically_Compatible (
- Etype (Discriminant_Type (Disc_Spec)),
- Etype (Old_Disc))
- then
- Error_Msg_N
- ("not statically compatible with parent discriminant",
- Discriminant_Type (Disc_Spec));
+ while Present (D_Constraint) loop
+ if Nkind (D_Constraint) /= N_Discriminant_Association then
+
+ -- Positional constraint. If it is a reference to a new
+ -- discriminant, it constrains the corresponding old one.
+
+ if Nkind (D_Constraint) = N_Identifier then
+ New_Disc := First_Discriminant (Derived_Type);
+ while Present (New_Disc) loop
+ exit when Chars (New_Disc) = Chars (D_Constraint);
+ Next_Discriminant (New_Disc);
+ end loop;
+
+ if Present (New_Disc) then
+ Set_Corresponding_Discriminant (New_Disc, Old_Disc);
+ end if;
+ end if;
+
+ Next_Discriminant (Old_Disc);
+
+ -- if this is a named constraint, search by name for the old
+ -- discriminants constrained by the new one.
+
+ elsif Nkind (Expression (D_Constraint)) = N_Identifier then
+
+ -- Find new discriminant with that name
+
+ New_Disc := First_Discriminant (Derived_Type);
+ while Present (New_Disc) loop
+ exit when
+ Chars (New_Disc) = Chars (Expression (D_Constraint));
+ Next_Discriminant (New_Disc);
+ end loop;
+
+ if Present (New_Disc) then
+
+ -- Verify that new discriminant renames some discriminant
+ -- of the parent type, and associate the new discriminant
+ -- with one or more old ones that it renames.
+
+ declare
+ Selector : Node_Id;
+
+ begin
+ Selector := First (Selector_Names (D_Constraint));
+ while Present (Selector) loop
+ Old_Disc := First_Discriminant (Parent_Type);
+ while Present (Old_Disc) loop
+ exit when Chars (Old_Disc) = Chars (Selector);
+ Next_Discriminant (Old_Disc);
+ end loop;
+
+ if Present (Old_Disc) then
+ Set_Corresponding_Discriminant
+ (New_Disc, Old_Disc);
+ end if;
+
+ Next (Selector);
+ end loop;
+ end;
end if;
end if;
- if Nkind (D_Constraint) = N_Identifier
- and then Chars (D_Constraint) /=
- Chars (Defining_Identifier (Disc_Spec))
+ Next (D_Constraint);
+ end loop;
+
+ New_Disc := First_Discriminant (Derived_Type);
+ while Present (New_Disc) loop
+ if No (Corresponding_Discriminant (New_Disc)) then
+ Error_Msg_NE
+ ("new discriminant& must constrain old one", N, New_Disc);
+
+ elsif not
+ Subtypes_Statically_Compatible
+ (Etype (New_Disc),
+ Etype (Corresponding_Discriminant (New_Disc)))
then
- Error_Msg_N ("new discriminants must constrain old ones",
- D_Constraint);
- else
- Set_Corresponding_Discriminant (New_Disc, Old_Disc);
+ Error_Msg_NE
+ ("& not statically compatible with parent discriminant",
+ N, New_Disc);
end if;
- Next_Discriminant (Old_Disc);
Next_Discriminant (New_Disc);
- Next (Disc_Spec);
end loop;
-
- if Present (Old_Disc) or else Present (Disc_Spec) then
- Error_Msg_N ("discriminant mismatch in derivation", N);
- end if;
-
end if;
elsif Present (Discriminant_Specifications (N)) then
Error_Msg_N
- ("missing discriminant constraint in untagged derivation",
- N);
+ ("missing discriminant constraint in untagged derivation", N);
end if;
+ -- The entity chain of the derived type includes the new discriminants
+ -- but shares operations with the parent.
+
if Present (Discriminant_Specifications (N)) then
Old_Disc := First_Discriminant (Parent_Type);
while Present (Old_Disc) loop
-
if No (Next_Entity (Old_Disc))
or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
then
- Set_Next_Entity (Last_Entity (Derived_Type),
- Next_Entity (Old_Disc));
+ Set_Next_Entity
+ (Last_Entity (Derived_Type), Next_Entity (Old_Disc));
exit;
end if;
Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type));
Set_Has_Completion (Derived_Type);
+
+ if Corr_Decl_Needed then
+ Set_Stored_Constraint (Derived_Type, New_Constraint);
+ Insert_After (N, Corr_Decl);
+ Analyze (Corr_Decl);
+ Set_Corresponding_Record_Type (Derived_Type, Corr_Record);
+ end if;
end Build_Derived_Concurrent_Type;
------------------------------------
OSDN Git Service
