-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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_Ch7; use Exp_Ch7;
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 Exp_Util; use Exp_Util;
-with Fname; use Fname;
with Freeze; use Freeze;
with Ghost; use Ghost;
with Itypes; use Itypes;
if Nkind (S) /= N_Subtype_Indication then
Analyze (S);
- if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then
+ if Present (Entity (S))
+ and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type
+ then
Set_Directly_Designated_Type (T, Entity (S));
-- If the designated type is a limited view, we cannot tell if
Derived_Type => Tagged_Type,
Parent_Type => Iface);
+ declare
+ Anc : Entity_Id;
+ begin
+ if Is_Inherited_Operation (Prim)
+ and then Present (Alias (Prim))
+ then
+ Anc := Alias (Prim);
+ else
+ Anc := Overridden_Operation (Prim);
+ end if;
+
+ -- Apply legality checks in RM 6.1.1 (10-13) concerning
+ -- nonconforming preconditions in both an ancestor and
+ -- a progenitor operation.
+
+ if Present (Anc)
+ and then Has_Non_Trivial_Precondition (Anc)
+ and then Has_Non_Trivial_Precondition (Iface_Prim)
+ then
+ if Is_Abstract_Subprogram (Prim)
+ or else
+ (Ekind (Prim) = E_Procedure
+ and then Nkind (Parent (Prim)) =
+ N_Procedure_Specification
+ and then Null_Present (Parent (Prim)))
+ then
+ null;
+
+ -- The inherited operation must be overridden
+
+ elsif not Comes_From_Source (Prim) then
+ Error_Msg_NE
+ ("&inherits non-conforming preconditions and must "
+ & "be overridden (RM 6.1.1 (10-16)",
+ Parent (Tagged_Type), Prim);
+ end if;
+ end if;
+ end;
+
-- 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
-- Utility to resolve the expressions of aspects at the end of a list of
-- declarations.
+ function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean;
+ -- Check if an inner package has entities within it that rely on library
+ -- level private types where the full view has not been seen.
+
-----------------
-- Adjust_Decl --
-----------------
if Nkind (Context) = N_Package_Specification then
+ -- Preanalyze and resolve the class-wide invariants of an
+ -- interface at the end of whichever declarative part has the
+ -- interface type. Note that an interface may be declared in
+ -- any non-package declarative part, but reaching the end of
+ -- such a declarative part will always freeze the type and
+ -- generate the invariant procedure (see Freeze_Type).
+
+ if Is_Interface (Typ) then
+
+ -- Interfaces are treated as the partial view of a private
+ -- type, in order to achieve uniformity with the general
+ -- case. As a result, an interface receives only a "partial"
+ -- invariant procedure, which is never called.
+
+ if Has_Own_Invariants (Typ) then
+ Build_Invariant_Procedure_Body
+ (Typ => Typ,
+ Partial_Invariant => True);
+ end if;
+
-- Preanalyze and resolve the invariants of a private type
-- at the end of the visible declarations to catch potential
-- errors. Inherited class-wide invariants are not included
-- because they have already been resolved.
- if Decls = Visible_Declarations (Context)
+ elsif Decls = Visible_Declarations (Context)
and then Ekind_In (Typ, E_Limited_Private_Type,
E_Private_Type,
E_Record_Type_With_Private)
(First (Pragma_Argument_Associations (ASN))));
Set_Parent (Exp, ASN);
- -- ??? why not Preanalyze_Assert_Expression
-
- Preanalyze (Exp);
+ Preanalyze_Assert_Expression (Exp, Standard_Boolean);
end if;
ASN := Next_Pragma (ASN);
end loop;
end Resolve_Aspects;
+ -------------------------------
+ -- Uses_Unseen_Lib_Unit_Priv --
+ -------------------------------
+
+ function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean is
+ Curr : Entity_Id;
+
+ begin
+ -- Avoid looking through scopes that do not meet the precondition of
+ -- Pkg not being within a library unit spec.
+
+ if not Is_Compilation_Unit (Pkg)
+ and then not Is_Generic_Instance (Pkg)
+ and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg))
+ then
+ -- Loop through all entities in the current scope to identify
+ -- an entity that depends on a private type.
+
+ Curr := First_Entity (Pkg);
+ loop
+ if Nkind (Curr) in N_Entity
+ and then Depends_On_Private (Curr)
+ then
+ return True;
+ end if;
+
+ exit when Last_Entity (Current_Scope) = Curr;
+ Curr := Next_Entity (Curr);
+ end loop;
+ end if;
+
+ return False;
+ end Uses_Unseen_Lib_Unit_Priv;
+
-- Local variables
Context : Node_Id := Empty;
-- care to attach the bodies at a proper place in the tree so as to
-- not cause unwanted freezing at that point.
- elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) then
+ -- It is also necessary to check for a case where both an expression
+ -- function is used and the current scope depends on an unseen
+ -- private type from a library unit, otherwise premature freezing of
+ -- the private type will occur.
+ elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl)
+ and then ((Nkind (Next_Decl) /= N_Subprogram_Body
+ or else not Was_Expression_Function (Next_Decl))
+ or else not Uses_Unseen_Lib_Unit_Priv (Current_Scope))
+ then
-- When a controlled type is frozen, the expander generates stream
- -- and controlled type support routines. If the freeze is caused
- -- by the stand alone body of Initialize, Adjust and Finalize, the
- -- expander will end up using the wrong version of these routines
+ -- and controlled-type support routines. If the freeze is caused
+ -- by the stand-alone body of Initialize, Adjust, or Finalize, the
+ -- expander will end up using the wrong version of these routines,
-- as the body has not been processed yet. To remedy this, detect
-- a late controlled primitive and create a proper spec for it.
-- This ensures that the primitive will override its inherited
-- The spec of the late primitive is not generated in ASIS mode to
-- ensure a consistent list of primitives that indicates the true
-- semantic structure of the program (which is not relevant when
- -- generating executable code.
+ -- generating executable code).
- -- ??? a cleaner approach may be possible and/or this solution
+ -- ??? A cleaner approach may be possible and/or this solution
-- could be extended to general-purpose late primitives, TBD.
- if not ASIS_Mode and then not Body_Seen and then not Is_Body (Decl)
+ if not ASIS_Mode
+ and then not Body_Seen
+ and then not Is_Body (Decl)
then
Body_Seen := True;
-- The generated body of an expression function does not freeze,
-- unless it is a completion, in which case only the expression
- -- itself freezes. THis is handled when the body itself is
+ -- itself freezes. This is handled when the body itself is
-- analyzed (see Freeze_Expr_Types, sem_ch6.adb).
Freeze_All (Freeze_From, Decl);
----------------------------------
procedure Check_Nonoverridable_Aspects is
- Prev_Aspects : constant List_Id :=
- Aspect_Specifications (Parent (Def_Id));
- Par_Type : Entity_Id;
-
- function Has_Aspect_Spec
- (Specs : List_Id;
- Aspect_Name : Name_Id) return Boolean;
+ function Get_Aspect_Spec
+ (Specs : List_Id;
+ Aspect_Name : Name_Id) return Node_Id;
-- Check whether a list of aspect specifications includes an entry
-- for a specific aspect. The list is either that of a partial or
-- a full view.
---------------------
- -- Has_Aspect_Spec --
+ -- Get_Aspect_Spec --
---------------------
- function Has_Aspect_Spec
- (Specs : List_Id;
- Aspect_Name : Name_Id) return Boolean
+ function Get_Aspect_Spec
+ (Specs : List_Id;
+ Aspect_Name : Name_Id) return Node_Id
is
Spec : Node_Id;
+
begin
Spec := First (Specs);
while Present (Spec) loop
if Chars (Identifier (Spec)) = Aspect_Name then
- return True;
+ return Spec;
end if;
Next (Spec);
end loop;
- return False;
- end Has_Aspect_Spec;
+
+ return Empty;
+ end Get_Aspect_Spec;
+
+ -- Local variables
+
+ Prev_Aspects : constant List_Id :=
+ Aspect_Specifications (Parent (Def_Id));
+ Par_Type : Entity_Id;
+ Prev_Aspect : Node_Id;
-- Start of processing for Check_Nonoverridable_Aspects
begin
-
- -- Get parent type of derived type. Note that Prev is the entity
- -- in the partial declaration, but its contents are now those of
- -- full view, while Def_Id reflects the partial view.
+ -- Get parent type of derived type. Note that Prev is the entity in
+ -- the partial declaration, but its contents are now those of full
+ -- view, while Def_Id reflects the partial view.
if Is_Private_Type (Def_Id) then
Par_Type := Etype (Full_View (Def_Id));
and then Present (Discriminant_Specifications (Parent (Prev)))
and then Present (Get_Reference_Discriminant (Par_Type))
then
- if
- not Has_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference)
+ Prev_Aspect :=
+ Get_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference);
+
+ if No (Prev_Aspect)
+ and then Present
+ (Discriminant_Specifications
+ (Original_Node (Parent (Prev))))
then
Error_Msg_N
("type does not inherit implicit dereference", Prev);
-- is consistent with that of the parent.
declare
- Par_Discr : constant Entity_Id :=
+ Par_Discr : constant Entity_Id :=
Get_Reference_Discriminant (Par_Type);
- Cur_Discr : constant Entity_Id :=
+ Cur_Discr : constant Entity_Id :=
Get_Reference_Discriminant (Prev);
+
begin
if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then
Error_Msg_N ("aspect incosistent with that of parent", N);
end if;
+
+ -- Check that specification in partial view matches the
+ -- inherited aspect. Compare names directly because aspect
+ -- expression may not be analyzed.
+
+ if Present (Prev_Aspect)
+ and then Nkind (Expression (Prev_Aspect)) = N_Identifier
+ and then Chars (Expression (Prev_Aspect)) /=
+ Chars (Cur_Discr)
+ then
+ Error_Msg_N
+ ("aspect incosistent with that of parent", N);
+ end if;
end;
end if;
end if;
when N_Derived_Type_Definition =>
Derived_Type_Declaration (T, N, T /= Def_Id);
+ -- Inherit predicates from parent, and protect against illegal
+ -- derivations.
+
+ if Is_Type (T) and then Has_Predicates (T) then
+ Set_Has_Predicates (Def_Id);
+ end if;
+
when N_Enumeration_Type_Definition =>
Enumeration_Type_Declaration (T, Def);
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)))
+ and then In_Predefined_Unit (N)
then
Set_Is_Descendant_Of_Address (Def_Id);
Set_Is_Descendant_Of_Address (Base_Type (Def_Id));
T : Entity_Id;
E : Node_Id := Expression (N);
- -- E is set to Expression (N) throughout this routine. When
- -- Expression (N) is modified, E is changed accordingly.
+ -- E is set to Expression (N) throughout this routine. When Expression
+ -- (N) is modified, E is changed accordingly.
Prev_Entity : Entity_Id := Empty;
+ procedure Check_Dynamic_Object (Typ : Entity_Id);
+ -- A library-level object with non-static discriminant constraints may
+ -- require dynamic allocation. The declaration is illegal if the
+ -- profile includes the restriction No_Implicit_Heap_Allocations.
+
+ procedure Check_For_Null_Excluding_Components
+ (Obj_Typ : Entity_Id;
+ Obj_Decl : Node_Id);
+ -- Verify that each null-excluding component of object declaration
+ -- Obj_Decl carrying type Obj_Typ has explicit initialization. Emit
+ -- a compile-time warning if this is not the case.
+
function Count_Tasks (T : Entity_Id) return Uint;
-- This function is called when a non-generic library level object of a
-- task type is declared. Its function is to count the static number of
-- Any other relevant delayed aspects on object declarations ???
+ --------------------------
+ -- Check_Dynamic_Object --
+ --------------------------
+
+ procedure Check_Dynamic_Object (Typ : Entity_Id) is
+ Comp : Entity_Id;
+ Obj_Type : Entity_Id;
+
+ begin
+ Obj_Type := Typ;
+
+ if Is_Private_Type (Obj_Type)
+ and then Present (Full_View (Obj_Type))
+ then
+ Obj_Type := Full_View (Obj_Type);
+ end if;
+
+ if Known_Static_Esize (Obj_Type) then
+ return;
+ end if;
+
+ if Restriction_Active (No_Implicit_Heap_Allocations)
+ and then Expander_Active
+ and then Has_Discriminants (Obj_Type)
+ then
+ Comp := First_Component (Obj_Type);
+ while Present (Comp) loop
+ if Known_Static_Esize (Etype (Comp))
+ or else Size_Known_At_Compile_Time (Etype (Comp))
+ then
+ null;
+
+ elsif not Discriminated_Size (Comp)
+ and then Comes_From_Source (Comp)
+ then
+ Error_Msg_NE
+ ("component& of non-static size will violate restriction "
+ & "No_Implicit_Heap_Allocation?", N, Comp);
+
+ elsif Is_Record_Type (Etype (Comp)) then
+ Check_Dynamic_Object (Etype (Comp));
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ end if;
+ end Check_Dynamic_Object;
+
+ -----------------------------------------
+ -- Check_For_Null_Excluding_Components --
+ -----------------------------------------
+
+ procedure Check_For_Null_Excluding_Components
+ (Obj_Typ : Entity_Id;
+ Obj_Decl : Node_Id)
+ is
+ procedure Check_Component
+ (Comp_Typ : Entity_Id;
+ Comp_Decl : Node_Id := Empty;
+ Array_Comp : Boolean := False);
+ -- Apply a compile-time null-exclusion check on a component denoted
+ -- by its declaration Comp_Decl and type Comp_Typ, and all of its
+ -- subcomponents (if any).
+
+ ---------------------
+ -- Check_Component --
+ ---------------------
+
+ procedure Check_Component
+ (Comp_Typ : Entity_Id;
+ Comp_Decl : Node_Id := Empty;
+ Array_Comp : Boolean := False)
+ is
+ Comp : Entity_Id;
+ T : Entity_Id;
+
+ begin
+ -- Do not consider internally-generated components or those that
+ -- are already initialized.
+
+ if Present (Comp_Decl)
+ and then (not Comes_From_Source (Comp_Decl)
+ or else Present (Expression (Comp_Decl)))
+ then
+ return;
+ end if;
+
+ if Is_Incomplete_Or_Private_Type (Comp_Typ)
+ and then Present (Full_View (Comp_Typ))
+ then
+ T := Full_View (Comp_Typ);
+ else
+ T := Comp_Typ;
+ end if;
+
+ -- Verify a component of a null-excluding access type
+
+ if Is_Access_Type (T)
+ and then Can_Never_Be_Null (T)
+ then
+ if Comp_Decl = Obj_Decl then
+ Null_Exclusion_Static_Checks
+ (N => Obj_Decl,
+ Comp => Empty,
+ Array_Comp => Array_Comp);
+
+ else
+ Null_Exclusion_Static_Checks
+ (N => Obj_Decl,
+ Comp => Comp_Decl,
+ Array_Comp => Array_Comp);
+ end if;
+
+ -- Check array components
+
+ elsif Is_Array_Type (T) then
+
+ -- There is no suitable component when the object is of an
+ -- array type. However, a namable component may appear at some
+ -- point during the recursive inspection, but not at the top
+ -- level. At the top level just indicate array component case.
+
+ if Comp_Decl = Obj_Decl then
+ Check_Component (Component_Type (T), Array_Comp => True);
+ else
+ Check_Component (Component_Type (T), Comp_Decl);
+ end if;
+
+ -- Verify all components of type T
+
+ -- Note: No checks are performed on types with discriminants due
+ -- to complexities involving variants. ???
+
+ elsif (Is_Concurrent_Type (T)
+ or else Is_Incomplete_Or_Private_Type (T)
+ or else Is_Record_Type (T))
+ and then not Has_Discriminants (T)
+ then
+ Comp := First_Component (T);
+ while Present (Comp) loop
+ Check_Component (Etype (Comp), Parent (Comp));
+
+ Comp := Next_Component (Comp);
+ end loop;
+ end if;
+ end Check_Component;
+
+ -- Start processing for Check_For_Null_Excluding_Components
+
+ begin
+ Check_Component (Obj_Typ, Obj_Decl);
+ end Check_For_Null_Excluding_Components;
+
-----------------
-- Count_Tasks --
-----------------
-- Local variables
- Mode : Ghost_Mode_Type;
- Mode_Set : Boolean := False;
+ Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ -- Save the Ghost mode to restore on exit
+
Related_Id : Entity_Id;
-- Start of processing for Analyze_Object_Declaration
-- The object declaration is Ghost when it completes a deferred Ghost
-- constant.
- Mark_And_Set_Ghost_Completion (N, Prev_Entity, Mode);
- Mode_Set := True;
+ Mark_And_Set_Ghost_Completion (N, Prev_Entity);
Constant_Redeclaration (Id, N, T);
-- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
-- out some static checks.
- if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then
+ if Ada_Version >= Ada_2005 then
-- In case of aggregates we must also take care of the correct
-- initialization of nested aggregates bug this is done at the
-- point of the analysis of the aggregate (see sem_aggr.adb) ???
- if Present (Expression (N))
- and then Nkind (Expression (N)) = N_Aggregate
- then
- null;
+ if Can_Never_Be_Null (T) then
+ if Present (Expression (N))
+ and then Nkind (Expression (N)) = N_Aggregate
+ then
+ null;
+
+ else
+ declare
+ Save_Typ : constant Entity_Id := Etype (Id);
+ begin
+ Set_Etype (Id, T); -- Temp. decoration for static checks
+ Null_Exclusion_Static_Checks (N);
+ Set_Etype (Id, Save_Typ);
+ end;
+ end if;
+
+ -- We might be dealing with an object of a composite type containing
+ -- null-excluding components without an aggregate, so we must verify
+ -- that such components have default initialization.
else
- declare
- Save_Typ : constant Entity_Id := Etype (Id);
- begin
- Set_Etype (Id, T); -- Temp. decoration for static checks
- Null_Exclusion_Static_Checks (N);
- Set_Etype (Id, Save_Typ);
- end;
+ Check_For_Null_Excluding_Components (T, N);
end if;
end if;
Object_Definition (N));
end if;
+ if Is_Library_Level_Entity (Id) then
+ Check_Dynamic_Object (T);
+ end if;
+
-- There are no aliased objects in SPARK
if Aliased_Present (N) then
if No (E) and then Is_Null_Record_Type (T) then
null;
+ -- Do not generate a predicate check if the initialization expression
+ -- is a type conversion because the conversion has been subjected to
+ -- the same check. This is a small optimization which avoid redundant
+ -- checks.
+
+ elsif Present (E) and then Nkind (E) = N_Type_Conversion then
+ null;
+
else
Insert_After (N,
Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
Check_No_Hidden_State (Id);
end if;
- if Mode_Set then
- Restore_Ghost_Mode (Mode);
- end if;
+ Restore_Ghost_Mode (Saved_GM);
end Analyze_Object_Declaration;
---------------------------
Set_Ekind (T, E_Record_Type_With_Private);
Init_Size_Align (T);
Set_Default_SSO (T);
+ Set_No_Reordering (T, No_Component_Reordering);
Set_Etype (T, Parent_Base);
Propagate_Concurrent_Flags (T, Parent_Base);
end if;
end if;
+ -- Remember that its parent type has a private extension. Used to warn
+ -- on public primitives of the parent type defined after its private
+ -- extensions (see Check_Dispatching_Operation).
+
+ Set_Has_Private_Extension (Parent_Type);
+
<<Leave>>
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, T);
Conditional_Delay (Id, T);
end if;
+ -- If we have a subtype of an incomplete type whose full type is a
+ -- derived numeric type, we need to have a freeze node for the subtype.
+ -- Otherwise gigi will complain while computing the (static) bounds of
+ -- the subtype.
+
+ if Is_Itype (T)
+ and then Is_Elementary_Type (Id)
+ and then Etype (Id) /= Id
+ then
+ declare
+ Partial : constant Entity_Id :=
+ Incomplete_Or_Partial_View (First_Subtype (Id));
+ begin
+ if Present (Partial)
+ and then Ekind (Partial) = E_Incomplete_Type
+ then
+ Set_Has_Delayed_Freeze (Id);
+ end if;
+ end;
+ end if;
+
-- Check that Constraint_Error is raised for a scalar subtype indication
-- when the lower or upper bound of a non-null range lies outside the
-- range of the type mark.
Analyze (Decl);
Set_Etype (Index, New_E);
- -- If the index is a range the Entity attribute is not
- -- available. Example:
+ -- If the index is a range or a subtype indication it carries
+ -- no entity. Example:
-- package Pkg is
-- type T is private;
-- Table : array (T(1) .. T(10)) of Boolean;
-- end Pkg;
- if Nkind (Index) /= N_Range then
+ -- Otherwise the type of the reference is its entity.
+
+ if Is_Entity_Name (Index) then
Set_Entity (Index, New_E);
end if;
end;
Set_Ekind (Full_Der, E_Record_Type);
Set_Is_Underlying_Record_View (Full_Der);
Set_Default_SSO (Full_Der);
+ Set_No_Reordering (Full_Der, No_Component_Reordering);
Analyze (Decl);
Set_Last_Entity (Der_Base, Last_Discr);
Set_First_Entity (Derived_Type, First_Entity (Der_Base));
Set_Last_Entity (Derived_Type, Last_Entity (Der_Base));
-
- Set_Stored_Constraint
- (Full_Der, Stored_Constraint (Derived_Type));
end;
end if;
-- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES
-- We have spoken about stored discriminants in point 1 (introduction)
- -- above. There are two sort of stored discriminants: implicit and
+ -- above. There are two sorts of stored discriminants: implicit and
-- explicit. As long as the derived type inherits the same discriminants as
-- the root record type, stored discriminants are the same as regular
-- discriminants, and are said to be implicit. However, if any discriminant
-- type T4 (Y : Int) is new T3 (Y, 99);
-- The following table summarizes the discriminants and stored
- -- discriminants in R and T1 through T4.
+ -- discriminants in R and T1 through T4:
-- Type Discrim Stored Discrim Comment
-- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R
-- Field Corresponding_Discriminant (abbreviated CD below) allows us to
-- find the corresponding discriminant in the parent type, while
- -- Original_Record_Component (abbreviated ORC below), the actual physical
+ -- Original_Record_Component (abbreviated ORC below) the actual physical
-- component that is renamed. Finally the field Is_Completely_Hidden
-- (abbreviated ICH below) is set for all explicit stored discriminants
-- (see einfo.ads for more info). For the above example this gives:
-- D2 in T3 empty itself yes
-- D3 in T3 empty itself yes
- -- Y in T4 X1 in T3 D3 in T3 no
- -- D1 in T3 empty itself yes
- -- D2 in T3 empty itself yes
- -- D3 in T3 empty itself yes
+ -- Y in T4 X1 in T3 D3 in T4 no
+ -- D1 in T4 empty itself yes
+ -- D2 in T4 empty itself yes
+ -- D3 in T4 empty itself yes
-- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES
Type_Def := N;
Set_Ekind (Derived_Type, E_Record_Type_With_Private);
Set_Default_SSO (Derived_Type);
+ Set_No_Reordering (Derived_Type, No_Component_Reordering);
else
Type_Def := Type_Definition (N);
if Present (Record_Extension_Part (Type_Def)) then
Set_Ekind (Derived_Type, E_Record_Type);
Set_Default_SSO (Derived_Type);
+ Set_No_Reordering (Derived_Type, No_Component_Reordering);
-- Create internal access types for components with anonymous
-- access types.
-- However, if the record contains an array constrained by
-- the discriminant but with some different bound, the compiler
- -- attemps to create a smaller range for the discriminant type.
+ -- tries to create a smaller range for the discriminant type.
-- (See exp_ch3.Adjust_Discriminants). In this case, where
-- the discriminant type is a scalar type, the check must use
-- the original discriminant type in the parent declaration.
Set_Has_Primitive_Operations
(Derived_Type, Has_Primitive_Operations (Parent_Base));
- -- Fields inherited from the Parent_Base in the non-private case
+ -- Set fields for private derived types
- if Ekind (Derived_Type) = E_Record_Type then
- Set_Has_Complex_Representation
- (Derived_Type, Has_Complex_Representation (Parent_Base));
+ if Is_Private_Type (Derived_Type) then
+ Set_Depends_On_Private (Derived_Type, True);
+ Set_Private_Dependents (Derived_Type, New_Elmt_List);
end if;
- -- Fields inherited from the Parent_Base for record types
+ -- Inherit fields for non-private types. If this is the completion of a
+ -- derivation from a private type, the parent itself is private and the
+ -- attributes come from its full view, which must be present.
if Is_Record_Type (Derived_Type) then
declare
Parent_Full : Entity_Id;
begin
- -- Ekind (Parent_Base) is not necessarily E_Record_Type since
- -- Parent_Base can be a private type or private extension. Go
- -- to the full view here to get the E_Record_Type specific flags.
-
- if Present (Full_View (Parent_Base)) then
+ if Is_Private_Type (Parent_Base)
+ and then not Is_Record_Type (Parent_Base)
+ then
Parent_Full := Full_View (Parent_Base);
else
Parent_Full := Parent_Base;
end if;
- Set_OK_To_Reorder_Components
- (Derived_Type, OK_To_Reorder_Components (Parent_Full));
- end;
- end if;
-
- -- Set fields for private derived types
-
- if Is_Private_Type (Derived_Type) then
- Set_Depends_On_Private (Derived_Type, True);
- Set_Private_Dependents (Derived_Type, New_Elmt_List);
-
- -- Inherit fields from non private record types. If this is the
- -- completion of a derivation from a private type, the parent itself
- -- is private, and the attributes come from its full view, which must
- -- be present.
-
- else
- if Is_Private_Type (Parent_Base)
- and then not Is_Record_Type (Parent_Base)
- then
- Set_Component_Alignment
- (Derived_Type, Component_Alignment (Full_View (Parent_Base)));
- Set_C_Pass_By_Copy
- (Derived_Type, C_Pass_By_Copy (Full_View (Parent_Base)));
- else
Set_Component_Alignment
- (Derived_Type, Component_Alignment (Parent_Base));
+ (Derived_Type, Component_Alignment (Parent_Full));
Set_C_Pass_By_Copy
- (Derived_Type, C_Pass_By_Copy (Parent_Base));
- end if;
+ (Derived_Type, C_Pass_By_Copy (Parent_Full));
+ Set_Has_Complex_Representation
+ (Derived_Type, Has_Complex_Representation (Parent_Full));
+
+ -- For untagged types, inherit the layout by default to avoid
+ -- costly changes of representation for type conversions.
+
+ if not Is_Tagged then
+ Set_Is_Packed (Derived_Type, Is_Packed (Parent_Full));
+ Set_No_Reordering (Derived_Type, No_Reordering (Parent_Full));
+ end if;
+ end;
end if;
-- Set fields for tagged types
end if;
end;
end if;
-
- else
- Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base));
- Set_Has_Non_Standard_Rep
- (Derived_Type, Has_Non_Standard_Rep (Parent_Base));
end if;
-- STEP 4: Inherit components from the parent base and constrain them.
-- STEP 5a: Copy the parent record declaration for untagged types
+ Set_Has_Implicit_Dereference
+ (Derived_Type, Has_Implicit_Dereference (Parent_Type));
+
if not Is_Tagged then
-- Discriminant_Constraint (Derived_Type) has been properly
Set_Stored_Constraint
(Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
Replace_Components (Derived_Type, New_Decl);
- Set_Has_Implicit_Dereference
- (Derived_Type, Has_Implicit_Dereference (Parent_Type));
end if;
-- Insert the new derived type declaration
-- If any of the discriminant constraints is given by a
-- discriminant and we are in a derived type declaration we
-- have a discriminant renaming. Establish link between new
- -- and old discriminant.
+ -- and old discriminant. The new discriminant has an implicit
+ -- dereference if the old one does.
if Denotes_Discriminant (Discr_Expr (J)) then
if Derived_Def then
- Set_Corresponding_Discriminant
- (Entity (Discr_Expr (J)), Discr);
+ declare
+ New_Discr : constant Entity_Id := Entity (Discr_Expr (J));
+
+ begin
+ Set_Corresponding_Discriminant (New_Discr, Discr);
+ Set_Has_Implicit_Dereference (New_Discr,
+ Has_Implicit_Dereference (Discr));
+ end;
end if;
-- Force the evaluation of non-discriminant expressions.
null;
elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration
- and then
- Has_Per_Object_Constraint
- (Defining_Identifier (Parent (Parent (Def))))
+ and then Has_Per_Object_Constraint
+ (Defining_Identifier (Parent (Parent (Def))))
then
null;
if Ekind (Etype (Discr)) = E_Anonymous_Access_Type
and then not Is_Class_Wide_Type
- (Designated_Type (Etype (Discr)))
+ (Designated_Type (Etype (Discr)))
and then Etype (Discr_Expr (J)) /= Any_Type
and then Is_Class_Wide_Type
(Designated_Type (Etype (Discr_Expr (J))))
then
Error_Msg_NE
("constraint for discriminant& must be access to variable",
- Def, Discr);
+ Def, Discr);
end if;
end if;
-- elaboration, because only the access type is needed in the
-- initialization procedure.
- Set_Ekind (Def_Id, Ekind (T));
+ if Ekind (T) = E_Incomplete_Type then
+ Set_Ekind (Def_Id, E_Incomplete_Subtype);
+ else
+ Set_Ekind (Def_Id, Ekind (T));
+ end if;
if For_Access and then Within_Init_Proc then
null;
Set_Last_Entity (Def_Id, Last_Entity (T));
Set_Has_Implicit_Dereference
(Def_Id, Has_Implicit_Dereference (T));
+ Set_Has_Pragma_Unreferenced_Objects
+ (Def_Id, Has_Pragma_Unreferenced_Objects (T));
-- If the subtype is the completion of a private declaration, there may
-- have been representation clauses for the partial view, and they must
-- already frozen. We skip this processing if the type is an anonymous
-- subtype of a record component, or is the corresponding record of a
-- protected type, since these are processed when the enclosing type
- -- is frozen.
+ -- is frozen. If the parent type is declared in a nested package then
+ -- the freezing of the private and full views also happens later.
if not Is_Type (Scope (Full)) then
- Set_Has_Delayed_Freeze (Full,
- Has_Delayed_Freeze (Full_Base)
- and then (not Is_Frozen (Full_Base)));
+ if Is_Itype (Priv)
+ and then In_Same_Source_Unit (Full, Full_Base)
+ and then Scope (Full_Base) /= Scope (Full)
+ then
+ Set_Has_Delayed_Freeze (Full);
+ Set_Has_Delayed_Freeze (Priv);
+
+ else
+ Set_Has_Delayed_Freeze (Full,
+ Has_Delayed_Freeze (Full_Base)
+ and then not Is_Frozen (Full_Base));
+ end if;
end if;
Set_Freeze_Node (Full, Empty);
procedure Fixup_Bad_Constraint is
begin
- -- Set a reasonable Ekind for the entity. For an incomplete type,
- -- we can't do much, but for other types, we can set the proper
- -- corresponding subtype kind.
+ -- Set a reasonable Ekind for the entity, including incomplete types.
- if Ekind (T) = E_Incomplete_Type then
- Set_Ekind (Def_Id, Ekind (T));
- else
- Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
- end if;
+ Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
-- Set Etype to the known type, to reduce chances of cascaded errors
elsif Ada_Version >= Ada_2005
and then Is_Dispatching_Operation (Parent_Subp)
- and then Covers_Some_Interface (Parent_Subp)
+ and then Present (Covered_Interface_Op (Parent_Subp))
then
Set_Derived_Name;
New_Overloaded_Entity (New_Subp, Derived_Type);
+ -- Ada RM 6.1.1 (15): If a subprogram inherits nonconforming class-wide
+ -- preconditions and the derived type is abstract, the derived operation
+ -- is abstract as well if parent subprogram is not abstract or null.
+
+ if Is_Abstract_Type (Derived_Type)
+ and then Has_Non_Trivial_Precondition (Parent_Subp)
+ and then Present (Interfaces (Derived_Type))
+ then
+
+ -- Add useful attributes of subprogram before the freeze point,
+ -- in case freezing is delayed or there are previous errors.
+
+ Set_Is_Dispatching_Operation (New_Subp);
+
+ declare
+ Iface_Prim : constant Entity_Id := Covered_Interface_Op (New_Subp);
+
+ begin
+ if Present (Iface_Prim)
+ and then Has_Non_Trivial_Precondition (Iface_Prim)
+ then
+ Set_Is_Abstract_Subprogram (New_Subp);
+ end if;
+ end;
+ end if;
+
-- Check for case of a derived subprogram for the instantiation of a
-- formal derived tagged type, if so mark the subprogram as dispatching
-- and inherit the dispatching attributes of the actual subprogram. The
begin
Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
+ if SPARK_Mode = On
+ and then Is_Tagged_Type (Parent_Type)
+ then
+ declare
+ Partial_View : constant Entity_Id :=
+ Incomplete_Or_Partial_View (Parent_Type);
+
+ begin
+ -- If the partial view was not found then the parent type is not
+ -- a private type. Otherwise check if the partial view is a tagged
+ -- private type.
+
+ if Present (Partial_View)
+ and then Is_Private_Type (Partial_View)
+ and then not Is_Tagged_Type (Partial_View)
+ then
+ Error_Msg_NE
+ ("cannot derive from & declared as untagged private "
+ & "(SPARK RM 3.4(1))", N, Partial_View);
+ end if;
+ end;
+ end if;
+
-- Ada 2005 (AI-251): In case of interface derivation check that the
-- parent is also an interface.
begin
-- Look for the associated private type declaration
- Partial_View := First_Entity (Current_Scope);
- loop
- exit when No (Partial_View)
- or else (Has_Private_Declaration (Partial_View)
- and then Full_View (Partial_View) = T);
-
- Next_Entity (Partial_View);
- end loop;
+ Partial_View := Incomplete_Or_Partial_View (T);
-- If the partial view was not found then the source code has
-- errors and the transformation is not needed.
end if;
while Present (Disc) loop
- pragma Assert (Present (Assoc));
+
+ -- If no further associations return the discriminant, value will
+ -- be found on the second pass.
+
+ if No (Assoc) then
+ return Result;
+ end if;
if Original_Record_Component (Disc) = Result_Entity then
return Node (Assoc);
-- ??? This routine is a gigantic mess and will be deleted. For the
-- time being just test for the trivial case before calling recurse.
+ -- We are now celebrating the 20th anniversary of this comment!
+
if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
declare
D : Entity_Id;
if not Is_Tagged then
Set_Original_Record_Component (New_C, New_C);
+ Set_Corresponding_Record_Component (New_C, Old_C);
end if;
-- Set the proper type of an access discriminant
and then Original_Record_Component (Corr_Discrim) = Old_C
then
Set_Original_Record_Component (Discrim, New_C);
+ Set_Corresponding_Record_Component (Discrim, Empty);
end if;
Next_Discriminant (Discrim);
when N_Attribute_Reference =>
return Attribute_Name (Original_Node (Exp)) = Name_Input;
+ -- "return raise ..." is OK
+
+ when N_Raise_Expression =>
+ return True;
+
-- For a case expression, all dependent expressions must be legal
when N_Case_Expression =>
-- Local variables
+ Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+
Full_Indic : Node_Id;
Full_Parent : Entity_Id;
- Mode : Ghost_Mode_Type;
Priv_Parent : Entity_Id;
-- Start of processing for Process_Full_View
begin
- Mark_And_Set_Ghost_Completion (N, Priv_T, Mode);
+ Mark_And_Set_Ghost_Completion (N, Priv_T);
-- First some sanity checks that must be done after semantic
-- decoration of the full view and thus cannot be placed with other
end if;
<<Leave>>
- Restore_Ghost_Mode (Mode);
+ Restore_Ghost_Mode (Saved_GM);
end Process_Full_View;
-----------------------------------
-- Ada 2005 (AI-412): Transform a regular incomplete subtype into a
-- corresponding subtype of the full view.
- elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then
+ elsif Ekind (Priv_Dep) = E_Incomplete_Subtype
+ and then Comes_From_Source (Priv_Dep)
+ then
Set_Subtype_Indication
(Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep)));
Set_Etype (Priv_Dep, Full_T);
Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T)));
Set_Analyzed (Parent (Priv_Dep), False);
- -- Reanalyze the declaration, suppressing the call to
- -- Enter_Name to avoid duplicate names.
+ -- Reanalyze the declaration, suppressing the call to Enter_Name
+ -- to avoid duplicate names.
Analyze_Subtype_Declaration
(N => Parent (Priv_Dep),
Set_Interfaces (T, No_Elist);
Set_Stored_Constraint (T, No_Elist);
Set_Default_SSO (T);
+ Set_No_Reordering (T, No_Component_Reordering);
-- Normal case
projects / gcc.git / blobdiff