-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Errout; use Errout;
with Eval_Fat; use Eval_Fat;
with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch9; use Exp_Ch9;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Tss; use Exp_Tss;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
Derived_Type : Entity_Id);
-- Subsidiary procedure to Build_Derived_Type. For a derived enumeration
-- type, we must create a new list of literals. Types derived from
- -- Character and Wide_Character are special-cased.
+ -- Character and [Wide_]Wide_Character are special-cased.
procedure Build_Derived_Numeric_Type
(N : Node_Id;
-- Needs a more complete spec--what are the parameters exactly, and what
-- exactly is the returned value, and how is Bound affected???
- procedure Build_Itype_Reference
- (Ityp : Entity_Id;
- Nod : Node_Id);
- -- Create a reference to an internal type, for use by Gigi. The back-end
- -- elaborates itypes on demand, i.e. when their first use is seen. This
- -- can lead to scope anomalies if the first use is within a scope that is
- -- nested within the scope that contains the point of definition of the
- -- itype. The Itype_Reference node forces the elaboration of the itype
- -- in the proper scope. The node is inserted after Nod, which is the
- -- enclosing declaration that generated Ityp.
- --
- -- A related mechanism is used during expansion, for itypes created in
- -- branches of conditionals. See Ensure_Defined in exp_util.
- -- Could both mechanisms be merged ???
-
procedure Build_Underlying_Full_View
(N : Node_Id;
Typ : Entity_Id;
function Is_Progenitor
(Iface : Entity_Id;
- Typ : Entity_Id) return Boolean;
- -- Determine whether type Typ implements interface Iface. This requires
+ Typ : Entity_Id) return Boolean;
+ -- Determine whether the interface Iface is implemented by Typ. It requires
-- traversing the list of abstract interfaces of the type, as well as that
-- of the ancestor types. The predicate is used to determine when a formal
-- in the signature of an inherited operation must carry the derived type.
-- given kind of type (index constraint to an array type, for example).
procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id);
- -- Create new modular type. Verify that modulus is in bounds and is
+ -- Create new modular type. Verify that modulus is in bounds and is
-- a power of two (implementation restriction).
procedure New_Concatenation_Op (Typ : Entity_Id);
(Related_Nod : Node_Id;
N : Node_Id) return Entity_Id
is
- Loc : constant Source_Ptr := Sloc (Related_Nod);
- Anon_Type : Entity_Id;
- Anon_Scope : Entity_Id;
- Desig_Type : Entity_Id;
- Decl : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Related_Nod);
+ Anon_Type : Entity_Id;
+ Anon_Scope : Entity_Id;
+ Desig_Type : Entity_Id;
+ Decl : Entity_Id;
+ Enclosing_Prot_Type : Entity_Id := Empty;
begin
if Is_Entry (Current_Scope)
-- If the current scope is a protected type, the anonymous access
-- is associated with one of the protected operations, and must
-- be available in the scope that encloses the protected declaration.
- -- Otherwise the type is is in the scope enclosing the subprogram.
+ -- 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
+ -- the scope of the current function scope.
if Ekind (Current_Scope) = E_Protected_Type then
- Anon_Scope := Scope (Scope (Defining_Entity (Related_Nod)));
+ Enclosing_Prot_Type := Current_Scope;
+
+ elsif Ekind (Current_Scope) = E_Function
+ and then Ekind (Scope (Current_Scope)) = E_Protected_Type
+ then
+ Enclosing_Prot_Type := Scope (Current_Scope);
+ end if;
+
+ if Present (Enclosing_Prot_Type) then
+ Anon_Scope := Scope (Enclosing_Prot_Type);
+
else
Anon_Scope := Scope (Defining_Entity (Related_Nod));
end if;
Desig_Type := Entity (Subtype_Mark (N));
Set_Directly_Designated_Type
- (Anon_Type, Desig_Type);
- Set_Etype (Anon_Type, Anon_Type);
+ (Anon_Type, Desig_Type);
+ Set_Etype (Anon_Type, Anon_Type);
-- Make sure the anonymous access type has size and alignment fields
-- set, as required by gigi. This is necessary in the case of the
Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
- -- Ada 2005 (AI-50217): Propagate the attribute that indicates that the
- -- designated type comes from the limited view.
-
- Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
-
-- Ada 2005 (AI-231): Propagate the access-constant attribute
Set_Is_Access_Constant (Anon_Type, Constant_Present (N));
Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod)));
-- Similarly, if the access definition is the return result of a
- -- protected function, create an itype reference for it because it
- -- will be used within the function body.
+ -- 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 Ekind (Current_Scope) = E_Protected_Type
+ and then not From_With_Type (Desig_Type)
+ and then not Is_Generic_Type (Desig_Type)
then
- Build_Itype_Reference (Anon_Type, Parent (Current_Scope));
+ if Present (Enclosing_Prot_Type) then
+ Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type));
+
+ elsif Is_List_Member (Parent (Related_Nod))
+ and then Nkind (Parent (N)) /= N_Parameter_Specification
+ then
+ 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);
is
procedure Check_For_Premature_Usage (Def : Node_Id);
- -- Check that type T_Name is not used, directly or recursively,
- -- as a parameter or a return type in Def. Def is either a subtype,
- -- an access_definition, or an access_to_subprogram_definition.
+ -- Check that type T_Name is not used, directly or recursively, as a
+ -- parameter or a return type in Def. Def is either a subtype, an
+ -- access_definition, or an access_to_subprogram_definition.
-------------------------------
-- Check_For_Premature_Usage --
or else
Nkind_In (D_Ityp, N_Object_Declaration,
N_Object_Renaming_Declaration,
+ N_Formal_Object_Declaration,
N_Formal_Type_Declaration,
N_Task_Type_Declaration,
N_Protected_Type_Declaration))
else
Analyze (Result_Definition (T_Def));
- Set_Etype (Desig_Type, Entity (Result_Definition (T_Def)));
+
+ declare
+ Typ : constant Entity_Id := Entity (Result_Definition (T_Def));
+
+ begin
+ -- If a null exclusion is imposed on the result type, then
+ -- create a null-excluding itype (an access subtype) and use
+ -- it as the function's Etype.
+
+ if Is_Access_Type (Typ)
+ and then Null_Exclusion_In_Return_Present (T_Def)
+ then
+ Set_Etype (Desig_Type,
+ Create_Null_Excluding_Itype
+ (T => Typ,
+ Related_Nod => T_Def,
+ Scope_Id => Current_Scope));
+
+ else
+ if From_With_Type (Typ) then
+ Error_Msg_NE
+ ("illegal use of incomplete type&",
+ Result_Definition (T_Def), Typ);
+
+ elsif Ekind (Current_Scope) = E_Package
+ and then In_Private_Part (Current_Scope)
+ then
+ if Ekind (Typ) = E_Incomplete_Type then
+ Append_Elmt (Desig_Type, Private_Dependents (Typ));
+
+ elsif Is_Class_Wide_Type (Typ)
+ and then Ekind (Etype (Typ)) = E_Incomplete_Type
+ then
+ Append_Elmt
+ (Desig_Type, Private_Dependents (Etype (Typ)));
+ end if;
+ end if;
+
+ Set_Etype (Desig_Type, Typ);
+ end if;
+ end;
end if;
if not (Is_Type (Etype (Desig_Type))) then
if Present (Formals) then
Push_Scope (Desig_Type);
+
+ -- A bit of a kludge here. These kludges will be removed when Itypes
+ -- have proper parent pointers to their declarations???
+
+ -- Kludge 1) Link defining_identifier of formals. Required by
+ -- First_Formal to provide its functionality.
+
+ declare
+ F : Node_Id;
+
+ begin
+ F := First (Formals);
+ while Present (F) loop
+ if No (Parent (Defining_Identifier (F))) then
+ Set_Parent (Defining_Identifier (F), F);
+ end if;
+
+ Next (F);
+ end loop;
+ end;
+
Process_Formals (Formals, Parent (T_Def));
- -- A bit of a kludge here, End_Scope requires that the parent
- -- pointer be set to something reasonable, but Itypes don't have
- -- parent pointers. So we set it and then unset it ??? If and when
- -- Itypes have proper parent pointers to their declarations, this
- -- kludge can be removed.
+ -- Kludge 2) End_Scope requires that the parent pointer be set to
+ -- something reasonable, but Itypes don't have parent pointers. So
+ -- we set it and then unset it ???
Set_Parent (Desig_Type, T_Name);
End_Scope;
end loop;
end if;
+ -- If the return type is incomplete, this is legal as long as the
+ -- type is declared in the current scope and will be completed in
+ -- it (rather than being part of limited view).
+
if Ekind (Etype (Desig_Type)) = E_Incomplete_Type
and then not Has_Delayed_Freeze (Desig_Type)
+ and then In_Open_Scopes (Scope (Etype (Desig_Type)))
then
Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type)));
Set_Has_Delayed_Freeze (Desig_Type);
procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is
S : constant Node_Id := Subtype_Indication (Def);
P : constant Node_Id := Parent (Def);
-
- Desig : Entity_Id;
- -- Designated type
-
begin
-- Check for permissible use of incomplete type
Init_Size_Align (T);
end if;
- Desig := Designated_Type (T);
-
- -- If designated type is an imported tagged type, indicate that the
- -- access type is also imported, and therefore restricted in its use.
- -- The access type may already be imported, so keep setting otherwise.
-
- -- Ada 2005 (AI-50217): If the non-limited view of the designated type
- -- is available, use it as the designated type of the access type, so
- -- that the back-end gets a usable entity.
-
- if From_With_Type (Desig)
- and then Ekind (Desig) /= E_Access_Type
- then
- Set_From_With_Type (T);
- end if;
-
-- Note that Has_Task is always false, since the access type itself
-- is not a task type. See Einfo for more description on this point.
-- Exactly the same consideration applies to Has_Controlled_Component.
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 --
-----------------------------------
if Ada_Version >= Ada_05
and then Ekind (T) = E_Anonymous_Access_Type
+ and then Etype (E) /= Any_Type
then
-- Check RM 3.9.2(9): "if the expected type for an expression is
-- an anonymous access-to-specific tagged type, then the object
End_Scope;
- -- If the type has discriminants, non-trivial subtypes may be be
+ -- If the type has discriminants, non-trivial subtypes may be
-- declared before the full view of the type. The full views of those
-- subtypes will be built after the full view of the type.
if Constant_Present (N) then
Prev_Entity := Current_Entity_In_Scope (Id);
- -- If the homograph is an implicit subprogram, it is overridden by
- -- the current declaration.
-
if Present (Prev_Entity)
and then
+ -- If the homograph is an implicit subprogram, it is overridden
+ -- by the current declaration.
+
((Is_Overloadable (Prev_Entity)
- and then Is_Inherited_Operation (Prev_Entity))
+ and then Is_Inherited_Operation (Prev_Entity))
-- The current object is a discriminal generated for an entry
-- family index. Even though the index is a constant, in this
or else
(Is_Discriminal (Id)
and then Ekind (Discriminal_Link (Id)) =
- E_Entry_Index_Parameter))
+ E_Entry_Index_Parameter)
+
+ -- The current object is the renaming for a generic declared
+ -- within the instance.
+
+ or else
+ (Ekind (Prev_Entity) = E_Package
+ and then Nkind (Parent (Prev_Entity)) =
+ N_Package_Renaming_Declaration
+ and then not Comes_From_Source (Prev_Entity)
+ and then Is_Generic_Instance (Renamed_Entity (Prev_Entity))))
then
Prev_Entity := Empty;
end if;
if Constant_Present (N)
and then No (E)
then
- -- We exclude forward references to tags
-
- if Is_Imported (Defining_Identifier (N))
- and then
- (T = RTE (RE_Tag)
- or else
- (Present (Full_View (T))
- and then Full_View (T) = RTE (RE_Tag)))
- then
- null;
-
-- A deferred constant may appear in the declarative part of the
-- following constructs:
-- return statements are flagged as invalid contexts because they do
-- not have a declarative part and so cannot accommodate the pragma.
- elsif Ekind (Current_Scope) = E_Return_Statement then
+ if Ekind (Current_Scope) = E_Return_Statement then
Error_Msg_N
("invalid context for deferred constant declaration (RM 7.4)",
N);
Set_Etype (Id, T);
Resolve (E, T);
+ -- If E is null and has been replaced by an N_Raise_Constraint_Error
+ -- node (which was marked already-analyzed), we need to set the type
+ -- to something other than Any_Access in order to keep gigi happy.
+
+ if Etype (E) = Any_Access then
+ Set_Etype (E, T);
+ end if;
+
-- If the object is an access to variable, the initialization
-- expression cannot be an access to constant.
and then Is_Access_Constant (Etype (E))
then
Error_Msg_N
- ("object that is an 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
end if;
end if;
- -- Check incorrect use of dynamically tagged expressions. Note
- -- the use of Is_Tagged_Type (T) which seems redundant but is in
- -- fact important to avoid spurious errors due to expanded code
- -- for dispatching functions over an anonymous access type
+ -- Check incorrect use of dynamically tagged expressions.
- if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E))
- and then Is_Tagged_Type (T)
- and then not Is_Class_Wide_Type (T)
- then
- Error_Msg_N ("dynamically tagged expression not allowed!", E);
+ if Is_Tagged_Type (T) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => E,
+ Typ => T,
+ Related_Nod => N);
end if;
Apply_Scalar_Range_Check (E, T);
end if;
end if;
- -- Abstract type is never permitted for a variable or constant.
- -- Note: we inhibit this check for objects that do not come from
- -- source because there is at least one case (the expansion of
- -- x'class'input where x is abstract) where we legitimately
- -- generate an abstract object.
-
- if Is_Abstract_Type (T) and then Comes_From_Source (N) then
- Error_Msg_N ("type of object cannot be abstract",
- Object_Definition (N));
-
- if Is_CPP_Class (T) then
- Error_Msg_NE ("\} may need a cpp_constructor",
- Object_Definition (N), T);
- end if;
-
-- Case of unconstrained type
- elsif Is_Indefinite_Subtype (T) then
+ if Is_Indefinite_Subtype (T) then
-- Nothing to do in deferred constant case
then
Act_T := Etype (E);
+ -- In case of class-wide interface object declarations we delay
+ -- the generation of the equivalent record type declarations until
+ -- its expansion because there are cases in they are not required.
+
+ elsif Is_Interface (T) then
+ null;
+
else
Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
Act_T := Find_Type_Of_Object (Object_Definition (N), N);
end if;
end if;
+ -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
+ -- extension with a synchronized parent must be explicitly declared
+ -- synchronized, because the full view will be a synchronized type.
+ -- This must be checked before the check for limited types below,
+ -- to ensure that types declared limited are not allowed to extend
+ -- synchronized interfaces.
+
+ elsif Is_Interface (Parent_Type)
+ and then Is_Synchronized_Interface (Parent_Type)
+ and then not Synchronized_Present (N)
+ then
+ Error_Msg_NE
+ ("private extension of& must be explicitly synchronized",
+ N, Parent_Type);
+
elsif Limited_Present (N) then
Set_Is_Limited_Record (T);
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Machine_Radix_10 (Id, Machine_Radix_10 (T));
Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_Is_Known_Valid (Id, Is_Known_Valid (T));
Set_RM_Size (Id, RM_Size (T));
when Enumeration_Kind =>
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Character_Type (Id, Is_Character_Type (T));
Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_Is_Known_Valid (Id, Is_Known_Valid (T));
Set_RM_Size (Id, RM_Size (T));
when Ordinary_Fixed_Point_Kind =>
Set_Small_Value (Id, Small_Value (T));
Set_Delta_Value (Id, Delta_Value (T));
Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_Is_Known_Valid (Id, Is_Known_Valid (T));
Set_RM_Size (Id, RM_Size (T));
when Float_Kind =>
Set_Ekind (Id, E_Signed_Integer_Subtype);
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_Is_Known_Valid (Id, Is_Known_Valid (T));
Set_RM_Size (Id, RM_Size (T));
when Modular_Integer_Kind =>
Set_Ekind (Id, E_Modular_Integer_Subtype);
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_Is_Known_Valid (Id, Is_Known_Valid (T));
Set_RM_Size (Id, RM_Size (T));
when Class_Wide_Kind =>
-- A Pure library_item must not contain the declaration of a
-- named access type, except within a subprogram, generic
- -- subprogram, task unit, or protected unit (RM 10.2.1(16)).
+ -- subprogram, task unit, or protected unit, or if it has
+ -- a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)).
if Comes_From_Source (Id)
and then In_Pure_Unit
and then not In_Subprogram_Task_Protected_Unit
+ and then not No_Pool_Assigned (Id)
then
Error_Msg_N
("named access types not allowed in pure unit", N);
-- subtype. Freeze_Entity will use this preallocated freeze node when
-- it freezes the entity.
- if B /= T then
+ -- This does not apply if the base type is a generic type, whose
+ -- declaration is independent of the current derived definition.
+
+ if B /= T and then not Is_Generic_Type (B) then
Ensure_Freeze_Node (B);
Set_First_Subtype_Link (Freeze_Node (B), T);
end if;
- if not From_With_Type (T) then
+ -- A type that is imported through a limited_with clause cannot
+ -- generate any code, and thus need not be frozen. However, an access
+ -- type with an imported designated type needs a finalization list,
+ -- which may be referenced in some other package that has non-limited
+ -- visibility on the designated type. Thus we must create the
+ -- finalization list at the point the access type is frozen, to
+ -- prevent unsatisfied references at link time.
+
+ if not From_With_Type (T) or else Is_Access_Type (T) then
Set_Has_Delayed_Freeze (T);
end if;
end;
- -- Case of T is the full declaration of some private type which has
+ -- Case where T is the full declaration of some private type which has
-- been swapped in Defining_Identifier (N).
if T /= Def_Id and then Is_Private_Type (Def_Id) then
Generate_Definition (Def_Id);
end if;
- if Chars (Scope (Def_Id)) = Name_System
+ if Chars (Scope (Def_Id)) = Name_System
and then Chars (Def_Id) = Name_Address
and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
then
Comp := Object_Definition (N);
Acc := Comp;
+ when N_Function_Specification =>
+ Comp := Result_Definition (N);
+ Acc := Comp;
+
when others =>
raise Program_Error;
end case;
Mark_Rewrite_Insertion (Decl);
- -- Insert the new declaration in the nearest enclosing scope
+ -- Insert the new declaration in the nearest enclosing scope. If the
+ -- node is a body and N is its return type, the declaration belongs in
+ -- the enclosing scope.
P := Parent (N);
+
+ if Nkind (P) = N_Subprogram_Body
+ and then Nkind (N) = N_Function_Specification
+ then
+ P := Parent (P);
+ end if;
+
while Present (P) and then not Has_Declarations (P) loop
P := Parent (P);
end loop;
elsif Nkind (N) = N_Access_Function_Definition then
Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
+ elsif Nkind (N) = N_Function_Specification then
+ Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
+ Set_Etype (Defining_Unit_Name (N), Anon);
+
else
Rewrite (Comp,
Make_Component_Definition (Loc,
Mark_Rewrite_Insertion (Comp);
- -- Temporarily remove the current scope from the stack to add the new
- -- declarations to the enclosing scope
-
if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then
Analyze (Decl);
else
+ -- Temporarily remove the current scope (record or subprogram) from
+ -- the stack to add the new declarations to the enclosing scope.
+
Scope_Stack.Decrement_Last;
Analyze (Decl);
Set_Is_Itype (Anon);
Has_Private_Component (Derived_Type));
Conditional_Delay (Derived_Type, Subt);
- -- Ada 2005 (AI-231). Set the null-exclusion attribute
+ -- Ada 2005 (AI-231): Set the null-exclusion attribute, and verify
+ -- that it is not redundant.
- if Null_Exclusion_Present (Type_Definition (N))
- or else Can_Never_Be_Null (Parent_Type)
- then
+ if Null_Exclusion_Present (Type_Definition (N)) then
+ Set_Can_Never_Be_Null (Derived_Type);
+
+ if Can_Never_Be_Null (Parent_Type)
+ and then False
+ then
+ Error_Msg_NE
+ ("`NOT NULL` not allowed (& already excludes null)",
+ N, Parent_Type);
+ end if;
+
+ elsif Can_Never_Be_Null (Parent_Type) then
Set_Can_Never_Be_Null (Derived_Type);
end if;
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;
------------------------------------
Rang_Expr : Node_Id;
begin
- -- Since types Standard.Character and Standard.Wide_Character do
+ -- Since types Standard.Character and Standard.[Wide_]Wide_Character do
-- not have explicit literals lists we need to process types derived
-- from them specially. This is handled by Derived_Standard_Character.
-- If the parent type is a generic type, there are no literals either,
Hi : Node_Id;
begin
- Lo :=
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_First,
- Prefix => New_Reference_To (Derived_Type, Loc));
- Set_Etype (Lo, Derived_Type);
+ if Nkind (Indic) /= N_Subtype_Indication then
+ Lo :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix => New_Reference_To (Derived_Type, Loc));
+ Set_Etype (Lo, Derived_Type);
+
+ Hi :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Last,
+ Prefix => New_Reference_To (Derived_Type, Loc));
+ Set_Etype (Hi, Derived_Type);
+
+ Set_Scalar_Range (Derived_Type,
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi));
+ else
- Hi :=
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Last,
- Prefix => New_Reference_To (Derived_Type, Loc));
- Set_Etype (Hi, Derived_Type);
-
- Set_Scalar_Range (Derived_Type,
- Make_Range (Loc,
- Low_Bound => Lo,
- High_Bound => Hi));
+ -- Analyze subtype indication and verify compatibility
+ -- with parent type.
+
+ if Base_Type (Process_Subtype (Indic, N)) /=
+ Base_Type (Parent_Type)
+ then
+ Error_Msg_N
+ ("illegal constraint for formal discrete type", N);
+ end if;
+ end if;
end;
else
Set_Size_Info (Implicit_Base, Parent_Base);
Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base));
Set_Parent (Implicit_Base, Parent (Derived_Type));
+ Set_Is_Known_Valid (Implicit_Base, Is_Known_Valid (Parent_Base));
-- Set RM Size for discrete type or decimal fixed-point type
-- Ordinary fixed-point is excluded, why???
if Has_Infinities (Parent_Type) then
Set_Includes_Infinities (Scalar_Range (Derived_Type));
end if;
+
+ Set_Is_Known_Valid (Derived_Type, Is_Known_Valid (Parent_Type));
end if;
Set_Is_Descendent_Of_Address (Derived_Type,
Set_Non_Binary_Modulus
(Implicit_Base, Non_Binary_Modulus (Parent_Base));
+ Set_Is_Known_Valid
+ (Implicit_Base, Is_Known_Valid (Parent_Base));
+
elsif Is_Floating_Point_Type (Parent_Type) then
-- Digits of base type is always copied from the digits value of
Is_Completion : Boolean;
Derive_Subps : Boolean := True)
is
+ Loc : constant Source_Ptr := Sloc (N);
Der_Base : Entity_Id;
Discr : Entity_Id;
Full_Decl : Node_Id := Empty;
begin
if Is_Tagged_Type (Parent_Type) then
- Build_Derived_Record_Type
- (N, Parent_Type, Derived_Type, Derive_Subps);
+ Full_P := Full_View (Parent_Type);
+
+ -- A type extension of a type with unknown discriminants is an
+ -- indefinite type that the back-end cannot handle directly.
+ -- We treat it as a private type, and build a completion that is
+ -- derived from the full view of the parent, and hopefully has
+ -- known discriminants.
+
+ -- If the full view of the parent type has an underlying record view,
+ -- use it to generate the underlying record view of this derived type
+ -- (required for chains of derivations with unknown discriminants).
+
+ -- Minor optimization: we avoid the generation of useless underlying
+ -- record view entities if the private type declaration has unknown
+ -- discriminants but its corresponding full view has no
+ -- discriminants.
+
+ if Has_Unknown_Discriminants (Parent_Type)
+ and then Present (Full_P)
+ and then (Has_Discriminants (Full_P)
+ or else Present (Underlying_Record_View (Full_P)))
+ and then not In_Open_Scopes (Par_Scope)
+ and then Expander_Active
+ then
+ declare
+ Full_Der : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+ New_Ext : constant Node_Id :=
+ Copy_Separate_Tree
+ (Record_Extension_Part (Type_Definition (N)));
+ Decl : Node_Id;
+
+ begin
+ Build_Derived_Record_Type
+ (N, Parent_Type, Derived_Type, Derive_Subps);
+
+ -- Build anonymous completion, as a derivation from the full
+ -- view of the parent. This is not a completion in the usual
+ -- sense, because the current type is not private.
+
+ Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Full_Der,
+ Type_Definition =>
+ Make_Derived_Type_Definition (Loc,
+ Subtype_Indication =>
+ New_Copy_Tree
+ (Subtype_Indication (Type_Definition (N))),
+ Record_Extension_Part => New_Ext));
+
+ -- If the parent type has an underlying record view, use it
+ -- here to build the new underlying record view.
+
+ if Present (Underlying_Record_View (Full_P)) then
+ pragma Assert
+ (Nkind (Subtype_Indication (Type_Definition (Decl)))
+ = N_Identifier);
+ Set_Entity (Subtype_Indication (Type_Definition (Decl)),
+ Underlying_Record_View (Full_P));
+ end if;
+
+ Install_Private_Declarations (Par_Scope);
+ Install_Visible_Declarations (Par_Scope);
+ Insert_Before (N, Decl);
+
+ -- Mark entity as an underlying record view before analysis,
+ -- to avoid generating the list of its primitive operations
+ -- (which is not really required for this entity) and thus
+ -- prevent spurious errors associated with missing overriding
+ -- of abstract primitives (overridden only for Derived_Type).
+
+ Set_Ekind (Full_Der, E_Record_Type);
+ Set_Is_Underlying_Record_View (Full_Der);
+
+ Analyze (Decl);
+
+ pragma Assert (Has_Discriminants (Full_Der)
+ and then not Has_Unknown_Discriminants (Full_Der));
+
+ Uninstall_Declarations (Par_Scope);
+
+ -- Freeze the underlying record view, to prevent generation of
+ -- useless dispatching information, which is simply shared with
+ -- the real derived type.
+
+ Set_Is_Frozen (Full_Der);
+
+ -- Set up links between real entity and underlying record view
+
+ Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der));
+ Set_Underlying_Record_View (Base_Type (Full_Der), Derived_Type);
+ end;
+
+ -- If discriminants are known, build derived record
+
+ else
+ Build_Derived_Record_Type
+ (N, Parent_Type, Derived_Type, Derive_Subps);
+ end if;
+
return;
elsif Has_Discriminants (Parent_Type) then
Insert_After (N, Full_Decl);
else
- -- If this is a completion, the full view being built is
- -- itself private. We build a subtype of the parent with
- -- the same constraints as this full view, to convey to the
- -- back end the constrained components and the size of this
- -- subtype. If the parent is constrained, its full view can
- -- serve as the underlying full view of the derived type.
+ -- If this is a completion, the full view being built is itself
+ -- private. We build a subtype of the parent with the same
+ -- constraints as this full view, to convey to the back end the
+ -- constrained components and the size of this subtype. If the
+ -- parent is constrained, its full view can serve as the
+ -- underlying full view of the derived type.
if No (Discriminant_Specifications (N)) then
if Nkind (Subtype_Indication (Type_Definition (N))) =
Build_Underlying_Full_View (N, Derived_Type, Parent_Type);
elsif Is_Constrained (Full_View (Parent_Type)) then
- Set_Underlying_Full_View (Derived_Type,
- Full_View (Parent_Type));
+ Set_Underlying_Full_View
+ (Derived_Type, Full_View (Parent_Type));
end if;
else
-- If there are new discriminants, the parent subtype is
-- constrained by them, but it is not clear how to build
- -- the underlying_full_view in this case ???
+ -- the Underlying_Full_View in this case???
null;
end if;
Build_Derived_Record_Type
(N, Parent_Type, Derived_Type, Derive_Subps);
- if Present (Full_View (Parent_Type))
- and then not Is_Completion
- then
+ if Present (Full_View (Parent_Type)) and then not Is_Completion then
if not In_Open_Scopes (Par_Scope)
or else not In_Same_Source_Unit (N, Parent_Type)
then
end if;
else
- -- If full view of parent is tagged, the completion
- -- inherits the proper primitive operations.
+ -- If full view of parent is tagged, the completion inherits
+ -- the proper primitive operations.
Set_Defining_Identifier (Full_Decl, Full_Der);
Build_Derived_Record_Type
Set_Full_View (Der_Base, Base_Type (Full_Der));
-- Copy the discriminant list from full view to the partial views
- -- (base type and its subtype). Gigi requires that the partial
- -- and full views have the same discriminants.
+ -- (base type and its subtype). Gigi requires that the partial and
+ -- full views have the same discriminants.
-- Note that since the partial view is pointing to discriminants
-- in the full view, their scope will be that of the full view.
- -- This might cause some front end problems and need
- -- adjustment???
+ -- This might cause some front end problems and need adjustment???
Discr := First_Discriminant (Base_Type (Full_Der));
Set_First_Entity (Der_Base, Discr);
Set_Stored_Constraint (Full_Der, Stored_Constraint (Derived_Type));
else
- -- If this is a completion, the derived type stays private
- -- and there is no need to create a further full view, except
- -- in the unusual case when the derivation is nested within a
- -- child unit, see below.
+ -- If this is a completion, the derived type stays private and
+ -- there is no need to create a further full view, except in the
+ -- unusual case when the derivation is nested within a child unit,
+ -- see below.
null;
end if;
return;
end if;
- -- If full view of parent is a record type, Build full view as
- -- a derivation from the parent's full view. Partial view remains
- -- private. For code generation and linking, the full view must
- -- have the same public status as the partial one. This full view
- -- is only needed if the parent type is in an enclosing scope, so
- -- that the full view may actually become visible, e.g. in a child
- -- unit. This is both more efficient, and avoids order of freezing
- -- problems with the added entities.
+ -- If full view of parent is a record type, build full view as a
+ -- derivation from the parent's full view. Partial view remains
+ -- private. For code generation and linking, the full view must have
+ -- the same public status as the partial one. This full view is only
+ -- needed if the parent type is in an enclosing scope, so that the
+ -- full view may actually become visible, e.g. in a child unit. This
+ -- is both more efficient, and avoids order of freezing problems with
+ -- the added entities.
if not Is_Private_Type (Full_View (Parent_Type))
and then (In_Open_Scopes (Scope (Parent_Type)))
Derive_Subps => False);
end if;
- -- In any case, the primitive operations are inherited from
- -- the parent type, not from the internal full view.
+ -- In any case, the primitive operations are inherited from the
+ -- parent type, not from the internal full view.
Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type));
and then Present (Full_View (Parent_Type))
and then not Is_Tagged_Type (Full_View (Parent_Type))
then
- Error_Msg_N
- ("cannot add discriminants to untagged type", N);
+ Error_Msg_N ("cannot add discriminants to untagged type", N);
end if;
Set_Stored_Constraint (Derived_Type, No_Elist);
(Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
end if;
- -- Construct the implicit full view by deriving from full view of
- -- the parent type. In order to get proper visibility, we install
- -- the parent scope and its declarations.
+ -- Construct the implicit full view by deriving from full view of the
+ -- parent type. In order to get proper visibility, we install the
+ -- parent scope and its declarations.
- -- ??? if the parent is untagged private and its completion is
- -- tagged, this mechanism will not work because we cannot derive
- -- from the tagged full view unless we have an extension
+ -- ??? If the parent is untagged private and its completion is
+ -- tagged, this mechanism will not work because we cannot derive from
+ -- the tagged full view unless we have an extension.
if Present (Full_View (Parent_Type))
and then not Is_Tagged_Type (Full_View (Parent_Type))
Set_Is_Frozen (Full_Der, False);
Set_Freeze_Node (Full_Der, Empty);
Set_Depends_On_Private (Full_Der,
- Has_Private_Component (Full_Der));
+ Has_Private_Component (Full_Der));
Set_Public_Status (Full_Der);
end if;
end if;
and then Scope (Parent_Type) /= Current_Scope
then
-- This is the unusual case where a type completed by a private
- -- derivation occurs within a package nested in a child unit,
- -- and the parent is declared in an ancestor. In this case, the
- -- full view of the parent type will become visible in the body
- -- of the enclosing child, and only then will the current type
- -- be possibly non-private. We build a underlying full view that
+ -- derivation occurs within a package nested in a child unit, and
+ -- the parent is declared in an ancestor. In this case, the full
+ -- view of the parent type will become visible in the body of
+ -- the enclosing child, and only then will the current type be
+ -- possibly non-private. We build a underlying full view that
-- will be installed when the enclosing child body is compiled.
Full_Der :=
-- The representation clauses for T can specify a completely different
-- record layout from R's. Hence the same component can be placed in two
- -- very different positions in objects of type T and R. If R and are tagged
- -- types, representation clauses for T can only specify the layout of non
- -- inherited components, thus components that are common in R and T have
- -- the same position in objects of type R and T.
+ -- very different positions in objects of type T and R. If R and T are
+ -- tagged types, representation clauses for T can only specify the layout
+ -- of non inherited components, thus components that are common in R and T
+ -- have the same position in objects of type R and T.
-- This has two implications. The first is that the entire tree for R's
-- declaration needs to be copied for T in the untagged case, so that T
Type_Definition =>
Make_Derived_Type_Definition (Loc,
Abstract_Present => Abstract_Present (Type_Def),
+ Limited_Present => Limited_Present (Type_Def),
Subtype_Indication =>
New_Occurrence_Of (Parent_Base, Loc),
Record_Extension_Part =>
- Relocate_Node (Record_Extension_Part (Type_Def))));
+ Relocate_Node (Record_Extension_Part (Type_Def)),
+ Interface_List => Interface_List (Type_Def)));
Set_Parent (New_Decl, Parent (N));
Mark_Rewrite_Insertion (New_Decl);
-- Fields inherited from the Parent_Type
Set_Discard_Names
- (Derived_Type, Einfo.Discard_Names (Parent_Type));
+ (Derived_Type, Einfo.Discard_Names (Parent_Type));
Set_Has_Specified_Layout
- (Derived_Type, Has_Specified_Layout (Parent_Type));
+ (Derived_Type, Has_Specified_Layout (Parent_Type));
Set_Is_Limited_Composite
- (Derived_Type, Is_Limited_Composite (Parent_Type));
+ (Derived_Type, Is_Limited_Composite (Parent_Type));
Set_Is_Private_Composite
- (Derived_Type, Is_Private_Composite (Parent_Type));
+ (Derived_Type, Is_Private_Composite (Parent_Type));
-- Fields inherited from the Parent_Base
-- Fields inherited from the Parent_Base for record types
if Is_Record_Type (Derived_Type) then
- Set_OK_To_Reorder_Components
- (Derived_Type, OK_To_Reorder_Components (Parent_Base));
- Set_Reverse_Bit_Order
- (Derived_Type, Reverse_Bit_Order (Parent_Base));
+
+ -- Ekind (Parent_Base) is not necessarily E_Record_Type since
+ -- Parent_Base can be a private type or private extension.
+
+ if Present (Full_View (Parent_Base)) then
+ Set_OK_To_Reorder_Components
+ (Derived_Type,
+ OK_To_Reorder_Components (Full_View (Parent_Base)));
+ Set_Reverse_Bit_Order
+ (Derived_Type, Reverse_Bit_Order (Full_View (Parent_Base)));
+ else
+ Set_OK_To_Reorder_Components
+ (Derived_Type, OK_To_Reorder_Components (Parent_Base));
+ Set_Reverse_Bit_Order
+ (Derived_Type, Reverse_Bit_Order (Parent_Base));
+ end if;
end if;
-- Direct controlled types do not inherit Finalize_Storage_Only flag
else
Set_Component_Alignment
(Derived_Type, Component_Alignment (Parent_Base));
-
Set_C_Pass_By_Copy
(Derived_Type, C_Pass_By_Copy (Parent_Base));
end if;
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
end if;
- Make_Class_Wide_Type (Derived_Type);
+ -- Minor optimization: there is no need to generate the class-wide
+ -- entity associated with an underlying record view.
+
+ if not Is_Underlying_Record_View (Derived_Type) then
+ Make_Class_Wide_Type (Derived_Type);
+ end if;
+
Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def));
if Has_Discriminants (Derived_Type)
end if;
end if;
- -- Update the class_wide type, which shares the now-completed
- -- entity list with its specific type.
+ -- Update the class-wide type, which shares the now-completed entity
+ -- list with its specific type. In case of underlying record views,
+ -- we do not generate the corresponding class wide entity.
- if Is_Tagged then
+ if Is_Tagged
+ and then not Is_Underlying_Record_View (Derived_Type)
+ then
Set_First_Entity
(Class_Wide_Type (Derived_Type), First_Entity (Derived_Type));
Set_Last_Entity
Set_Etype (Derived_Type, Parent_Base);
Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
- Set_Size_Info (Derived_Type, Parent_Type);
- Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
- Set_Convention (Derived_Type, Convention (Parent_Type));
- Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
+ Set_Size_Info (Derived_Type, Parent_Type);
+ Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
+ Set_Convention (Derived_Type, Convention (Parent_Type));
+ Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
+ Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
-- The derived type inherits the representation clauses of the parent.
-- However, for a private type that is completed by a derivation, there
(Designated_Type (Etype (Discr_Expr (J))))
then
Wrong_Type (Discr_Expr (J), Etype (Discr));
+
+ elsif Is_Access_Type (Etype (Discr))
+ and then not Is_Access_Constant (Etype (Discr))
+ and then Is_Access_Type (Etype (Discr_Expr (J)))
+ and then Is_Access_Constant (Etype (Discr_Expr (J)))
+ then
+ Error_Msg_NE
+ ("constraint for discriminant& must be access to variable",
+ Def, Discr);
end if;
end if;
-- declaration, all clauses are inherited.
if No (First_Rep_Item (Def_Id)) then
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
end if;
if Is_Tagged_Type (T) then
-- Error message below needs rewording (remember comma
-- in -gnatj mode) ???
- if Ekind (First_Formal (Subp)) = E_In_Parameter then
+ if Ekind (First_Formal (Subp)) = E_In_Parameter
+ and then Ekind (Subp) /= E_Function
+ then
if not Is_Predefined_Dispatching_Operation (Subp) then
Error_Msg_NE
("first formal of & must be of mode `OUT`, " &
Error_Msg_NE
("interface subprogram & must be overridden",
T, Subp);
+
+ -- Examine primitive operations of synchronized type,
+ -- to find homonyms that have the wrong profile.
+
+ declare
+ Prim : Entity_Id;
+
+ begin
+ Prim :=
+ First_Entity (Corresponding_Concurrent_Type (T));
+ while Present (Prim) loop
+ if Chars (Prim) = Chars (Subp) then
+ Error_Msg_NE
+ ("profile is not type conformant with "
+ & "prefixed view profile of "
+ & "inherited operation&", Prim, Subp);
+ end if;
+
+ Next_Entity (Prim);
+ end loop;
+ end;
end if;
end if;
----------------
procedure Post_Error is
+
+ procedure Missing_Body;
+ -- Output missing body message
+
+ ------------------
+ -- Missing_Body --
+ ------------------
+
+ procedure Missing_Body is
+ begin
+ -- Spec is in same unit, so we can post on spec
+
+ if In_Same_Source_Unit (Body_Id, E) then
+ Error_Msg_N ("missing body for &", E);
+
+ -- Spec is in a separate unit, so we have to post on the body
+
+ else
+ Error_Msg_NE ("missing body for & declared#!", Body_Id, E);
+ end if;
+ end Missing_Body;
+
+ -- Start of processing for Post_Error
+
begin
if not Comes_From_Source (E) then
Check_Type_Conformant (Candidate, E);
else
- Error_Msg_NE ("missing body for & declared#!",
- Body_Id, E);
+ Missing_Body;
end if;
end;
+
else
- Error_Msg_NE ("missing body for & declared#!",
- Body_Id, E);
+ Missing_Body;
end if;
end if;
end if;
end Post_Error;
- -- Start processing for Check_Completion
+ -- Start of processing for Check_Completion
begin
E := First_Entity (Current_Scope);
-- source (including the _Call primitive operation of RAS types,
-- which has to have the flag Comes_From_Source for other purposes):
-- we assume that the expander will provide the missing completion.
+ -- In case of previous errors, other expansion actions that provide
+ -- bodies for null procedures with not be invoked, so inhibit message
+ -- in those cases.
+ -- Note that E_Operator is not in the list that follows, because
+ -- this kind is reserved for predefined operators, that are
+ -- intrinsic and do not need completion.
elsif Ekind (E) = E_Function
or else Ekind (E) = E_Procedure
or else Ekind (E) = E_Generic_Function
or else Ekind (E) = E_Generic_Procedure
then
- if not Has_Completion (E)
- and then not (Is_Subprogram (E)
- and then Is_Abstract_Subprogram (E))
- and then not (Is_Subprogram (E)
- and then
- (not Comes_From_Source (E)
- or else Chars (E) = Name_uCall))
- and then Nkind (Parent (Unit_Declaration_Node (E))) /=
- N_Compilation_Unit
- and then Chars (E) /= Name_uSize
+ if Has_Completion (E) then
+ null;
+
+ elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then
+ null;
+
+ elsif Is_Subprogram (E)
+ and then (not Comes_From_Source (E)
+ or else Chars (E) = Name_uCall)
then
+ null;
+
+ elsif
+ Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
+ then
+ null;
+
+ elsif Nkind (Parent (E)) = N_Procedure_Specification
+ and then Null_Present (Parent (E))
+ and then Serious_Errors_Detected > 0
+ then
+ null;
+
+ else
Post_Error;
end if;
and then not In_Instance
and then not In_Inlined_Body
then
- if not OK_For_Limited_Init (Exp) then
+ if not OK_For_Limited_Init (T, Exp) then
-- In GNAT mode, this is just a warning, to allow it to be evilly
-- turned off. Otherwise it is a real error.
Is_Protected := True;
end if;
+ if Is_Synchronized_Interface (Iface_Id) then
+
+ -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
+ -- extension derived from a synchronized interface must explicitly
+ -- be declared synchronized, because the full view will be a
+ -- synchronized type.
+
+ if Nkind (N) = N_Private_Extension_Declaration then
+ if not Synchronized_Present (N) then
+ Error_Msg_NE
+ ("private extension of& must be explicitly synchronized",
+ N, Iface_Id);
+ end if;
+
+ -- However, by 3.9.4(16/2), a full type that is a record extension
+ -- is never allowed to derive from a synchronized interface (note
+ -- that interfaces must be excluded from this check, because those
+ -- are represented by derived type definitions in some cases).
+
+ elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition
+ and then not Interface_Present (Type_Definition (N))
+ then
+ Error_Msg_N ("record extension cannot derive from synchronized"
+ & " interface", Error_Node);
+ end if;
+ end if;
+
-- Check that the characteristics of the progenitor are compatible
-- with the explicit qualifier in the declaration.
-- The check only applies to qualifiers that come from source.
or else Protected_Present (Iface_Def)
or else Synchronized_Present (Iface_Def))
and then Nkind (N) /= N_Private_Extension_Declaration
+ and then not Error_Posted (N)
then
Error_Msg_NE
("progenitor& must be limited interface",
Error_Msg_N ("ALIASED required (see declaration#)", N);
end if;
- -- Allow incomplete declaration of tags (used to handle forward
- -- references to tags). The check on Ada_Tags avoids circularities
- -- when rebuilding the compiler.
-
- if RTU_Loaded (Ada_Tags)
- and then T = RTE (RE_Tag)
- then
- null;
-
-- Check that placement is in private part and that the incomplete
-- declaration appeared in the visible part.
- elsif Ekind (Current_Scope) = E_Package
+ if Ekind (Current_Scope) = E_Package
and then not In_Private_Part (Current_Scope)
then
Error_Msg_Sloc := Sloc (Prev);
Set_Convention (T1, Convention (T2));
Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2));
Set_Is_Private_Composite (T1, Is_Private_Composite (T2));
+ Set_Packed_Array_Type (T1, Packed_Array_Type (T2));
end Copy_Array_Subtype_Attributes;
-----------------------------------
and then Is_Completely_Hidden (Old_Compon)
then
-- This is a shadow discriminant created for a discriminant of
- -- the parent type that is one of several renamed by the same
- -- new discriminant. Give the shadow discriminant an internal
- -- name that cannot conflict with that of visible components.
+ -- the parent type, which needs to be present in the subtype.
+ -- Give the shadow discriminant an internal name that cannot
+ -- conflict with that of visible components.
Set_Chars (New_Compon, New_Internal_Name ('C'));
end if;
-- For an untagged derived subtype, the number of discriminants may
-- be smaller than the number of inherited discriminants, because
- -- several of them may be renamed by a single new discriminant.
- -- In this case, add the hidden discriminants back into the subtype,
- -- because otherwise the size of the subtype is computed incorrectly
- -- in GCC 4.1.
+ -- several of them may be renamed by a single new discriminant or
+ -- constrained. In this case, add the hidden discriminants back into
+ -- the subtype, because they need to be present if the optimizer of
+ -- the GCC 4.x back-end decides to break apart assignments between
+ -- objects using the parent view into member-wise assignments.
Num_Gird := 0;
-- component for the current old discriminant.
New_C := Create_Component (Old_Discr);
- Set_Original_Record_Component (New_C, Old_Discr);
+ Set_Original_Record_Component (New_C, Old_Discr);
end if;
+
+ else
+ -- The constraint has eliminated the old discriminant.
+ -- Introduce a shadow component.
+
+ New_C := Create_Component (Old_Discr);
+ Set_Original_Record_Component (New_C, Old_Discr);
end if;
Next_Elmt (Constr);
and then Is_Tagged_Type (Tagged_Type)
and then Has_Interfaces (Tagged_Type));
- -- Step 1: Transfer to the full-view primitives asociated with the
+ -- Step 1: Transfer to the full-view primitives associated with the
-- partial-view that cover interface primitives. Conceptually this
-- work should be done later by Process_Full_View; done here to
-- simplify its implementation at later stages. It can be safely
-- Step 2: Add primitives of progenitors that are not implemented by
-- parents of Tagged_Type
- if Present (Interfaces (Tagged_Type)) then
- Iface_Elmt := First_Elmt (Interfaces (Tagged_Type));
+ if Present (Interfaces (Base_Type (Tagged_Type))) then
+ Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type)));
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
then
Set_Derived_Name;
+ -- An inherited dispatching equality will be overridden by an internally
+ -- generated one, or by an explicit one, so preserve its name and thus
+ -- its entry in the dispatch table. Otherwise, if Parent_Subp is a
+ -- private operation it may become invisible if the full view has
+ -- progenitors, and the dispatch table will be malformed.
+ -- We check that the type is limited to handle the anomalous declaration
+ -- of Limited_Controlled, which is derived from a non-limited type, and
+ -- which is handled specially elsewhere as well.
+
+ elsif Chars (Parent_Subp) = Name_Op_Eq
+ and then Is_Dispatching_Operation (Parent_Subp)
+ and then Etype (Parent_Subp) = Standard_Boolean
+ and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp)))
+ and then
+ Etype (First_Formal (Parent_Subp)) =
+ Etype (Next_Formal (First_Formal (Parent_Subp)))
+ then
+ Set_Derived_Name;
+
-- If parent is hidden, this can be a regular derivation if the
-- parent is immediately visible in a non-instantiating context,
-- or if we are in the private part of an instance. This test
elsif Parent_Overrides_Interface_Primitive then
Set_Derived_Name;
- -- The type is inheriting a private operation, so enter
+ -- Otherwise, the type is inheriting a private operation, so enter
-- it with a special name so it can't be overridden.
else
null;
elsif Protected_Present (Iface_Def) then
- Error_Msg_N
- ("(Ada 2005) limited interface cannot "
- & "inherit from protected interface", Indic);
+ Error_Msg_NE
+ ("descendant of& must be declared"
+ & " as a protected interface",
+ N, Parent_Type);
elsif Synchronized_Present (Iface_Def) then
- Error_Msg_N
- ("(Ada 2005) limited interface cannot "
- & "inherit from synchronized interface", Indic);
+ Error_Msg_NE
+ ("descendant of& must be declared"
+ & " as a synchronized interface",
+ N, Parent_Type);
elsif Task_Present (Iface_Def) then
- Error_Msg_N
- ("(Ada 2005) limited interface cannot "
- & "inherit from task interface", Indic);
+ Error_Msg_NE
+ ("descendant of& must be declared as a task interface",
+ N, Parent_Type);
else
Error_Msg_N
null;
elsif Protected_Present (Iface_Def) then
- Error_Msg_N
- ("(Ada 2005) non-limited interface cannot "
- & "inherit from protected interface", Indic);
+ Error_Msg_NE
+ ("descendant of& must be declared"
+ & " as a protected interface",
+ N, Parent_Type);
elsif Synchronized_Present (Iface_Def) then
- Error_Msg_N
- ("(Ada 2005) non-limited interface cannot "
- & "inherit from synchronized interface", Indic);
+ Error_Msg_NE
+ ("descendant of& must be declared"
+ & " as a synchronized interface",
+ N, Parent_Type);
elsif Task_Present (Iface_Def) then
- Error_Msg_N
- ("(Ada 2005) non-limited interface cannot "
- & "inherit from task interface", Indic);
-
+ Error_Msg_NE
+ ("descendant of& must be declared as a task interface",
+ N, Parent_Type);
else
null;
end if;
end;
end if;
- Build_Derived_Type (N, Parent_Type, T, Is_Completion);
+ if Null_Exclusion_Present (Def)
+ and then not Is_Access_Type (Parent_Type)
+ then
+ Error_Msg_N ("null exclusion can only apply to an access type", N);
+ end if;
+
+ -- Avoid deriving parent primitives of underlying record views
+
+ Build_Derived_Type (N, Parent_Type, T, Is_Completion,
+ Derive_Subps => not Is_Underlying_Record_View (T));
-- AI-419: The parent type of an explicitly limited derived type must
-- be a limited type or a limited interface.
Ev := Uint_0;
-- Loop through literals of enumeration type setting pos and rep values
- -- except that if the Ekind is already set, then it means that the
- -- literal was already constructed (case of a derived type declaration
- -- and we should not disturb the Pos and Rep values.
+ -- except that if the Ekind is already set, then it means the literal
+ -- was already constructed (case of a derived type declaration and we
+ -- should not disturb the Pos and Rep values.
while Present (L) loop
if Ekind (L) /= E_Enumeration_Literal then
end if;
end Tag_Mismatch;
- -- Start processing for Find_Type_Name
+ -- Start of processing for Find_Type_Name
begin
-- Find incomplete declaration, if one was given
Set_Scope (Id, Current_Scope);
New_Id := Id;
+ -- If this is a repeated incomplete declaration, no further
+ -- checks are possible.
+
+ if Nkind (N) = N_Incomplete_Type_Declaration then
+ return Prev;
+ end if;
+
-- Case of full declaration of incomplete type
elsif Ekind (Prev) = E_Incomplete_Type then
elsif No (Interface_List (N)) then
Error_Msg_N
("completion of tagged private type must be tagged",
- N);
+ N);
end if;
+
+ elsif Nkind (N) = N_Full_Type_Declaration
+ and then
+ Nkind (Type_Definition (N)) = N_Record_Definition
+ and then Interface_Present (Type_Definition (N))
+ then
+ Error_Msg_N
+ ("completion of private type cannot be an interface", N);
end if;
-- Ada 2005 (AI-251): Private extension declaration of a task
Error_Msg_NE (
"full declaration of } must be a record extension",
Prev, Id);
+
+ -- Set some attributes to produce a usable full view
+
Set_Is_Tagged_Type (Id);
Set_Primitive_Operations (Id, New_Elmt_List);
end if;
-----------------------
function Is_Null_Extension (T : Entity_Id) return Boolean is
- Type_Decl : constant Node_Id := Parent (T);
+ Type_Decl : constant Node_Id := Parent (Base_Type (T));
Comp_List : Node_Id;
Comp : Node_Id;
else
Init_Esize (T, System_Max_Binary_Modulus_Power);
end if;
+
+ if not Non_Binary_Modulus (T)
+ and then Esize (T) = RM_Size (T)
+ then
+ Set_Is_Known_Valid (T);
+ end if;
end Set_Modular_Size;
-- Start of processing for Modular_Type_Declaration
-- ???Check all calls of this, and compare the conditions under which it's
-- called.
- function OK_For_Limited_Init (Exp : Node_Id) return Boolean is
+ function OK_For_Limited_Init
+ (Typ : Entity_Id;
+ Exp : Node_Id) return Boolean
+ is
begin
- return Ada_Version >= Ada_05
- and then not Debug_Flag_Dot_L
- and then OK_For_Limited_Init_In_05 (Exp);
+ return Is_CPP_Constructor_Call (Exp)
+ or else (Ada_Version >= Ada_05
+ and then not Debug_Flag_Dot_L
+ and then OK_For_Limited_Init_In_05 (Typ, Exp));
end OK_For_Limited_Init;
-------------------------------
-- OK_For_Limited_Init_In_05 --
-------------------------------
- function OK_For_Limited_Init_In_05 (Exp : Node_Id) return Boolean is
+ function OK_For_Limited_Init_In_05
+ (Typ : Entity_Id;
+ Exp : Node_Id) return Boolean
+ is
begin
+ -- An object of a limited interface type can be initialized with any
+ -- expression of a nonlimited descendant type.
+
+ if Is_Class_Wide_Type (Typ)
+ and then Is_Limited_Interface (Typ)
+ and then not Is_Limited_Type (Etype (Exp))
+ then
+ return True;
+ end if;
+
-- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in
-- case of limited aggregates (including extension aggregates), and
-- function calls. The function call may have been give in prefixed
when N_Qualified_Expression =>
return
- OK_For_Limited_Init_In_05 (Expression (Original_Node (Exp)));
+ OK_For_Limited_Init_In_05
+ (Typ, Expression (Original_Node (Exp)));
-- Ada 2005 (AI-251): If a class-wide interface object is initialized
-- with a function call, the expander has rewritten the call into an
-- N_Type_Conversion node to force displacement of the pointer to
-- reference the component containing the secondary dispatch table.
-- Otherwise a type conversion is not a legal context.
+ -- A return statement for a build-in-place function returning a
+ -- synchronized type also introduces an unchecked conversion.
- when N_Type_Conversion =>
+ when N_Type_Conversion | N_Unchecked_Type_Conversion =>
return not Comes_From_Source (Exp)
and then
- OK_For_Limited_Init_In_05 (Expression (Original_Node (Exp)));
+ OK_For_Limited_Init_In_05
+ (Typ, Expression (Original_Node (Exp)));
when N_Indexed_Component | N_Selected_Component =>
return Nkind (Exp) = N_Function_Call;
Create_Null_Excluding_Itype
(T => Discr_Type,
Related_Nod => Discr));
+
+ -- Check for improper null exclusion if the type is otherwise
+ -- legal for a discriminant.
+
+ elsif Null_Exclusion_Present (Discr)
+ and then Is_Discrete_Type (Discr_Type)
+ then
+ Error_Msg_N
+ ("null exclusion can only apply to an access type", Discr);
end if;
-- Ada 2005 (AI-402): access discriminants of nonlimited types
-- Ada 2005 (AI-251): If the parent of the private type declaration
-- is an interface there is no need to check that it is an ancestor
-- of the associated full type declaration. The required tests for
- -- this case case are performed by Build_Derived_Record_Type.
+ -- this case are performed by Build_Derived_Record_Type.
elsif not Is_Interface (Base_Type (Priv_Parent))
and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
-- If the private view was tagged, copy the new primitive operations
-- from the private view to the full view.
- -- Note: Subprograms covering interface primitives were previously
- -- propagated to the full view by Derive_Progenitor_Primitives
-
- if Is_Tagged_Type (Full_T)
- and then not Is_Concurrent_Type (Full_T)
- then
+ if Is_Tagged_Type (Full_T) then
declare
- Priv_List : Elist_Id;
- Full_List : constant Elist_Id := Primitive_Operations (Full_T);
- P1, P2 : Elmt_Id;
+ Disp_Typ : Entity_Id;
+ Full_List : Elist_Id;
Prim : Entity_Id;
- D_Type : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Priv_List : Elist_Id;
+
+ function Contains
+ (E : Entity_Id;
+ L : Elist_Id) return Boolean;
+ -- Determine whether list L contains element E
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains
+ (E : Entity_Id;
+ L : Elist_Id) return Boolean
+ is
+ List_Elmt : Elmt_Id;
+
+ begin
+ List_Elmt := First_Elmt (L);
+ while Present (List_Elmt) loop
+ if Node (List_Elmt) = E then
+ return True;
+ end if;
+
+ Next_Elmt (List_Elmt);
+ end loop;
+
+ return False;
+ end Contains;
+
+ -- Start of processing
begin
if Is_Tagged_Type (Priv_T) then
Priv_List := Primitive_Operations (Priv_T);
+ Prim_Elmt := First_Elmt (Priv_List);
+
+ -- In the case of a concurrent type completing a private tagged
+ -- type, primitives may have been declared in between the two
+ -- views. These subprograms need to be wrapped the same way
+ -- entries and protected procedures are handled because they
+ -- cannot be directly shared by the two views.
- P1 := First_Elmt (Priv_List);
- while Present (P1) loop
- Prim := Node (P1);
+ if Is_Concurrent_Type (Full_T) then
+ declare
+ Conc_Typ : constant Entity_Id :=
+ Corresponding_Record_Type (Full_T);
+ Curr_Nod : Node_Id := Parent (Conc_Typ);
+ Wrap_Spec : Node_Id;
- -- Transfer explicit primitives, not those inherited from
- -- parent of partial view, which will be re-inherited on
- -- the full view.
+ begin
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- if Comes_From_Source (Prim) then
- P2 := First_Elmt (Full_List);
- while Present (P2) and then Node (P2) /= Prim loop
- Next_Elmt (P2);
+ if Comes_From_Source (Prim)
+ and then not Is_Abstract_Subprogram (Prim)
+ then
+ Wrap_Spec :=
+ Make_Subprogram_Declaration (Sloc (Prim),
+ Specification =>
+ Build_Wrapper_Spec
+ (Subp_Id => Prim,
+ Obj_Typ => Conc_Typ,
+ Formals =>
+ Parameter_Specifications (
+ Parent (Prim))));
+
+ Insert_After (Curr_Nod, Wrap_Spec);
+ Curr_Nod := Wrap_Spec;
+
+ Analyze (Wrap_Spec);
+ end if;
+
+ Next_Elmt (Prim_Elmt);
end loop;
- -- If not found, that is a new one
+ return;
+ end;
+
+ -- For non-concurrent types, transfer explicit primitives, but
+ -- omit those inherited from the parent of the private view
+ -- since they will be re-inherited later on.
+
+ else
+ Full_List := Primitive_Operations (Full_T);
- if No (P2) then
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if Comes_From_Source (Prim)
+ and then not Contains (Prim, Full_List)
+ then
Append_Elmt (Prim, Full_List);
end if;
- end if;
- Next_Elmt (P1);
- end loop;
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
+
+ -- Untagged private view
else
+ Full_List := Primitive_Operations (Full_T);
+
-- In this case the partial view is untagged, so here we locate
-- all of the earlier primitives that need to be treated as
-- dispatching (those that appear between the two views). Note
or else
Ekind (Prim) = E_Function
then
+ Disp_Typ := Find_Dispatching_Type (Prim);
- D_Type := Find_Dispatching_Type (Prim);
-
- if D_Type = Full_T
+ if Disp_Typ = Full_T
and then (Chars (Prim) /= Name_Op_Ne
or else Comes_From_Source (Prim))
then
end if;
elsif Is_Dispatching_Operation (Prim)
- and then D_Type /= Full_T
+ and then Disp_Typ /= Full_T
then
-- Verify that it is not otherwise controlled by a
-- formal or a return value of type T.
- Check_Controlling_Formals (D_Type, Prim);
+ Check_Controlling_Formals (Disp_Typ, Prim);
end if;
end if;
Set_Is_CPP_Class (Full_T);
Set_Convention (Full_T, Convention_CPP);
end if;
+
+ -- If the private view has user specified stream attributes, then so has
+ -- the full view.
+
+ if Has_Specified_Stream_Read (Priv_T) then
+ Set_Has_Specified_Stream_Read (Full_T);
+ end if;
+ if Has_Specified_Stream_Write (Priv_T) then
+ Set_Has_Specified_Stream_Write (Full_T);
+ end if;
+ if Has_Specified_Stream_Input (Priv_T) then
+ Set_Has_Specified_Stream_Input (Full_T);
+ end if;
+ if Has_Specified_Stream_Output (Priv_T) then
+ Set_Has_Specified_Stream_Output (Full_T);
+ end if;
end Process_Full_View;
-----------------------------------
or else
Nkind_In (P, N_Derived_Type_Definition,
N_Discriminant_Specification,
+ N_Formal_Object_Declaration,
N_Object_Declaration,
+ N_Object_Renaming_Declaration,
N_Parameter_Specification,
N_Subtype_Declaration);
Error_Node :=
Subtype_Indication (Component_Definition (Related_Nod));
+ when N_Allocator =>
+ Error_Node := Expression (Related_Nod);
+
when others =>
pragma Assert (False);
Error_Node := Related_Nod;
E_Incomplete_Type =>
Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+ if Ekind (Def_Id) = E_Incomplete_Type then
+ Set_Private_Dependents (Def_Id, New_Elmt_List);
+ end if;
+
when Private_Kind =>
Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
Set_Private_Dependents (Def_Id, New_Elmt_List);
OSDN Git Service
