-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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 Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Debug; use Debug;
-with Elists; use Elists;
-with Einfo; use Einfo;
-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 Exp_Util; use Exp_Util;
-with Fname; use Fname;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with Itypes; use Itypes;
-with Layout; use Layout;
-with Lib; use Lib;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Restrict; use Restrict;
-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;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch10; use Sem_Ch10;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Dim; use Sem_Dim;
-with Sem_Disp; use Sem_Disp;
-with Sem_Dist; use Sem_Dist;
-with Sem_Elim; use Sem_Elim;
-with Sem_Eval; use Sem_Eval;
-with Sem_Mech; use Sem_Mech;
-with Sem_Prag; use Sem_Prag;
-with Sem_Res; use Sem_Res;
-with Sem_Smem; use Sem_Smem;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Elists; use Elists;
+with Einfo; use Einfo;
+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;
+with Layout; use Layout;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Restrict; use Restrict;
+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;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
+with Sem_Res; use Sem_Res;
+with Sem_Smem; use Sem_Smem;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
package body Sem_Ch3 is
-- abstract interface types implemented by a record type or a derived
-- record type.
- procedure Analyze_Object_Contract (Obj_Id : Entity_Id);
- -- Analyze all delayed pragmas chained on the contract of object Obj_Id as
- -- if they appeared at the end of the declarative region. The pragmas to be
- -- considered are:
- -- Async_Readers
- -- Async_Writers
- -- Effective_Reads
- -- Effective_Writes
- -- Part_Of
-
procedure Build_Derived_Type
(N : Node_Id;
Parent_Type : Entity_Id;
-- present. If errors are found, error messages are posted, and the
-- Real_Range_Specification of Def is reset to Empty.
- procedure Propagate_Default_Init_Cond_Attributes
- (From_Typ : Entity_Id;
- To_Typ : Entity_Id;
- Parent_To_Derivation : Boolean := False;
- Private_To_Full_View : Boolean := False);
- -- Subsidiary to routines Build_Derived_Type and Process_Full_View. Inherit
- -- all attributes related to pragma Default_Initial_Condition from From_Typ
- -- to To_Typ. Flag Parent_To_Derivation should be set when the context is
- -- the creation of a derived type. Flag Private_To_Full_View should be set
- -- when processing both views of a private type.
-
procedure Record_Type_Declaration
(T : Entity_Id;
N : Node_Id;
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
elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T
then
Error_Msg_N
- ("access type cannot designate its own classwide type", S);
+ ("access type cannot designate its own class-wide type", S);
-- Clean up indication of tagged status to prevent cascaded errors
-- and to Has_Protected.
Set_Has_Task (T, False);
- Set_Has_Controlled_Component (T, False);
Set_Has_Protected (T, False);
+ Set_Has_Timing_Event (T, False);
+ Set_Has_Controlled_Component (T, False);
-- Initialize field Finalization_Master explicitly to Empty, to avoid
-- problems where an incomplete view of this entity has been previously
when others =>
return False;
-
end case;
end Contains_POC;
-- (They have the sloc of the label as found in the source, and that
-- is ahead of the current declarative part).
+ procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id);
+ -- Create the subprogram bodies which verify the run-time semantics of
+ -- the pragmas listed below for each elibigle type found in declarative
+ -- list Decls. The pragmas are:
+ --
+ -- Default_Initial_Condition
+ -- Invariant
+ -- Type_Invariant
+ --
+ -- Context denotes the owner of the declarative list.
+
+ procedure Check_Entry_Contracts;
+ -- Perform a pre-analysis of the pre- and postconditions of an entry
+ -- declaration. This must be done before full resolution and creation
+ -- of the parameter block, etc. to catch illegal uses within the
+ -- contract expression. Full analysis of the expression is done when
+ -- the contract is processed.
+
procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id);
-- Determine whether Body_Decl denotes the body of a late controlled
-- primitive (either Initialize, Adjust or Finalize). If this is the
-- case, add a proper spec if the body lacks one. The spec is inserted
- -- before Body_Decl and immedately analyzed.
+ -- before Body_Decl and immediately analyzed.
+
+ procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id);
+ -- Spec_Id is the entity of a package that may define abstract states,
+ -- and in the case of a child unit, whose ancestors may define abstract
+ -- states. If the states have partial visible refinement, remove the
+ -- partial visibility of each constituent at the end of the package
+ -- spec and body declarations.
procedure Remove_Visible_Refinements (Spec_Id : Entity_Id);
-- Spec_Id is the entity of a package that may define abstract states.
-- If the states have visible refinement, remove the visibility of each
- -- constituent at the end of the package body declarations.
+ -- constituent at the end of the package body declaration.
+
+ procedure Resolve_Aspects;
+ -- Utility to resolve the expressions of aspects at the end of a list of
+ -- declarations.
-----------------
-- Adjust_Decl --
end loop;
end Adjust_Decl;
+ ----------------------------
+ -- Build_Assertion_Bodies --
+ ----------------------------
+
+ procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id) is
+ procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id);
+ -- Create the subprogram bodies which verify the run-time semantics
+ -- of the pragmas listed below for type Typ. The pragmas are:
+ --
+ -- Default_Initial_Condition
+ -- Invariant
+ -- Type_Invariant
+
+ -------------------------------------
+ -- Build_Assertion_Bodies_For_Type --
+ -------------------------------------
+
+ procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id) is
+ begin
+ -- Preanalyze and resolve the Default_Initial_Condition assertion
+ -- expression at the end of the declarations to catch any errors.
+
+ if Has_DIC (Typ) then
+ Build_DIC_Procedure_Body (Typ);
+ end if;
+
+ if Nkind (Context) = N_Package_Specification then
+
+ -- 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)
+ and then Ekind_In (Typ, E_Limited_Private_Type,
+ E_Private_Type,
+ E_Record_Type_With_Private)
+ and then Has_Own_Invariants (Typ)
+ then
+ Build_Invariant_Procedure_Body
+ (Typ => Typ,
+ Partial_Invariant => True);
+
+ -- Preanalyze and resolve the invariants of a private type's
+ -- full view at the end of the private declarations to catch
+ -- potential errors.
+
+ elsif Decls = Private_Declarations (Context)
+ and then not Is_Private_Type (Typ)
+ and then Has_Private_Declaration (Typ)
+ and then Has_Invariants (Typ)
+ then
+ Build_Invariant_Procedure_Body (Typ);
+ end if;
+ end if;
+ end Build_Assertion_Bodies_For_Type;
+
+ -- Local variables
+
+ Decl : Node_Id;
+ Decl_Id : Entity_Id;
+
+ -- Start of processing for Build_Assertion_Bodies
+
+ begin
+ Decl := First (Decls);
+ while Present (Decl) loop
+ if Is_Declaration (Decl) then
+ Decl_Id := Defining_Entity (Decl);
+
+ if Is_Type (Decl_Id) then
+ Build_Assertion_Bodies_For_Type (Decl_Id);
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Build_Assertion_Bodies;
+
+ ---------------------------
+ -- Check_Entry_Contracts --
+ ---------------------------
+
+ procedure Check_Entry_Contracts is
+ ASN : Node_Id;
+ Ent : Entity_Id;
+ Exp : Node_Id;
+
+ begin
+ Ent := First_Entity (Current_Scope);
+ while Present (Ent) loop
+
+ -- This only concerns entries with pre/postconditions
+
+ if Ekind (Ent) = E_Entry
+ and then Present (Contract (Ent))
+ and then Present (Pre_Post_Conditions (Contract (Ent)))
+ then
+ ASN := Pre_Post_Conditions (Contract (Ent));
+ Push_Scope (Ent);
+ Install_Formals (Ent);
+
+ -- Pre/postconditions are rewritten as Check pragmas. Analysis
+ -- is performed on a copy of the pragma expression, to prevent
+ -- modifying the original expression.
+
+ while Present (ASN) loop
+ if Nkind (ASN) = N_Pragma then
+ Exp :=
+ New_Copy_Tree
+ (Expression
+ (First (Pragma_Argument_Associations (ASN))));
+ Set_Parent (Exp, ASN);
+
+ -- ??? why not Preanalyze_Assert_Expression
+
+ Preanalyze (Exp);
+ end if;
+
+ ASN := Next_Pragma (ASN);
+ end loop;
+
+ End_Scope;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end Check_Entry_Contracts;
+
--------------------------------------
-- Handle_Late_Controlled_Primitive --
--------------------------------------
Set_Null_Present (Spec, False);
- Insert_Before_And_Analyze (Body_Decl,
- Make_Subprogram_Declaration (Loc, Specification => Spec));
+ -- Ensure that the freeze node is inserted after the declaration of
+ -- the primitive since its expansion will freeze the primitive.
+
+ Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
+
+ Insert_Before_And_Analyze (Body_Decl, Decl);
end Handle_Late_Controlled_Primitive;
+ ----------------------------------------
+ -- Remove_Partial_Visible_Refinements --
+ ----------------------------------------
+
+ procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id) is
+ State_Elmt : Elmt_Id;
+ begin
+ if Present (Abstract_States (Spec_Id)) then
+ State_Elmt := First_Elmt (Abstract_States (Spec_Id));
+ while Present (State_Elmt) loop
+ Set_Has_Partial_Visible_Refinement (Node (State_Elmt), False);
+ Next_Elmt (State_Elmt);
+ end loop;
+ end if;
+
+ -- For a child unit, also hide the partial state refinement from
+ -- ancestor packages.
+
+ if Is_Child_Unit (Spec_Id) then
+ Remove_Partial_Visible_Refinements (Scope (Spec_Id));
+ end if;
+ end Remove_Partial_Visible_Refinements;
+
--------------------------------
-- Remove_Visible_Refinements --
--------------------------------
end if;
end Remove_Visible_Refinements;
+ ---------------------
+ -- Resolve_Aspects --
+ ---------------------
+
+ procedure Resolve_Aspects is
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Current_Scope);
+ while Present (E) loop
+ Resolve_Aspect_Expressions (E);
+ Next_Entity (E);
+ end loop;
+ end Resolve_Aspects;
+
-- Local variables
Context : Node_Id := Empty;
Freeze_From : Entity_Id := Empty;
Next_Decl : Node_Id;
- Pack_Decl : Node_Id := Empty;
Body_Seen : Boolean := False;
-- Flag set when the first body [stub] is encountered
+ Ignore_Freezing : Boolean;
+ -- Flag set when deciding to freeze an expression function in the
+ -- current scope.
+
-- Start of processing for Analyze_Declarations
begin
-- (This is needed in any case for early instantiations ???).
if No (Next_Decl) then
- if Nkind_In (Parent (L), N_Component_List,
- N_Task_Definition,
- N_Protected_Definition)
- then
+ if Nkind (Parent (L)) = N_Component_List then
null;
+ elsif Nkind_In (Parent (L), N_Protected_Definition,
+ N_Task_Definition)
+ then
+ Check_Entry_Contracts;
+
elsif Nkind (Parent (L)) /= N_Package_Specification then
if Nkind (Parent (L)) = N_Package_Body then
Freeze_From := First_Entity (Current_Scope);
Freeze_All (First_Entity (Current_Scope), Decl);
Freeze_From := Last_Entity (Current_Scope);
+ -- Current scope is a package specification
+
elsif Scope (Current_Scope) /= Standard_Standard
and then not Is_Child_Unit (Current_Scope)
and then No (Generic_Parent (Parent (L)))
then
- null;
+ -- This is needed in all cases to catch visibility errors in
+ -- aspect expressions, but several large user tests are now
+ -- rejected. Pending notification we restrict this call to
+ -- ASIS mode.
+
+ if False and then ASIS_Mode then -- ????
+ Resolve_Aspects;
+ end if;
elsif L /= Visible_Declarations (Parent (L))
- or else No (Private_Declarations (Parent (L)))
- or else Is_Empty_List (Private_Declarations (Parent (L)))
+ or else No (Private_Declarations (Parent (L)))
+ or else Is_Empty_List (Private_Declarations (Parent (L)))
then
Adjust_Decl;
+
+ -- End of a package declaration
+
+ -- In compilation mode the expansion of freeze node takes care
+ -- of resolving expressions of all aspects in the list. In ASIS
+ -- mode this must be done explicitly.
+
+ if ASIS_Mode
+ and then Scope (Current_Scope) = Standard_Standard
+ then
+ Resolve_Aspects;
+ end if;
+
+ -- This is a freeze point because it is the end of a
+ -- compilation unit.
+
Freeze_All (First_Entity (Current_Scope), Decl);
Freeze_From := Last_Entity (Current_Scope);
+
+ -- At the end of the visible declarations the expressions in
+ -- aspects of all entities declared so far must be resolved.
+ -- The entities themselves might be frozen later, and the
+ -- generated pragmas and attribute definition clauses analyzed
+ -- in full at that point, but name resolution must take place
+ -- now.
+ -- In addition to being the proper semantics, this is mandatory
+ -- within generic units, because global name capture requires
+ -- those expressions to be analyzed, given that the generated
+ -- pragmas do not appear in the original generic tree.
+
+ elsif Serious_Errors_Detected = 0 then
+ Resolve_Aspects;
end if;
-- If next node is a body then freeze all types before the body.
elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) 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
- -- 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
- -- counterpart before the freeze takes place.
+ -- Check for an edge case that may cause premature freezing of
+ -- a private type. If there is a type which depends on another
+ -- private type from an enclosing package that is in the same
+ -- scope as a non-completing expression function then we cannot
+ -- freeze here.
+
+ Ignore_Freezing := False;
- -- If the declaration we just processed is a body, do not attempt
- -- to examine Next_Decl as the late primitive idiom can only apply
- -- to the first encountered body.
+ if Nkind (Next_Decl) = N_Subprogram_Body
+ and then Was_Expression_Function (Next_Decl)
+ and then not Is_Compilation_Unit (Current_Scope)
+ and then not Is_Generic_Instance (Current_Scope)
+ then
+ -- Loop through all entities in the current scope to identify
+ -- an instance of the edge case outlined above and ignore
+ -- freezing if it is detected.
- -- 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.
+ declare
+ Curr : Entity_Id := First_Entity (Current_Scope);
+ begin
+ loop
+ if Nkind (Curr) in N_Entity
+ and then Depends_On_Private (Curr)
+ then
+ Ignore_Freezing := True;
+ exit;
+ end if;
- -- ??? a cleaner approach may be possible and/or this solution
- -- could be extended to general-purpose late primitives, TBD.
+ exit when Last_Entity (Current_Scope) = Curr;
+ Curr := Next_Entity (Curr);
+ end loop;
+ end;
+ end if;
- if not ASIS_Mode and then not Body_Seen and then not Is_Body (Decl)
- then
- Body_Seen := True;
+ if not Ignore_Freezing 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, 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 counterpart before the freeze
+ -- takes place.
+
+ -- If the declaration we just processed is a body, do not
+ -- attempt to examine Next_Decl as the late primitive idiom can
+ -- only apply to the first encountered body.
+
+ -- 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).
+
+ -- ??? 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)
+ then
+ Body_Seen := True;
- if Nkind (Next_Decl) = N_Subprogram_Body then
- Handle_Late_Controlled_Primitive (Next_Decl);
+ if Nkind (Next_Decl) = N_Subprogram_Body then
+ Handle_Late_Controlled_Primitive (Next_Decl);
+ end if;
end if;
- end if;
- Adjust_Decl;
- Freeze_All (Freeze_From, Decl);
- Freeze_From := Last_Entity (Current_Scope);
+ Adjust_Decl;
+
+ -- 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 analyzed (see Freeze_Expr_Types, sem_ch6.adb).
+
+ Freeze_All (Freeze_From, Decl);
+ Freeze_From := Last_Entity (Current_Scope);
+ end if;
end if;
Decl := Next_Decl;
end loop;
- -- Analyze the contracts of packages and their bodies
+ -- Post-freezing actions
if Present (L) then
Context := Parent (L);
+ -- Analyze the contracts of packages and their bodies
+
if Nkind (Context) = N_Package_Specification then
- Pack_Decl := Parent (Context);
-- When a package has private declarations, its contract must be
-- analyzed at the end of the said declarations. This way both the
if L = Private_Declarations (Context) then
Analyze_Package_Contract (Defining_Entity (Context));
- -- Build the bodies of the default initial condition procedures
- -- for all types subject to pragma Default_Initial_Condition.
- -- From a purely Ada stand point, this is a freezing activity,
- -- however freezing is not available under GNATprove_Mode. To
- -- accomodate both scenarios, the bodies are build at the end
- -- of private declaration analysis.
-
- Build_Default_Init_Cond_Procedure_Bodies (L);
-
-- Otherwise the contract is analyzed at the end of the visible
-- declarations.
end if;
elsif Nkind (Context) = N_Package_Body then
- Pack_Decl := Context;
Analyze_Package_Body_Contract (Defining_Entity (Context));
end if;
- -- Analyze the contracts of all subprogram declarations, subprogram
- -- bodies and variables now due to the delayed visibility needs of
- -- of their aspects and pragmas. Capture global references in generic
- -- subprograms or bodies.
+ -- Analyze the contracts of various constructs now due to the delayed
+ -- visibility needs of their aspects and pragmas.
- Decl := First (L);
- while Present (Decl) loop
- if Nkind (Decl) = N_Object_Declaration then
- Analyze_Object_Contract (Defining_Entity (Decl));
+ Analyze_Contracts (L);
- elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Subprogram_Declaration)
- then
- Analyze_Subprogram_Contract (Defining_Entity (Decl));
+ if Nkind (Context) = N_Package_Body then
- elsif Nkind (Decl) = N_Subprogram_Body then
- Analyze_Subprogram_Body_Contract (Defining_Entity (Decl));
+ -- Ensure that all abstract states and objects declared in the
+ -- state space of a package body are utilized as constituents.
- elsif Nkind (Decl) = N_Subprogram_Body_Stub then
- Analyze_Subprogram_Body_Stub_Contract (Defining_Entity (Decl));
- end if;
+ Check_Unused_Body_States (Defining_Entity (Context));
- -- Capture all global references in a generic subprogram or a body
- -- [stub] now that the contract has been analyzed.
+ -- State refinements are visible up to the end of the package body
+ -- declarations. Hide the state refinements from visibility to
+ -- restore the original state conditions.
- if Nkind_In (Decl, N_Generic_Subprogram_Declaration,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub)
- and then Is_Generic_Declaration_Or_Body (Decl)
- then
- Save_Global_References_In_Contract
- (Templ => Original_Node (Decl),
- Gen_Id => Corresponding_Spec_Of (Decl));
- end if;
+ Remove_Visible_Refinements (Corresponding_Spec (Context));
+ Remove_Partial_Visible_Refinements (Corresponding_Spec (Context));
- Next (Decl);
- end loop;
+ elsif Nkind (Context) = N_Package_Declaration then
- -- The owner of the declarations is a package [body]
+ -- Partial state refinements are visible up to the end of the
+ -- package spec declarations. Hide the partial state refinements
+ -- from visibility to restore the original state conditions.
- if Present (Pack_Decl) then
+ Remove_Partial_Visible_Refinements (Corresponding_Spec (Context));
+ end if;
- -- Capture all global references in a generic package or a body
- -- after all nested generic subprograms and bodies were subjected
- -- to the same processing.
+ -- Verify that all abstract states found in any package declared in
+ -- the input declarative list have proper refinements. The check is
+ -- performed only when the context denotes a block, entry, package,
+ -- protected, subprogram, or task body (SPARK RM 7.2.2(3)).
- if Is_Generic_Declaration_Or_Body (Pack_Decl) then
- Save_Global_References_In_Contract
- (Templ => Original_Node (Pack_Decl),
- Gen_Id => Corresponding_Spec_Of (Pack_Decl));
- end if;
+ Check_State_Refinements (Context);
- -- State refinements are visible upto the end the of the package
- -- body declarations. Hide the state refinements from visibility
- -- to restore the original state conditions.
+ -- Create the subprogram bodies which verify the run-time semantics
+ -- of pragmas Default_Initial_Condition and [Type_]Invariant for all
+ -- types within the current declarative list. This ensures that all
+ -- assertion expressions are preanalyzed and resolved at the end of
+ -- the declarative part. Note that the resolution happens even when
+ -- freezing does not take place.
- if Nkind (Pack_Decl) = N_Package_Body then
- Remove_Visible_Refinements (Corresponding_Spec (Pack_Decl));
- end if;
- end if;
+ Build_Assertion_Bodies (L, Context);
end if;
end Analyze_Declarations;
-----------------------------------
procedure Analyze_Full_Type_Declaration (N : Node_Id) is
- Def : constant Node_Id := Type_Definition (N);
- Def_Id : constant Entity_Id := Defining_Identifier (N);
- GM : constant Ghost_Mode_Type := Ghost_Mode;
+ Def : constant Node_Id := Type_Definition (N);
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
T : Entity_Id;
Prev : Entity_Id;
and then not (In_Private_Part (Current_Scope)
or else In_Package_Body (Current_Scope));
+ procedure Check_Nonoverridable_Aspects;
+ -- Apply the rule in RM 13.1.1(18.4/4) on iterator aspects that cannot
+ -- be overridden, and can only be confirmed on derivation.
+
procedure Check_Ops_From_Incomplete_Type;
-- If there is a tagged incomplete partial view of the type, traverse
-- the primitives of the incomplete view and change the type of any
-- list later in Sem_Disp.Check_Operation_From_Incomplete_Type (which
-- is called from Process_Incomplete_Dependents).
- procedure Restore_Globals;
- -- Restore the values of all saved global variables
+ ----------------------------------
+ -- Check_Nonoverridable_Aspects --
+ ----------------------------------
+
+ procedure Check_Nonoverridable_Aspects is
+ 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.
+
+ ---------------------
+ -- Get_Aspect_Spec --
+ ---------------------
+
+ 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 Spec;
+ end if;
+ Next (Spec);
+ end loop;
+
+ 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.
+
+ if Is_Private_Type (Def_Id) then
+ Par_Type := Etype (Full_View (Def_Id));
+ else
+ Par_Type := Etype (Def_Id);
+ end if;
+
+ -- If there is an inherited Implicit_Dereference, verify that it is
+ -- made explicit in the partial view.
+
+ if Has_Discriminants (Base_Type (Par_Type))
+ and then Nkind (Parent (Prev)) = N_Full_Type_Declaration
+ and then Present (Discriminant_Specifications (Parent (Prev)))
+ and then Present (Get_Reference_Discriminant (Par_Type))
+ then
+ 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);
+
+ else
+ -- If one of the views has the aspect specified, verify that it
+ -- is consistent with that of the parent.
+
+ declare
+ Par_Discr : constant Entity_Id :=
+ Get_Reference_Discriminant (Par_Type);
+ 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;
+
+ -- TBD : other nonoverridable aspects.
+ end Check_Nonoverridable_Aspects;
------------------------------------
-- Check_Ops_From_Incomplete_Type --
end if;
end Check_Ops_From_Incomplete_Type;
- ---------------------
- -- Restore_Globals --
- ---------------------
-
- procedure Restore_Globals is
- begin
- Ghost_Mode := GM;
- end Restore_Globals;
-
-- Start of processing for Analyze_Full_Type_Declaration
begin
Prev := Find_Type_Name (N);
- -- The type declaration may be subject to pragma Ghost with policy
- -- Ignore. Set the mode now to ensure that any nodes generated during
- -- analysis and expansion are properly flagged as ignored Ghost.
-
- Set_Ghost_Mode (N, Prev);
-
-- The full view, if present, now points to the current type. If there
-- is an incomplete partial view, set a link to it, to simplify the
-- retrieval of primitive operations of the type.
when others =>
raise Program_Error;
-
end case;
end if;
if Etype (T) = Any_Type then
- Restore_Globals;
return;
end if;
Check_SPARK_05_Restriction ("controlled type is not allowed", N);
end if;
- -- A type declared within a Ghost region is automatically Ghost
- -- (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (T);
- end if;
-
-- Some common processing for all types
Set_Depends_On_Private (T, Has_Private_Component (T));
and then Chars (Def_Id) = Name_Address
and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
then
- Set_Is_Descendent_Of_Address (Def_Id);
- Set_Is_Descendent_Of_Address (Base_Type (Def_Id));
- Set_Is_Descendent_Of_Address (Prev);
+ Set_Is_Descendant_Of_Address (Def_Id);
+ Set_Is_Descendant_Of_Address (Base_Type (Def_Id));
+ Set_Is_Descendant_Of_Address (Prev);
end if;
Set_Optimize_Alignment_Flags (Def_Id);
end if;
end if;
- Restore_Globals;
+ if Is_Derived_Type (Prev)
+ and then Def_Id /= Prev
+ then
+ Check_Nonoverridable_Aspects;
+ end if;
end Analyze_Full_Type_Declaration;
----------------------------------
----------------------------------
procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
- F : constant Boolean := Is_Pure (Current_Scope);
- GM : constant Ghost_Mode_Type := Ghost_Mode;
- T : Entity_Id;
+ F : constant Boolean := Is_Pure (Current_Scope);
+ T : Entity_Id;
begin
Check_SPARK_05_Restriction ("incomplete type is not allowed", N);
- -- The incomplete type declaration may be subject to pragma Ghost with
- -- policy Ignore. Set the mode now to ensure that any nodes generated
- -- during analysis and expansion are properly flagged as ignored Ghost.
-
- Set_Ghost_Mode (N);
Generate_Definition (Defining_Identifier (N));
-- Process an incomplete declaration. The identifier must not have been
Set_Is_First_Subtype (T, True);
Set_Etype (T, T);
- -- An incomplete type declared within a Ghost region is automatically
- -- Ghost (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (T);
- end if;
-
-- Ada 2005 (AI-326): Minimum decoration to give support to tagged
-- incomplete types.
Set_Direct_Primitive_Operations (T, New_Elmt_List);
end if;
- Push_Scope (T);
-
Set_Stored_Constraint (T, No_Elist);
if Present (Discriminant_Specifications (N)) then
+ Push_Scope (T);
Process_Discriminants (N);
+ End_Scope;
end if;
- End_Scope;
-
- -- 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 the type has discriminants, nontrivial 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.
Set_Private_Dependents (T, New_Elmt_List);
Set_Is_Pure (T, F);
-
- -- Restore the original Ghost mode once analysis and expansion have
- -- taken place.
-
- Ghost_Mode := GM;
end Analyze_Incomplete_Type_Decl;
-----------------------------------
-- Check runtime support for synchronized interfaces
- if VM_Target = No_VM
- and then (Is_Task_Interface (T)
- or else Is_Protected_Interface (T)
- or else Is_Synchronized_Interface (T))
+ if (Is_Task_Interface (T)
+ or else Is_Protected_Interface (T)
+ or else Is_Synchronized_Interface (T))
and then not RTE_Available (RE_Select_Specific_Data)
then
Error_Msg_CRT ("synchronized interfaces", T);
--------------------------------
procedure Analyze_Number_Declaration (N : Node_Id) is
- GM : constant Ghost_Mode_Type := Ghost_Mode;
-
- procedure Restore_Globals;
- -- Restore the values of all saved global variables
-
- ---------------------
- -- Restore_Globals --
- ---------------------
-
- procedure Restore_Globals is
- begin
- Ghost_Mode := GM;
- end Restore_Globals;
-
- -- Local variables
-
E : constant Node_Id := Expression (N);
Id : constant Entity_Id := Defining_Identifier (N);
Index : Interp_Index;
It : Interp;
T : Entity_Id;
- -- Start of processing for Analyze_Number_Declaration
-
begin
- -- The number declaration may be subject to pragma Ghost with policy
- -- Ignore. Set the mode now to ensure that any nodes generated during
- -- analysis and expansion are properly flagged as ignored Ghost.
-
- Set_Ghost_Mode (N);
-
Generate_Definition (Id);
Enter_Name (Id);
- -- A number declared within a Ghost region is automatically Ghost
- -- (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Id);
- end if;
-
-- This is an optimization of a common case of an integer literal
if Nkind (E) = N_Integer_Literal then
Set_Etype (Id, Universal_Integer);
Set_Ekind (Id, E_Named_Integer);
Set_Is_Frozen (Id, True);
-
- Restore_Globals;
return;
end if;
end loop;
end if;
- if Is_Integer_Type (T) then
+ if Is_Integer_Type (T) then
Resolve (E, T);
Set_Etype (Id, Universal_Integer);
Set_Ekind (Id, E_Named_Integer);
Set_Ekind (Id, E_Constant);
Set_Never_Set_In_Source (Id, True);
Set_Is_True_Constant (Id, True);
-
- Restore_Globals;
return;
end if;
Set_Etype (E, Any_Type);
end if;
- Restore_Globals;
+ Analyze_Dimension (N);
end Analyze_Number_Declaration;
- -----------------------------
- -- Analyze_Object_Contract --
- -----------------------------
-
- procedure Analyze_Object_Contract (Obj_Id : Entity_Id) is
- Obj_Typ : constant Entity_Id := Etype (Obj_Id);
- AR_Val : Boolean := False;
- AW_Val : Boolean := False;
- ER_Val : Boolean := False;
- EW_Val : Boolean := False;
- Prag : Node_Id;
- Seen : Boolean := False;
-
- begin
- -- The loop parameter in an element iterator over a formal container
- -- is declared with an object declaration but no contracts apply.
-
- if Ekind (Obj_Id) = E_Loop_Parameter then
- return;
- end if;
-
- -- Constant related checks
-
- if Ekind (Obj_Id) = E_Constant then
-
- -- A constant cannot be effectively volatile. This check is only
- -- relevant with SPARK_Mode on as it is not a standard Ada legality
- -- rule. Do not flag internally-generated constants that map generic
- -- formals to actuals in instantiations (SPARK RM 7.1.3(6)).
-
- if SPARK_Mode = On
- and then Is_Effectively_Volatile (Obj_Id)
- and then No (Corresponding_Generic_Association (Parent (Obj_Id)))
-
- -- Don't give this for internally generated entities (such as the
- -- FIRST and LAST temporaries generated for bounds).
-
- and then Comes_From_Source (Obj_Id)
- then
- Error_Msg_N ("constant cannot be volatile", Obj_Id);
- end if;
-
- -- Variable related checks
-
- else pragma Assert (Ekind (Obj_Id) = E_Variable);
-
- -- The following checks are only relevant when SPARK_Mode is on as
- -- they are not standard Ada legality rules. Internally generated
- -- temporaries are ignored.
-
- if SPARK_Mode = On and then Comes_From_Source (Obj_Id) then
- if Is_Effectively_Volatile (Obj_Id) then
-
- -- The declaration of an effectively volatile object must
- -- appear at the library level (SPARK RM 7.1.3(7), C.6(6)).
-
- if not Is_Library_Level_Entity (Obj_Id) then
- Error_Msg_N
- ("volatile variable & must be declared at library level",
- Obj_Id);
-
- -- An object of a discriminated type cannot be effectively
- -- volatile (SPARK RM C.6(4)).
-
- elsif Has_Discriminants (Obj_Typ) then
- Error_Msg_N
- ("discriminated object & cannot be volatile", Obj_Id);
-
- -- An object of a tagged type cannot be effectively volatile
- -- (SPARK RM C.6(5)).
-
- elsif Is_Tagged_Type (Obj_Typ) then
- Error_Msg_N ("tagged object & cannot be volatile", Obj_Id);
- end if;
-
- -- The object is not effectively volatile
-
- else
- -- A non-effectively volatile object cannot have effectively
- -- volatile components (SPARK RM 7.1.3(7)).
-
- if not Is_Effectively_Volatile (Obj_Id)
- and then Has_Volatile_Component (Obj_Typ)
- then
- Error_Msg_N
- ("non-volatile object & cannot have volatile components",
- Obj_Id);
- end if;
- end if;
- end if;
-
- if Is_Ghost_Entity (Obj_Id) then
-
- -- A Ghost object cannot be effectively volatile (SPARK RM 6.9(8))
-
- if Is_Effectively_Volatile (Obj_Id) then
- Error_Msg_N ("ghost variable & cannot be volatile", Obj_Id);
-
- -- A Ghost object cannot be imported or exported (SPARK RM 6.9(8))
-
- elsif Is_Imported (Obj_Id) then
- Error_Msg_N ("ghost object & cannot be imported", Obj_Id);
-
- elsif Is_Exported (Obj_Id) then
- Error_Msg_N ("ghost object & cannot be exported", Obj_Id);
- end if;
- end if;
-
- -- Analyze all external properties
-
- Prag := Get_Pragma (Obj_Id, Pragma_Async_Readers);
-
- if Present (Prag) then
- Analyze_External_Property_In_Decl_Part (Prag, AR_Val);
- Seen := True;
- end if;
-
- Prag := Get_Pragma (Obj_Id, Pragma_Async_Writers);
-
- if Present (Prag) then
- Analyze_External_Property_In_Decl_Part (Prag, AW_Val);
- Seen := True;
- end if;
-
- Prag := Get_Pragma (Obj_Id, Pragma_Effective_Reads);
-
- if Present (Prag) then
- Analyze_External_Property_In_Decl_Part (Prag, ER_Val);
- Seen := True;
- end if;
-
- Prag := Get_Pragma (Obj_Id, Pragma_Effective_Writes);
-
- if Present (Prag) then
- Analyze_External_Property_In_Decl_Part (Prag, EW_Val);
- Seen := True;
- end if;
-
- -- Verify the mutual interaction of the various external properties
-
- if Seen then
- Check_External_Properties (Obj_Id, AR_Val, AW_Val, ER_Val, EW_Val);
- end if;
- end if;
-
- -- Check whether the lack of indicator Part_Of agrees with the placement
- -- of the object with respect to the state space.
-
- Prag := Get_Pragma (Obj_Id, Pragma_Part_Of);
-
- if No (Prag) then
- Check_Missing_Part_Of (Obj_Id);
- end if;
-
- -- A ghost object cannot be imported or exported (SPARK RM 6.9(8))
-
- if Is_Ghost_Entity (Obj_Id) then
- if Is_Exported (Obj_Id) then
- Error_Msg_N ("ghost object & cannot be exported", Obj_Id);
-
- elsif Is_Imported (Obj_Id) then
- Error_Msg_N ("ghost object & cannot be imported", Obj_Id);
- end if;
- end if;
- end Analyze_Object_Contract;
-
--------------------------------
-- Analyze_Object_Declaration --
--------------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze_Object_Declaration (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- GM : constant Ghost_Mode_Type := Ghost_Mode;
- Id : constant Entity_Id := Defining_Identifier (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Id : constant Entity_Id := Defining_Identifier (N);
Act_T : Entity_Id;
T : Entity_Id;
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
- -- tasks declared within the type (it is only called if Has_Tasks is set
+ -- tasks declared within the type (it is only called if Has_Task is set
-- for T). As a side effect, if an array of tasks with non-static bounds
- -- or a variant record type is encountered, Check_Restrictions is called
+ -- or a variant record type is encountered, Check_Restriction is called
-- indicating the count is unknown.
function Delayed_Aspect_Present return Boolean;
-- Any other relevant delayed aspects on object declarations ???
- procedure Restore_Globals;
- -- Restore the values of all saved global variables
-
-----------------
-- Count_Tasks --
-----------------
return False;
end Delayed_Aspect_Present;
- ---------------------
- -- Restore_Globals --
- ---------------------
+ -- Local variables
- procedure Restore_Globals is
- begin
- Ghost_Mode := GM;
- end Restore_Globals;
+ Mode : Ghost_Mode_Type;
+ Mode_Set : Boolean := False;
+ Related_Id : Entity_Id;
-- Start of processing for Analyze_Object_Declaration
N_Package_Renaming_Declaration
and then not Comes_From_Source (Prev_Entity)
and then
- Is_Generic_Instance (Renamed_Entity (Prev_Entity))))
+ Is_Generic_Instance (Renamed_Entity (Prev_Entity)))
+
+ -- The entity may be a homonym of a private component of the
+ -- enclosing protected object, for which we create a local
+ -- renaming declaration. The declaration is legal, even if
+ -- useless when it just captures that component.
+
+ or else
+ (Ekind (Scope (Current_Scope)) = E_Protected_Type
+ and then Nkind (Parent (Prev_Entity)) =
+ N_Object_Renaming_Declaration))
then
Prev_Entity := Empty;
end if;
end if;
- -- The object declaration may be subject to pragma Ghost with policy
- -- Ignore. Set the mode now to ensure that any nodes generated during
- -- analysis and expansion are properly flagged as ignored Ghost.
+ if Present (Prev_Entity) then
- Set_Ghost_Mode (N, Prev_Entity);
+ -- The object declaration is Ghost when it completes a deferred Ghost
+ -- constant.
+
+ Mark_And_Set_Ghost_Completion (N, Prev_Entity, Mode);
+ Mode_Set := True;
- if Present (Prev_Entity) then
Constant_Redeclaration (Id, N, T);
Generate_Reference (Prev_Entity, Id, 'c');
if Error_Posted (N) then
- -- Type mismatch or illegal redeclaration, Do not analyze
+ -- Type mismatch or illegal redeclaration; do not analyze
-- expression to avoid cascaded errors.
T := Find_Type_Of_Object (Object_Definition (N), N);
end if;
-- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
- -- out some static checks
+ -- out some static checks.
if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) 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).
+ -- point of the analysis of the aggregate (see sem_aggr.adb) ???
if Present (Expression (N))
and then Nkind (Expression (N)) = N_Aggregate
-- Special checks for protected objects not at library level
- if Is_Protected_Type (T)
- and then not Is_Library_Level_Entity (Id)
- then
+ if Has_Protected (T) and then not Is_Library_Level_Entity (Id) then
Check_Restriction (No_Local_Protected_Objects, Id);
-- Protected objects with interrupt handlers must be at library level
-- AI05-0303: The AI is in fact a binding interpretation, and thus
-- applies to the '95 version of the language as well.
- if Has_Interrupt_Handler (T) and then Ada_Version < Ada_95 then
+ if Is_Protected_Type (T)
+ and then Has_Interrupt_Handler (T)
+ and then Ada_Version < Ada_95
+ then
Error_Msg_N
("interrupt object can only be declared at library level", Id);
end if;
end if;
+ -- Check for violation of No_Local_Timing_Events
+
+ if Has_Timing_Event (T) and then not Is_Library_Level_Entity (Id) then
+ Check_Restriction (No_Local_Timing_Events, Id);
+ end if;
+
-- The actual subtype of the object is the nominal subtype, unless
-- the nominal one is unconstrained and obtained from the expression.
-- the possible presence of an address clause, and defer resolution
-- and expansion of the aggregate to the freeze point of the entity.
+ -- This is not always legal because the aggregate may contain other
+ -- references that need freezing, e.g. references to other entities
+ -- with address clauses. In any case, when compiling with -gnatI the
+ -- presence of the address clause must be ignored.
+
if Comes_From_Source (N)
and then Expander_Active
and then Nkind (E) = N_Aggregate
- and then (Present (Following_Address_Clause (N))
- or else Delayed_Aspect_Present)
+ and then
+ ((Present (Following_Address_Clause (N))
+ and then not Ignore_Rep_Clauses)
+ or else Delayed_Aspect_Present)
then
Set_Etype (E, T);
and then Analyzed (N)
and then No (Expression (N))
then
- Restore_Globals;
- return;
+ goto Leave;
end if;
-- If E is null and has been replaced by an N_Raise_Constraint_Error
-- A formal parameter of a specific tagged type whose related
-- subprogram is subject to pragma Extensions_Visible with value
-- "False" cannot be implicitly converted to a class-wide type by
- -- means of an initialization expression (SPARK RM 6.1.7(3)).
+ -- means of an initialization expression (SPARK RM 6.1.7(3)). Do
+ -- not consider internally generated expressions.
- if Is_Class_Wide_Type (T) and then Is_EVF_Expression (E) then
+ if Is_Class_Wide_Type (T)
+ and then Comes_From_Source (E)
+ and then Is_EVF_Expression (E)
+ then
Error_Msg_N
- ("formal parameter with Extensions_Visible False cannot be "
- & "implicitly converted to class-wide type", E);
+ ("formal parameter cannot be implicitly converted to "
+ & "class-wide type when Extensions_Visible is False", E);
end if;
end if;
-- do this in the analyzer and not the expander because the analyzer
-- does some substantial rewriting in some cases.
- -- We need a predicate check if the type has predicates, and if either
- -- there is an initializing expression, or for default initialization
- -- when we have at least one case of an explicit default initial value
- -- and then this is not an internal declaration whose initialization
- -- comes later (as for an aggregate expansion).
+ -- We need a predicate check if the type has predicates that are not
+ -- ignored, and if either there is an initializing expression, or for
+ -- default initialization when we have at least one case of an explicit
+ -- default initial value and then this is not an internal declaration
+ -- whose initialization comes later (as for an aggregate expansion).
if not Suppress_Assignment_Checks (N)
and then Present (Predicate_Function (T))
+ and then not Predicates_Ignored (T)
and then not No_Initialization (N)
and then
(Present (E)
Check_Expression_Against_Static_Predicate (E, T);
end if;
- Insert_After (N,
- Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
+ -- If the type is a null record and there is no explicit initial
+ -- expression, no predicate check applies.
+
+ if No (E) and then Is_Null_Record_Type (T) then
+ null;
+
+ else
+ Insert_After (N,
+ Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
+ end if;
end if;
-- Case of unconstrained type
Set_Ekind (Id, E_Variable);
end if;
- -- An object declared within a Ghost region is automatically
- -- Ghost (SPARK RM 6.9(2)).
-
- if Comes_From_Source (Id) and then Ghost_Mode > None then
- Set_Is_Ghost_Entity (Id);
-
- -- The Ghost policy in effect at the point of declaration
- -- and at the point of completion must match
- -- (SPARK RM 6.9(14)).
-
- if Present (Prev_Entity)
- and then Is_Ghost_Entity (Prev_Entity)
- then
- Check_Ghost_Completion (Prev_Entity, Id);
- end if;
- end if;
-
Rewrite (N,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
Set_Renamed_Object (Id, E);
Freeze_Before (N, T);
Set_Is_Frozen (Id);
-
- Restore_Globals;
- return;
+ goto Leave;
else
- Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
+ -- Ensure that the generated subtype has a unique external name
+ -- when the related object is public. This guarantees that the
+ -- subtype and its bounds will not be affected by switches or
+ -- pragmas that may offset the internal counter due to extra
+ -- generated code.
+
+ if Is_Public (Id) then
+ Related_Id := Id;
+ else
+ Related_Id := Empty;
+ end if;
+
+ Expand_Subtype_From_Expr
+ (N => N,
+ Unc_Type => T,
+ Subtype_Indic => Object_Definition (N),
+ Exp => E,
+ Related_Id => Related_Id);
+
Act_T := Find_Type_Of_Object (Object_Definition (N), N);
end if;
elsif Is_Array_Type (T)
and then No_Initialization (N)
- and then Nkind (Original_Node (E)) = N_Aggregate
+ and then (Nkind (Original_Node (E)) = N_Aggregate
+ or else (Nkind (Original_Node (E)) = N_Qualified_Expression
+ and then Nkind (Original_Node (Expression
+ (Original_Node (E)))) = N_Aggregate))
then
if not Is_Entity_Name (Object_Definition (N)) then
Act_T := Etype (E);
elsif Nkind (E) = N_Aggregate
and then Present (Component_Associations (E))
- and then Present (Choices (First (Component_Associations (E))))
- and then Nkind (First
- (Choices (First (Component_Associations (E))))) = N_Others_Choice
+ and then Present (Choice_List (First (Component_Associations (E))))
+ and then
+ Nkind (First (Choice_List (First (Component_Associations (E))))) =
+ N_Others_Choice
then
null;
Init_Esize (Id);
Set_Optimize_Alignment_Flags (Id);
- -- An object declared within a Ghost region is automatically Ghost
- -- (SPARK RM 6.9(2)).
-
- if Comes_From_Source (Id)
- and then (Ghost_Mode > None
- or else (Present (Prev_Entity)
- and then Is_Ghost_Entity (Prev_Entity)))
- then
- Set_Is_Ghost_Entity (Id);
-
- -- The Ghost policy in effect at the point of declaration and at the
- -- point of completion must match (SPARK RM 6.9(14)).
-
- if Present (Prev_Entity) and then Is_Ghost_Entity (Prev_Entity) then
- Check_Ghost_Completion (Prev_Entity, Id);
- end if;
- end if;
-
-- Deal with aliased case
if Aliased_Present (N) then
-- type, rewrite the declaration as a renaming of the result of the
-- call. The exceptions below are cases where the copy is expected,
-- either by the back end (Aliased case) or by the semantics, as for
- -- initializing controlled types or copying tags for classwide types.
+ -- initializing controlled types or copying tags for class-wide types.
if Present (E)
and then Nkind (E) = N_Explicit_Dereference
Set_In_Private_Part (Id);
end if;
- -- Check for violation of No_Local_Timing_Events
-
- if Restriction_Check_Required (No_Local_Timing_Events)
- and then not Is_Library_Level_Entity (Id)
- and then Is_RTE (Etype (Id), RE_Timing_Event)
- then
- Check_Restriction (No_Local_Timing_Events, N);
- end if;
-
<<Leave>>
-- Initialize the refined state of a variable here because this is a
-- common destination for legal and illegal object declarations.
Check_No_Hidden_State (Id);
end if;
- Restore_Globals;
+ if Mode_Set then
+ Restore_Ghost_Mode (Mode);
+ end if;
end Analyze_Object_Declaration;
---------------------------
-------------------------------------------
procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
- GM : constant Ghost_Mode_Type := Ghost_Mode;
- Indic : constant Node_Id := Subtype_Indication (N);
- T : constant Entity_Id := Defining_Identifier (N);
+ Indic : constant Node_Id := Subtype_Indication (N);
+ T : constant Entity_Id := Defining_Identifier (N);
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
Parent_Base : Entity_Id;
Parent_Type : Entity_Id;
begin
- -- The private extension declaration may be subject to pragma Ghost with
- -- policy Ignore. Set the mode now to ensure that any nodes generated
- -- during analysis and expansion are properly flagged as ignored Ghost.
-
- Set_Ghost_Mode (N);
-
-- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
if Is_Non_Empty_List (Interface_List (N)) then
elsif Is_Concurrent_Type (Parent_Type) then
Error_Msg_N
- ("parent type of a private extension cannot be "
- & "a synchronized tagged type (RM 3.9.1 (3/1))", N);
+ ("parent type of a private extension cannot be a synchronized "
+ & "tagged type (RM 3.9.1 (3/1))", N);
Set_Etype (T, Any_Type);
Set_Ekind (T, E_Limited_Private_Type);
if (not Is_Package_Or_Generic_Package (Current_Scope)
and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
or else In_Private_Part (Current_Scope)
-
then
Error_Msg_N ("invalid context for private extension", N);
end if;
Init_Size_Align (T);
Set_Default_SSO (T);
- Set_Etype (T, Parent_Base);
- Set_Has_Task (T, Has_Task (Parent_Base));
- Set_Has_Protected (T, Has_Task (Parent_Base));
+ Set_Etype (T, Parent_Base);
+ Propagate_Concurrent_Flags (T, Parent_Base);
Set_Convention (T, Convention (Parent_Type));
Set_First_Rep_Item (T, First_Rep_Item (Parent_Type));
Build_Derived_Record_Type (N, Parent_Type, T);
- -- Propagate inherited invariant information. The new type has
- -- invariants, if the parent type has inheritable invariants,
- -- and these invariants can in turn be inherited.
+ -- A private extension inherits the Default_Initial_Condition pragma
+ -- coming from any parent type within the derivation chain.
- if Has_Inheritable_Invariants (Parent_Type) then
- Set_Has_Inheritable_Invariants (T);
- Set_Has_Invariants (T);
+ if Has_DIC (Parent_Type) then
+ Set_Has_Inherited_DIC (T);
+ end if;
+
+ -- A private extension inherits any class-wide invariants coming from a
+ -- parent type or an interface. Note that the invariant procedure of the
+ -- parent type should not be inherited because the private extension may
+ -- define invariants of its own.
+
+ if Has_Inherited_Invariants (Parent_Type)
+ or else Has_Inheritable_Invariants (Parent_Type)
+ then
+ Set_Has_Inherited_Invariants (T);
+
+ elsif Present (Interfaces (T)) then
+ Iface_Elmt := First_Elmt (Interfaces (T));
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ if Has_Inheritable_Invariants (Iface) then
+ Set_Has_Inherited_Invariants (T);
+ exit;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
end if;
-- Ada 2005 (AI-443): Synchronized private extension or a rewritten
(not Is_Interface (Parent_Type)
or else not Is_Synchronized_Interface (Parent_Type))
then
- Error_Msg_NE ("parent type of & must be tagged limited " &
- "or synchronized", N, T);
+ Error_Msg_NE
+ ("parent type of & must be tagged limited or synchronized",
+ N, T);
end if;
-- The progenitors (if any) must be limited or synchronized
-- interfaces.
if Present (Interfaces (T)) then
- declare
- Iface : Entity_Id;
- Iface_Elmt : Elmt_Id;
+ Iface_Elmt := First_Elmt (Interfaces (T));
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
- begin
- Iface_Elmt := First_Elmt (Interfaces (T));
- while Present (Iface_Elmt) loop
- Iface := Node (Iface_Elmt);
-
- if not Is_Limited_Interface (Iface)
- and then not Is_Synchronized_Interface (Iface)
- then
- Error_Msg_NE ("progenitor & must be limited " &
- "or synchronized", N, Iface);
- end if;
+ if not Is_Limited_Interface (Iface)
+ and then not Is_Synchronized_Interface (Iface)
+ then
+ Error_Msg_NE
+ ("progenitor & must be limited or synchronized",
+ N, Iface);
+ end if;
- Next_Elmt (Iface_Elmt);
- end loop;
- end;
+ Next_Elmt (Iface_Elmt);
+ end loop;
end if;
-- Regular derived extension, the parent must be a limited or
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, T);
end if;
-
- -- Restore the original Ghost mode once analysis and expansion have
- -- taken place.
-
- Ghost_Mode := GM;
end Analyze_Private_Extension_Declaration;
---------------------------------
(N : Node_Id;
Skip : Boolean := False)
is
- GM : constant Ghost_Mode_Type := Ghost_Mode;
Id : constant Entity_Id := Defining_Identifier (N);
R_Checks : Check_Result;
T : Entity_Id;
begin
- -- The subtype declaration may be subject to pragma Ghost with policy
- -- Ignore. Set the mode now to ensure that any nodes generated during
- -- analysis and expansion are properly flagged as ignored Ghost.
-
- Set_Ghost_Mode (N);
-
Generate_Definition (Id);
Set_Is_Pure (Id, Is_Pure (Current_Scope));
Init_Size_Align (Id);
then
Set_Has_Predicates (Id);
Set_Has_Delayed_Freeze (Id);
+
+ -- Generated subtypes inherit the predicate function from the parent
+ -- (no aspects to examine on the generated declaration).
+
+ if not Comes_From_Source (N) then
+ Set_Ekind (Id, Ekind (T));
+
+ if Present (Predicate_Function (T)) then
+ Set_Predicate_Function (Id, Predicate_Function (T));
+
+ elsif Present (Ancestor_Subtype (T))
+ and then Has_Predicates (Ancestor_Subtype (T))
+ and then Present (Predicate_Function (Ancestor_Subtype (T)))
+ then
+ Set_Predicate_Function (Id,
+ Predicate_Function (Ancestor_Subtype (T)));
+ end if;
+ end if;
end if;
-- Subtype of Boolean cannot have a constraint in SPARK
case Ekind (T) is
when Array_Kind =>
- Set_Ekind (Id, E_Array_Subtype);
- Copy_Array_Subtype_Attributes (Id, T);
+ Set_Ekind (Id, E_Array_Subtype);
+ Copy_Array_Subtype_Attributes (Id, T);
when Decimal_Fixed_Point_Kind =>
Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype);
Set_Digits_Value (Id, Digits_Value (T));
Set_Is_Constrained (Id, Is_Constrained (T));
+ -- If the floating point type has dimensions, these will be
+ -- inherited subsequently when Analyze_Dimensions is called.
+
when Signed_Integer_Kind =>
Set_Ekind (Id, E_Signed_Integer_Subtype);
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Equivalent_Type (Id, Equivalent_Type (T));
end if;
- when E_Record_Type | E_Record_Subtype =>
+ when E_Record_Subtype
+ | E_Record_Type
+ =>
Set_Ekind (Id, E_Record_Subtype);
if Ekind (T) = E_Record_Subtype
Set_Stored_Constraint_From_Discriminant_Constraint (Id);
end if;
- when Incomplete_Kind =>
+ when Incomplete_Kind =>
if Ada_Version >= Ada_2005 then
-- In Ada 2005 an incomplete type can be explicitly tagged:
Set_Is_Generic_Actual_Type (Id, Is_Generic_Actual_Type (T));
end if;
+ -- If this is a subtype declaration for an actual in an instance,
+ -- inherit static and dynamic predicates if any.
+
+ -- If declaration has no aspect specifications, inherit predicate
+ -- info as well. Unclear how to handle the case of both specified
+ -- and inherited predicates ??? Other inherited aspects, such as
+ -- invariants, should be OK, but the combination with later pragmas
+ -- may also require special merging.
+
+ if Has_Predicates (T)
+ and then Present (Predicate_Function (T))
+ and then
+ ((In_Instance and then not Comes_From_Source (N))
+ or else No (Aspect_Specifications (N)))
+ then
+ Set_Subprograms_For_Type (Id, Subprograms_For_Type (T));
+
+ if Has_Static_Predicate (T) then
+ Set_Has_Static_Predicate (Id);
+ Set_Static_Discrete_Predicate (Id, Static_Discrete_Predicate (T));
+ end if;
+ end if;
+
+ -- Remaining processing depends on characteristics of base type
+
T := Etype (Id);
Set_Is_Immediately_Visible (Id, True);
Set_Depends_On_Private (Id, Has_Private_Component (T));
- Set_Is_Descendent_Of_Address (Id, Is_Descendent_Of_Address (T));
+ Set_Is_Descendant_Of_Address (Id, Is_Descendant_Of_Address (T));
if Is_Interface (T) then
Set_Is_Interface (Id);
if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
if Is_Scalar_Type (Etype (Id))
- and then Scalar_Range (Id) /=
- Scalar_Range (Etype (Subtype_Mark
- (Subtype_Indication (N))))
+ and then Scalar_Range (Id) /=
+ Scalar_Range
+ (Etype (Subtype_Mark (Subtype_Indication (N))))
then
Apply_Range_Check
(Scalar_Range (Id),
Set_Has_Dynamic_Range_Check (N, Has_Dyn_Chk);
end;
- end if;
- end if;
-
- -- A type invariant applies to any subtype in its scope, in particular
- -- to a generic actual.
-
- if Has_Invariants (T) and then In_Open_Scopes (Scope (T)) then
- Set_Has_Invariants (Id);
- Set_Invariant_Procedure (Id, Invariant_Procedure (T));
- end if;
-
- -- Make sure that generic actual types are properly frozen. The subtype
- -- is marked as a generic actual type when the enclosing instance is
- -- analyzed, so here we identify the subtype from the tree structure.
-
- if Expander_Active
- and then Is_Generic_Actual_Type (Id)
- and then In_Instance
- and then not Comes_From_Source (N)
- and then Nkind (Subtype_Indication (N)) /= N_Subtype_Indication
- and then Is_Frozen (T)
- then
- Freeze_Before (N, Id);
+ end if;
end if;
Set_Optimize_Alignment_Flags (Id);
Analyze_Dimension (N);
- -- Restore the original Ghost mode once analysis and expansion have
- -- taken place.
+ -- Check No_Dynamic_Sized_Objects restriction, which disallows subtype
+ -- indications on composite types where the constraints are dynamic.
+ -- Note that object declarations and aggregates generate implicit
+ -- subtype declarations, which this covers. One special case is that the
+ -- implicitly generated "=" for discriminated types includes an
+ -- offending subtype declaration, which is harmless, so we ignore it
+ -- here.
- Ghost_Mode := GM;
+ if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
+ declare
+ Cstr : constant Node_Id := Constraint (Subtype_Indication (N));
+ begin
+ if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint
+ and then not (Is_Internal (Id)
+ and then Is_TSS (Scope (Id),
+ TSS_Composite_Equality))
+ and then not Within_Init_Proc
+ and then not All_Composite_Constraints_Static (Cstr)
+ then
+ Check_Restriction (No_Dynamic_Sized_Objects, Cstr);
+ end if;
+ end;
+ end if;
end Analyze_Subtype_Declaration;
--------------------------------
procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is
Component_Def : constant Node_Id := Component_Definition (Def);
Component_Typ : constant Node_Id := Subtype_Indication (Component_Def);
+ P : constant Node_Id := Parent (Def);
Element_Type : Entity_Id;
Implicit_Base : Entity_Id;
Index : Node_Id;
- Related_Id : Entity_Id := Empty;
Nb_Index : Nat;
- P : constant Node_Id := Parent (Def);
Priv : Entity_Id;
+ Related_Id : Entity_Id := Empty;
begin
if Nkind (Def) = N_Constrained_Array_Definition then
then
declare
Loc : constant Source_Ptr := Sloc (Def);
- New_E : Entity_Id;
Decl : Entity_Id;
+ New_E : Entity_Id;
begin
New_E := Make_Temporary (Loc, 'T');
-- Complete setup of implicit base type
- Set_First_Index (Implicit_Base, First_Index (T));
- Set_Component_Type (Implicit_Base, Element_Type);
- Set_Has_Task (Implicit_Base, Has_Task (Element_Type));
- Set_Has_Protected (Implicit_Base, Has_Protected (Element_Type));
- Set_Component_Size (Implicit_Base, Uint_0);
- Set_Packed_Array_Impl_Type (Implicit_Base, Empty);
- Set_Has_Controlled_Component (Implicit_Base,
- Has_Controlled_Component (Element_Type)
- or else Is_Controlled_Active (Element_Type));
- Set_Finalize_Storage_Only (Implicit_Base,
- Finalize_Storage_Only (Element_Type));
-
- -- Inherit the "ghostness" from the constrained array type
+ Set_Component_Size (Implicit_Base, Uint_0);
+ Set_Component_Type (Implicit_Base, Element_Type);
+ Set_Finalize_Storage_Only
+ (Implicit_Base,
+ Finalize_Storage_Only (Element_Type));
+ Set_First_Index (Implicit_Base, First_Index (T));
+ Set_Has_Controlled_Component
+ (Implicit_Base,
+ Has_Controlled_Component (Element_Type)
+ or else Is_Controlled_Active (Element_Type));
+ Set_Packed_Array_Impl_Type
+ (Implicit_Base, Empty);
- if Is_Ghost_Entity (T) or else Ghost_Mode > None then
- Set_Is_Ghost_Entity (Implicit_Base);
- end if;
+ Propagate_Concurrent_Flags (Implicit_Base, Element_Type);
-- Unconstrained array case
Set_Is_Constrained (T, False);
Set_First_Index (T, First (Subtype_Marks (Def)));
Set_Has_Delayed_Freeze (T, True);
- Set_Has_Task (T, Has_Task (Element_Type));
- Set_Has_Protected (T, Has_Protected (Element_Type));
+ Propagate_Concurrent_Flags (T, Element_Type);
Set_Has_Controlled_Component (T, Has_Controlled_Component
(Element_Type)
or else
Set_Is_Internal (Anon);
case Nkind (N) is
- when N_Component_Declaration |
- N_Unconstrained_Array_Definition |
- N_Constrained_Array_Definition =>
+ when N_Constrained_Array_Definition
+ | N_Component_Declaration
+ | N_Unconstrained_Array_Definition
+ =>
Comp := Component_Definition (N);
Acc := Access_Definition (Comp);
if ASIS_Mode then
declare
- Typ : constant Entity_Id := Make_Temporary (Loc, 'S');
+ Typ : constant Entity_Id := Make_Temporary (Loc, 'S');
begin
if Nkind (Spec) = N_Access_Function_Definition then
end if;
-- 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.
+ -- parent is a body and N is its return type, the declaration belongs
+ -- in the enclosing scope. Likewise if N is the type of a parameter.
P := Parent (N);
- if Nkind (P) = N_Subprogram_Body
- and then Nkind (N) = N_Function_Specification
+ if Nkind (N) = N_Function_Specification
+ and then Nkind (P) = N_Subprogram_Body
then
P := Parent (P);
+ elsif Nkind (N) = N_Parameter_Specification
+ and then Nkind (P) in N_Subprogram_Specification
+ and then Nkind (Parent (P)) = N_Subprogram_Body
+ then
+ P := Parent (Parent (P));
end if;
while Present (P) and then not Has_Declarations (P) loop
Mark_Rewrite_Insertion (Comp);
- if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then
+ if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition)
+ or else (Nkind (Parent (N)) = N_Full_Type_Declaration
+ and then not Is_Type (Current_Scope))
+ then
+
+ -- Declaration can be analyzed in the current scope.
+
Analyze (Decl);
else
-- Temporarily remove the current scope (record or subprogram) from
-- the stack to add the new declarations to the enclosing scope.
+ -- The anonymous entity is an Itype with the proper attributes.
Scope_Stack.Decrement_Last;
Analyze (Decl);
Set_Is_Itype (Anon);
+ Set_Associated_Node_For_Itype (Anon, N);
Scope_Stack.Append (Curr_Scope);
end if;
begin
Copy_Node (Pbase, Ibase);
+ -- Restore Itype status after Copy_Node
+
+ Set_Is_Itype (Ibase);
+ Set_Associated_Node_For_Itype (Ibase, N);
+
Set_Chars (Ibase, Svg_Chars);
Set_Next_Entity (Ibase, Svg_Next_E);
Set_Sloc (Ibase, Sloc (Derived_Type));
if Null_Exclusion_Present (Type_Definition (N)) then
Set_Can_Never_Be_Null (Derived_Type);
- -- What is with the "AND THEN FALSE" here ???
-
- 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;
-- ??? THIS CODE SHOULD NOT BE HERE REALLY.
Desig_Type := Designated_Type (Derived_Type);
+
if Is_Composite_Type (Desig_Type)
and then (not Is_Array_Type (Desig_Type))
and then Has_Discriminants (Desig_Type)
Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base);
Set_Has_Delayed_Freeze (Implicit_Base, True);
-
- -- Inherit the "ghostness" from the parent base type
-
- if Is_Ghost_Entity (Parent_Base) or else Ghost_Mode > None then
- Set_Is_Ghost_Entity (Implicit_Base);
- end if;
end Make_Implicit_Base;
-- Start of processing for Build_Derived_Array_Type
-- If we constructed a default range for the case where no range
-- was given, then the expressions in the range must not freeze
-- since they do not correspond to expressions in the source.
+ -- However, if the type inherits predicates the expressions will
+ -- be elaborated earlier and must freeze.
- if Nkind (Indic) /= N_Subtype_Indication then
+ if Nkind (Indic) /= N_Subtype_Indication
+ and then not Has_Predicates (Derived_Type)
+ then
Set_Must_Not_Freeze (Lo);
Set_Must_Not_Freeze (Hi);
Set_Must_Not_Freeze (Rang_Expr);
Set_Is_Known_Valid (Derived_Type, Is_Known_Valid (Parent_Type));
end if;
- Set_Is_Descendent_Of_Address (Derived_Type,
- Is_Descendent_Of_Address (Parent_Type));
- Set_Is_Descendent_Of_Address (Implicit_Base,
- Is_Descendent_Of_Address (Parent_Type));
+ Set_Is_Descendant_Of_Address (Derived_Type,
+ Is_Descendant_Of_Address (Parent_Type));
+ Set_Is_Descendant_Of_Address (Implicit_Base,
+ Is_Descendant_Of_Address (Parent_Type));
-- Set remaining type-specific fields, depending on numeric type
Set_Full_View (Derived_Type, Full_Der);
else
Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
end if;
if not Is_Base_Type (Derived_Type) then
Set_Full_View (Derived_Type, Full_Der);
else
Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
end if;
-- In any case, the primitive operations are inherited from the
else
Build_Full_Derivation;
Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
end if;
-- The full view will be used to swap entities on entry/exit to
end;
end if;
- -- Propagate inherited invariant information of parents
- -- and progenitors
-
- if Ada_Version >= Ada_2012
- and then not Is_Interface (Derived_Type)
- then
- if Has_Inheritable_Invariants (Parent_Type) then
- Set_Has_Invariants (Derived_Type);
- Set_Has_Inheritable_Invariants (Derived_Type);
-
- elsif not Is_Empty_Elmt_List (Ifaces_List) then
- declare
- AI : Elmt_Id;
-
- begin
- AI := First_Elmt (Ifaces_List);
- while Present (AI) loop
- if Has_Inheritable_Invariants (Node (AI)) then
- Set_Has_Invariants (Derived_Type);
- Set_Has_Inheritable_Invariants (Derived_Type);
-
- exit;
- end if;
-
- Next_Elmt (AI);
- end loop;
- end;
- end if;
- end if;
-
-- A type extension is automatically Ghost when one of its
-- progenitors is Ghost (SPARK RM 6.9(9)). This property is
-- also inherited when the parent type is Ghost, but this is
-- 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
begin
-- Set common attributes
- Set_Scope (Derived_Type, Current_Scope);
+ Set_Scope (Derived_Type, Current_Scope);
- Set_Etype (Derived_Type, Parent_Base);
- Set_Ekind (Derived_Type, Ekind (Parent_Base));
- Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
- Set_Has_Protected (Derived_Type, Has_Protected (Parent_Base));
+ Set_Etype (Derived_Type, Parent_Base);
+ Set_Ekind (Derived_Type, Ekind (Parent_Base));
+ Propagate_Concurrent_Flags (Derived_Type, Parent_Base);
Set_Size_Info (Derived_Type, Parent_Type);
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
Set_Default_SSO (Derived_Type);
end if;
- -- Propagate invariant information. The new type has invariants if
- -- they are inherited from the parent type, and these invariants can
- -- be further inherited, so both flags are set.
+ -- A derived type inherits the Default_Initial_Condition pragma coming
+ -- from any parent type within the derivation chain.
+
+ if Has_DIC (Parent_Type) then
+ Set_Has_Inherited_DIC (Derived_Type);
+ end if;
+
+ -- A derived type inherits any class-wide invariants coming from a
+ -- parent type or an interface. Note that the invariant procedure of
+ -- the parent type should not be inherited because the derived type may
+ -- define invariants of its own.
+
+ if not Is_Interface (Derived_Type) then
+ if Has_Inherited_Invariants (Parent_Type)
+ or else Has_Inheritable_Invariants (Parent_Type)
+ then
+ Set_Has_Inherited_Invariants (Derived_Type);
+
+ elsif Is_Concurrent_Type (Derived_Type)
+ or else Is_Tagged_Type (Derived_Type)
+ then
+ declare
+ Iface : Entity_Id;
+ Ifaces : Elist_Id;
+ Iface_Elmt : Elmt_Id;
+
+ begin
+ Collect_Interfaces
+ (T => Derived_Type,
+ Ifaces_List => Ifaces,
+ Exclude_Parents => True);
+
+ if Present (Ifaces) then
+ Iface_Elmt := First_Elmt (Ifaces);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ if Has_Inheritable_Invariants (Iface) then
+ Set_Has_Inherited_Invariants (Derived_Type);
+ exit;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end if;
+ end;
+ end if;
+ end if;
- -- We similarly inherit predicates
+ -- We similarly inherit predicates. Note that for scalar derived types
+ -- the predicate is inherited from the first subtype, and not from its
+ -- (anonymous) base type.
- if Has_Predicates (Parent_Type) then
+ if Has_Predicates (Parent_Type)
+ or else Has_Predicates (First_Subtype (Parent_Type))
+ then
Set_Has_Predicates (Derived_Type);
end if;
Inherit_Rep_Item_Chain (Derived_Type, Parent_Type);
- -- Propagate the attributes related to pragma Default_Initial_Condition
- -- from the parent type to the private extension. A derived type always
- -- inherits the default initial condition flag from the parent type. If
- -- the derived type carries its own Default_Initial_Condition pragma,
- -- the flag is later reset in Analyze_Pragma. Note that both flags are
- -- mutually exclusive.
-
- Propagate_Default_Init_Cond_Attributes
- (From_Typ => Parent_Type,
- To_Typ => Derived_Type,
- Parent_To_Derivation => True);
-
-- If the parent type has delayed rep aspects, then mark the derived
-- type as possibly inheriting a delayed rep aspect.
Set_May_Inherit_Delayed_Rep_Aspects (Derived_Type);
end if;
- -- Propagate the attributes related to pragma Ghost from the parent type
- -- to the derived type or type extension (SPARK RM 6.9(9)).
+ -- A derived type becomes Ghost when its parent type is also Ghost
+ -- (SPARK RM 6.9(9)). Note that the Ghost-related attributes are not
+ -- directly inherited because the Ghost policy in effect may differ.
if Is_Ghost_Entity (Parent_Type) then
Set_Is_Ghost_Entity (Derived_Type);
when Array_Kind =>
Build_Derived_Array_Type (N, Parent_Type, Derived_Type);
- when E_Record_Type
+ when Class_Wide_Kind
| E_Record_Subtype
- | Class_Wide_Kind =>
+ | E_Record_Type
+ =>
Build_Derived_Record_Type
(N, Parent_Type, Derived_Type, Derive_Subps);
return;
Set_Mechanism (D_Minal, Default_Mechanism);
Set_Etype (D_Minal, Etype (Discrim));
Set_Scope (D_Minal, Current_Scope);
+ Set_Parent (D_Minal, Parent (Discrim));
Set_Discriminal (Discrim, D_Minal);
Set_Discriminal_Link (D_Minal, Discrim);
-- 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;
Analyze (Indic);
Set_Underlying_Full_View (Typ, Full_View (Subt));
+ Set_Is_Underlying_Full_View (Full_View (Subt));
end Build_Underlying_Full_View;
-------------------------------
-- operations used in dispatching selects since we always provide
-- automatic overridings for these subprograms.
- -- Also ignore this rule for convention CIL since .NET libraries
- -- do bizarre things with interfaces???
-
-- The partial view of T may have been a private extension, for
-- which inherited functions dispatching on result are abstract.
-- If the full view is a null extension, there is no need for
and then not Is_TSS (Subp, TSS_Stream_Input)
and then not Is_TSS (Subp, TSS_Stream_Output)
and then not Is_Abstract_Type (T)
- and then Convention (T) /= Convention_CIL
and then not Is_Predefined_Interface_Primitive (Subp)
-- Ada 2005 (AI-251): Do not consider hidden entities associated
Save_Homonym := Homonym (Priv);
case Ekind (Full_Base) is
- when E_Record_Type |
- E_Record_Subtype |
- Class_Wide_Kind |
- Private_Kind |
- Task_Kind |
- Protected_Kind =>
+ when Class_Wide_Kind
+ | Private_Kind
+ | Protected_Kind
+ | Task_Kind
+ | E_Record_Subtype
+ | E_Record_Type
+ =>
Copy_Node (Priv, Full);
Set_Has_Discriminants
-- 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);
Append : Boolean;
Item : Node_Id;
Next_Item : Node_Id;
+ Priv_Item : Node_Id;
begin
Item := First_Rep_Item (Full);
+ Priv_Item := First_Rep_Item (Priv);
-- If no existing rep items on full type, we can just link directly
-- to the list of items on the private type, if any exist.. Same if
if (No (Item)
or else Nkind (Item) /= N_Aspect_Specification
or else Entity (Item) = Full_Base)
- and then Present (First_Rep_Item (Priv))
+ and then Present (First_Rep_Item (Priv))
then
- Set_First_Rep_Item (Full, First_Rep_Item (Priv));
+ Set_First_Rep_Item (Full, Priv_Item);
-- Otherwise, search to the end of items currently linked to the full
-- subtype and append the private items to the end. However, if Priv
-- and Full already have the same list of rep items, then the append
-- is not done, as that would create a circularity.
+ --
+ -- The partial view may have a predicate and the rep item lists of
+ -- both views agree when inherited from the same ancestor. In that
+ -- case, simply propagate the list from one view to the other.
+ -- A more complex analysis needed here ???
+
+ elsif Present (Priv_Item)
+ and then Item = Next_Rep_Item (Priv_Item)
+ then
+ Set_First_Rep_Item (Full, Priv_Item);
- elsif Item /= First_Rep_Item (Priv) then
+ elsif Item /= Priv_Item then
Append := True;
loop
Next_Item := Next_Rep_Item (Item);
-- in particular when the full type is a scalar type for which an
-- anonymous base type is constructed.
+ -- The predicate functions are generated either at the freeze point
+ -- of the type or at the end of the visible part, and we must avoid
+ -- generating them twice.
+
if Has_Predicates (Priv) then
Set_Has_Predicates (Full);
+
+ if Present (Predicate_Function (Priv))
+ and then No (Predicate_Function (Full))
+ then
+ Set_Predicate_Function (Full, Predicate_Function (Priv));
+ end if;
end if;
if Has_Delayed_Aspects (Priv) then
Related_Nod : Node_Id;
For_Access : Boolean := False)
is
- E : constant Entity_Id := Entity (Subtype_Mark (S));
- T : Entity_Id;
- C : Node_Id;
- Elist : Elist_Id := New_Elmt_List;
+ E : Entity_Id := Entity (Subtype_Mark (S));
+ T : Entity_Id;
procedure Fixup_Bad_Constraint;
- -- This is called after finding a bad constraint, and after having
- -- posted an appropriate error message. The mission is to leave the
- -- entity T in as reasonable state as possible.
+ -- Called after finding a bad constraint, and after having posted an
+ -- appropriate error message. The goal is to leave type Def_Id in as
+ -- reasonable state as possible.
--------------------------
-- Fixup_Bad_Constraint --
Set_Error_Posted (Def_Id);
end Fixup_Bad_Constraint;
+ -- Local variables
+
+ C : Node_Id;
+ Constr : Elist_Id := New_Elmt_List;
+
-- Start of processing for Constrain_Discriminated_Type
begin
T := Designated_Type (T);
end if;
- -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal.
- -- Avoid generating an error for access-to-incomplete subtypes.
+ -- In an instance it may be necessary to retrieve the full view of a
+ -- type with unknown discriminants, or a full view with defaulted
+ -- discriminants. In other contexts the constraint is illegal.
+
+ if In_Instance
+ and then Is_Private_Type (T)
+ and then Present (Full_View (T))
+ and then
+ (Has_Unknown_Discriminants (T)
+ or else
+ (not Has_Discriminants (T)
+ and then Has_Discriminants (Full_View (T))
+ and then Present (Discriminant_Default_Value
+ (First_Discriminant (Full_View (T))))))
+ then
+ T := Full_View (T);
+ E := Full_View (E);
+ end if;
+
+ -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. Avoid
+ -- generating an error for access-to-incomplete subtypes.
if Ada_Version >= Ada_2005
and then Ekind (T) = E_Incomplete_Type
and then Nkind (Parent (S)) = N_Subtype_Declaration
and then not Is_Itype (Def_Id)
then
- -- A little sanity check, emit an error message if the type
- -- has discriminants to begin with. Type T may be a regular
- -- incomplete type or imported via a limited with clause.
+ -- A little sanity check: emit an error message if the type has
+ -- discriminants to begin with. Type T may be a regular incomplete
+ -- type or imported via a limited with clause.
if Has_Discriminants (T)
or else (From_Limited_With (T)
return;
end if;
- -- T may be an unconstrained subtype (e.g. a generic actual).
- -- Constraint applies to the base type.
+ -- T may be an unconstrained subtype (e.g. a generic actual). Constraint
+ -- applies to the base type.
T := Base_Type (T);
- Elist := Build_Discriminant_Constraints (T, S);
+ Constr := Build_Discriminant_Constraints (T, S);
-- If the list returned was empty we had an error in building the
-- discriminant constraint. We have also already signalled an error
-- in the incomplete type case
- if Is_Empty_Elmt_List (Elist) then
+ if Is_Empty_Elmt_List (Constr) then
Fixup_Bad_Constraint;
return;
end if;
- Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access);
+ Build_Discriminated_Subtype (T, Def_Id, Constr, Related_Nod, For_Access);
end Constrain_Discriminated_Type;
---------------------------
Set_Component_Size (T1, Component_Size (T2));
Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2));
- Set_Has_Protected (T1, Has_Protected (T2));
- Set_Has_Task (T1, Has_Task (T2));
+ Propagate_Concurrent_Flags (T1, T2);
Set_Is_Packed (T1, Is_Packed (T2));
Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2));
Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2));
-- Inherit the discriminants of the parent type
Add_Discriminants : declare
- Num_Disc : Int;
- Num_Gird : Int;
+ Num_Disc : Nat;
+ Num_Gird : Nat;
begin
Num_Disc := 0;
Governed_By => Assoc_List,
Into => Comp_List,
Report_Errors => Errors);
- pragma Assert (not Errors);
+ pragma Assert (not Errors
+ or else Serious_Errors_Detected > 0);
Create_All_Components;
-----------------------
procedure Derive_Subprogram
- (New_Subp : in out Entity_Id;
+ (New_Subp : out Entity_Id;
Parent_Subp : Entity_Id;
Derived_Type : Entity_Id;
Parent_Type : Entity_Id;
-- of the derived type are not relevant, and thus we can use
-- the base type for the formals. However, the return type may be
-- used in a context that requires that the proper static bounds
- -- be used (a case statement, for example) and for those cases
+ -- be used (a case statement, for example) and for those cases
-- we must use the derived type (first subtype), not its base.
-- If the derived_type_definition has no constraints, we know that
or else Is_Internal (Parent_Subp)
or else Is_Private_Overriding
or else Is_Internal_Name (Chars (Parent_Subp))
- or else Nam_In (Chars (Parent_Subp), Name_Initialize,
- Name_Adjust,
- Name_Finalize)
+ or else (Is_Controlled (Parent_Type)
+ and then Nam_In (Chars (Parent_Subp), Name_Adjust,
+ Name_Finalize,
+ Name_Initialize))
then
Set_Derived_Name;
then
Set_Derived_Name;
- -- Otherwise, the type is inheriting a private operation, so enter
- -- it with a special name so it can't be overridden.
+ -- Otherwise, the type is inheriting a private operation, so enter it
+ -- with a special name so it can't be overridden.
else
Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P'));
Set_Alias (New_Subp, Actual_Subp);
end if;
- -- Inherit the "ghostness" from the parent subprogram
-
- if Is_Ghost_Entity (Alias (New_Subp)) then
- Set_Is_Ghost_Entity (New_Subp);
- end if;
-
-- Derived subprograms of a tagged type must inherit the convention
-- of the parent subprogram (a requirement of AI-117). Derived
-- subprograms of untagged types simply get convention Ada by default.
-- the list of primitives of Derived_Type exactly in the same order.
procedure Derive_Interface_Subprogram
- (New_Subp : in out Entity_Id;
+ (New_Subp : out Entity_Id;
Subp : Entity_Id;
Actual_Subp : Entity_Id);
-- Derive New_Subp from the ultimate alias of the parent subprogram Subp
-- Actual_Subp is the actual subprogram corresponding with the generic
-- subprogram Subp.
+ ------------------------
+ -- Check_Derived_Type --
+ ------------------------
+
function Check_Derived_Type return Boolean is
E : Entity_Id;
Elmt : Elmt_Id;
begin
-- Traverse list of entities in the current scope searching for
- -- an incomplete type whose full-view is derived type
+ -- an incomplete type whose full-view is derived type.
E := First_Entity (Scope (Derived_Type));
while Present (E) and then E /= Derived_Type loop
---------------------------------
procedure Derive_Interface_Subprogram
- (New_Subp : in out Entity_Id;
+ (New_Subp : out Entity_Id;
Subp : Entity_Id;
Actual_Subp : Entity_Id)
is
-- Given that this new interface entity corresponds with a primitive
-- of the parent that was not overridden we must leave it associated
-- with its parent primitive to ensure that it will share the same
- -- dispatch table slot when overridden.
+ -- dispatch table slot when overridden. We must set the Alias to Subp
+ -- (instead of Iface_Subp), and we must fix Is_Abstract_Subprogram
+ -- (in case we inherited Subp from Iface_Type via a nonabstract
+ -- generic formal type).
if No (Actual_Subp) then
Set_Alias (New_Subp, Subp);
+ declare
+ T : Entity_Id := Find_Dispatching_Type (Subp);
+ begin
+ while Etype (T) /= T loop
+ if Is_Generic_Type (T) and then not Is_Abstract_Type (T) then
+ Set_Is_Abstract_Subprogram (New_Subp, False);
+ exit;
+ end if;
+
+ T := Etype (T);
+ end loop;
+ end;
+
-- For instantiations this is not needed since the previous call to
-- Derive_Subprogram leaves the entity well decorated.
elsif Protected_Present (Iface_Def) then
Error_Msg_NE
- ("descendant of& must be declared"
- & " as a protected interface",
- N, Parent_Type);
+ ("descendant of & must be declared as a protected "
+ & "interface", N, Parent_Type);
elsif Synchronized_Present (Iface_Def) then
Error_Msg_NE
- ("descendant of& must be declared"
- & " as a synchronized interface",
- N, Parent_Type);
+ ("descendant of & must be declared as a synchronized "
+ & "interface", N, Parent_Type);
elsif Task_Present (Iface_Def) then
Error_Msg_NE
- ("descendant of& must be declared as a task interface",
+ ("descendant of & must be declared as a task interface",
N, Parent_Type);
else
Error_Msg_N
- ("(Ada 2005) limited interface cannot "
- & "inherit from non-limited interface", Indic);
+ ("(Ada 2005) limited interface cannot inherit from "
+ & "non-limited interface", Indic);
end if;
-- Ada 2005 (AI-345): Non-limited interfaces can only inherit
elsif Protected_Present (Iface_Def) then
Error_Msg_NE
- ("descendant of& must be declared"
- & " as a protected interface",
- N, Parent_Type);
+ ("descendant of & must be declared as a protected "
+ & "interface", N, Parent_Type);
elsif Synchronized_Present (Iface_Def) then
Error_Msg_NE
- ("descendant of& must be declared"
- & " as a synchronized interface",
- N, Parent_Type);
+ ("descendant of & must be declared as a synchronized "
+ & "interface", N, Parent_Type);
elsif Task_Present (Iface_Def) then
Error_Msg_NE
- ("descendant of& must be declared as a task interface",
+ ("descendant of & must be declared as a task interface",
N, Parent_Type);
else
null;
and then not Is_Interface (Parent_Type)
then
Error_Msg_N
- ("parent type of a record extension cannot be "
- & "a synchronized tagged type (RM 3.9.1 (3/1))", N);
+ ("parent type of a record extension cannot be a synchronized "
+ & "tagged type (RM 3.9.1 (3/1))", N);
Set_Etype (T, Any_Type);
return;
end if;
function Find_Type_Name (N : Node_Id) return Entity_Id is
Id : constant Entity_Id := Defining_Identifier (N);
- Prev : Entity_Id;
New_Id : Entity_Id;
+ Prev : Entity_Id;
Prev_Par : Node_Id;
procedure Check_Duplicate_Aspects;
-- Check that aspects specified in a completion have not been specified
- -- already in the partial view. Type_Invariant and others can be
- -- specified on either view but never on both.
+ -- already in the partial view.
procedure Tag_Mismatch;
- -- Diagnose a tagged partial view whose full view is untagged.
- -- We post the message on the full view, with a reference to
- -- the previous partial view. The partial view can be private
- -- or incomplete, and these are handled in a different manner,
- -- so we determine the position of the error message from the
- -- respective slocs of both.
+ -- Diagnose a tagged partial view whose full view is untagged. We post
+ -- the message on the full view, with a reference to the previous
+ -- partial view. The partial view can be private or incomplete, and
+ -- these are handled in a different manner, so we determine the position
+ -- of the error message from the respective slocs of both.
-----------------------------
-- Check_Duplicate_Aspects --
-----------------------------
+
procedure Check_Duplicate_Aspects is
- Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par);
- Full_Aspects : constant List_Id := Aspect_Specifications (N);
- F_Spec, P_Spec : Node_Id;
+ function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id;
+ -- Return the corresponding aspect of the partial view which matches
+ -- the aspect id of Asp. Return Empty is no such aspect exists.
- begin
- if Present (Prev_Aspects) and then Present (Full_Aspects) then
- F_Spec := First (Full_Aspects);
- while Present (F_Spec) loop
- P_Spec := First (Prev_Aspects);
- while Present (P_Spec) loop
- if Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec))
- then
- Error_Msg_N
- ("aspect already specified in private declaration",
- F_Spec);
- Remove (F_Spec);
- return;
+ -----------------------------
+ -- Get_Partial_View_Aspect --
+ -----------------------------
+
+ function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id is
+ Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp);
+ Prev_Asps : constant List_Id := Aspect_Specifications (Prev_Par);
+ Prev_Asp : Node_Id;
+
+ begin
+ if Present (Prev_Asps) then
+ Prev_Asp := First (Prev_Asps);
+ while Present (Prev_Asp) loop
+ if Get_Aspect_Id (Prev_Asp) = Asp_Id then
+ return Prev_Asp;
end if;
- Next (P_Spec);
+ Next (Prev_Asp);
end loop;
+ end if;
+
+ return Empty;
+ end Get_Partial_View_Aspect;
+
+ -- Local variables
+
+ Full_Asps : constant List_Id := Aspect_Specifications (N);
+ Full_Asp : Node_Id;
+ Part_Asp : Node_Id;
+
+ -- Start of processing for Check_Duplicate_Aspects
+
+ begin
+ if Present (Full_Asps) then
+ Full_Asp := First (Full_Asps);
+ while Present (Full_Asp) loop
+ Part_Asp := Get_Partial_View_Aspect (Full_Asp);
- Next (F_Spec);
+ -- An aspect and its class-wide counterpart are two distinct
+ -- aspects and may apply to both views of an entity.
+
+ if Present (Part_Asp)
+ and then Class_Present (Part_Asp) = Class_Present (Full_Asp)
+ then
+ Error_Msg_N
+ ("aspect already specified in private declaration",
+ Full_Asp);
+
+ Remove (Full_Asp);
+ return;
+ end if;
+
+ if Has_Discriminants (Prev)
+ and then not Has_Unknown_Discriminants (Prev)
+ and then Get_Aspect_Id (Full_Asp) =
+ Aspect_Implicit_Dereference
+ then
+ Error_Msg_N
+ ("cannot specify aspect if partial view has known "
+ & "discriminants", Full_Asp);
+ end if;
+
+ Next (Full_Asp);
end loop;
end if;
end Check_Duplicate_Aspects;
Set_Ekind (Id, Ekind (Prev)); -- will be reset later
Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
- -- The type of the classwide type is the current Id. Previously
+ -- Type of the class-wide type is the current Id. Previously
-- this was not done for private declarations because of order-
- -- of elaboration issues in the back-end, but gigi now handles
+ -- of-elaboration issues in the back end, but gigi now handles
-- this properly.
Set_Etype (Class_Wide_Type (Id), Id);
is
begin
case T_Kind is
- when Enumeration_Kind |
- Integer_Kind =>
+ when Enumeration_Kind
+ | Integer_Kind
+ =>
return Constraint_Kind = N_Range_Constraint;
when Decimal_Fixed_Point_Kind =>
return Nkind_In (Constraint_Kind, N_Digits_Constraint,
N_Range_Constraint);
- when Access_Kind |
- Array_Kind |
- E_Record_Type |
- E_Record_Subtype |
- Class_Wide_Kind |
- E_Incomplete_Type |
- Private_Kind |
- Concurrent_Kind =>
+ when Access_Kind
+ | Array_Kind
+ | Class_Wide_Kind
+ | Concurrent_Kind
+ | Private_Kind
+ | E_Incomplete_Type
+ | E_Record_Subtype
+ | E_Record_Type
+ =>
return Constraint_Kind = N_Index_Or_Discriminant_Constraint;
when others =>
else
Original_Type := Scope (Original_Comp);
- Type_Scope := Scope (Base_Type (Scope (C)));
+ Type_Scope := Scope (Base_Type (Scope (C)));
end if;
-- This test only concerns tagged types
then
return True;
- -- In the body of an instantiation, no need to check for the visibility
- -- of a component.
+ -- In the body of an instantiation, check the visibility of a component
+ -- in case it has a homograph that is a primitive operation of a private
+ -- type which was not visible in the generic unit.
+
+ -- Should Is_Prefixed_Call be propagated from template to instance???
elsif In_Instance_Body then
- return True;
+ if not Is_Tagged_Type (Original_Type)
+ or else not Is_Private_Type (Original_Type)
+ then
+ return True;
+
+ else
+ declare
+ Subp_Elmt : Elmt_Id;
+
+ begin
+ Subp_Elmt := First_Elmt (Primitive_Operations (Original_Type));
+ while Present (Subp_Elmt) loop
+
+ -- The component is hidden by a primitive operation
+
+ if Chars (Node (Subp_Elmt)) = Chars (C) then
+ return False;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+
+ return True;
+ end;
+ end if;
-- If the component has been declared in an ancestor which is currently
-- a private type, then it is not visible. The same applies if the
Set_Freeze_Node (CW_Type, Empty);
-- Customize the class-wide type: It has no prim. op., it cannot be
- -- abstract and its Etype points back to the specific root type.
+ -- abstract, its Etype points back to the specific root type, and it
+ -- cannot have any invariants.
Set_Ekind (CW_Type, E_Class_Wide_Type);
Set_Is_Tagged_Type (CW_Type, True);
Set_Is_Constrained (CW_Type, False);
Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T));
Set_Default_SSO (CW_Type);
+ Set_Has_Inheritable_Invariants (CW_Type, False);
+ Set_Has_Inherited_Invariants (CW_Type, False);
+ Set_Has_Own_Invariants (CW_Type, False);
if Ekind (T) = E_Class_Wide_Subtype then
Set_Etype (CW_Type, Etype (Base_Type (T)));
-- The index is given by a subtype with a range constraint
- T := Base_Type (Entity (Subtype_Mark (N)));
+ T := Base_Type (Entity (Subtype_Mark (N)));
if not Is_Discrete_Type (T) then
Error_Msg_N ("discrete type required for range", N);
is
begin
-- An object of a limited interface type can be initialized with any
- -- expression of a nonlimited descendant type.
+ -- expression of a nonlimited descendant type. However this does not
+ -- apply if this is a view conversion of some other expression. This
+ -- is checked below.
if Is_Class_Wide_Type (Typ)
and then Is_Limited_Interface (Typ)
and then not Is_Limited_Type (Etype (Exp))
+ and then Nkind (Exp) /= N_Type_Conversion
then
return True;
end if;
-- dereference. The function may also be parameterless, in which case
-- the source node is just an identifier.
+ -- A branch of a conditional expression may have been removed if the
+ -- condition is statically known. This happens during expansion, and
+ -- thus will not happen if previous errors were encountered. The check
+ -- will have been performed on the chosen branch, which replaces the
+ -- original conditional expression.
+
+ if No (Exp) then
+ return True;
+ end if;
+
case Nkind (Original_Node (Exp)) is
- when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op =>
+ when N_Aggregate
+ | N_Extension_Aggregate
+ | N_Function_Call
+ | N_Op
+ =>
return True;
when N_Identifier =>
-- A return statement for a build-in-place function returning a
-- synchronized type also introduces an unchecked conversion.
- when N_Type_Conversion |
- N_Unchecked_Type_Conversion =>
+ when N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ =>
return not Comes_From_Source (Exp)
and then
OK_For_Limited_Init_In_05
(Typ, Expression (Original_Node (Exp)));
- when N_Indexed_Component |
- N_Selected_Component |
- N_Explicit_Dereference =>
+ when N_Explicit_Dereference
+ | N_Indexed_Component
+ | N_Selected_Component
+ =>
return Nkind (Exp) = N_Function_Call;
-- A use of 'Input is a function call, hence allowed. Normally the
end if;
end if;
- -- A discriminant cannot be effectively volatile. This check is only
- -- relevant when SPARK_Mode is on as it is not standard Ada legality
- -- rule (SPARK RM 7.1.3(6)).
+ -- A discriminant cannot be effectively volatile (SPARK RM 7.1.3(6)).
+ -- This check is relevant only when SPARK_Mode is on as it is not a
+ -- standard Ada legality rule.
if SPARK_Mode = On
and then Is_Effectively_Volatile (Defining_Identifier (Discr))
-- Process_Full_View --
-----------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is
procedure Collect_Implemented_Interfaces
(Typ : Entity_Id;
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);
+
-- First some sanity checks that must be done after semantic
-- decoration of the full view and thus cannot be placed with other
-- similar checks in Find_Type_Name
-- error situation [7.3(8)].
if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
- return;
+ goto Leave;
-- Ada 2005 (AI-251): Interfaces in the full type can be given in
-- any order. Therefore we don't have to check that its parent must
and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
then
Error_Msg_N
- ("parent of full type must descend from parent"
- & " of private extension", Full_Indic);
+ ("parent of full type must descend from parent of private "
+ & "extension", Full_Indic);
-- First check a formal restriction, and then proceed with checking
-- Ada rules. Since the formal restriction is not a serious error, we
while Present (Priv_Discr) and then Present (Full_Discr) loop
if Original_Record_Component (Priv_Discr) =
Original_Record_Component (Full_Discr)
- or else
- Corresponding_Discriminant (Priv_Discr) =
- Corresponding_Discriminant (Full_Discr)
+ or else
+ Corresponding_Discriminant (Priv_Discr) =
+ Corresponding_Discriminant (Full_Discr)
then
null;
else
if Present (Priv_Discr) or else Present (Full_Discr) then
Error_Msg_N
- ("full view must inherit discriminants of the parent"
- & " type used in the private extension", Full_Indic);
+ ("full view must inherit discriminants of the parent "
+ & "type used in the private extension", Full_Indic);
elsif Priv_Constr and then not Full_Constr then
Error_Msg_N
-- known or unknown discriminants, then the full type
-- declaration shall define a definite subtype.
- elsif not Has_Unknown_Discriminants (Priv_T)
+ elsif not Has_Unknown_Discriminants (Priv_T)
and then not Has_Discriminants (Priv_T)
and then not Is_Constrained (Full_T)
then
Error_Msg_N
- ("full view must define a constrained type if partial view"
- & " has no discriminants", Full_T);
+ ("full view must define a constrained type if partial view "
+ & "has no discriminants", Full_T);
end if;
-- ??????? Do we implement the following properly ?????
(Subp_Id => Prim,
Obj_Typ => Conc_Typ,
Formals =>
- Parameter_Specifications (
- Parent (Prim))));
+ Parameter_Specifications
+ (Parent (Prim))));
Insert_After (Curr_Nod, Wrap_Spec);
Curr_Nod := Wrap_Spec;
Analyze (Wrap_Spec);
+
+ -- Remove the wrapper from visibility to avoid
+ -- spurious conflict with the wrapped entity.
+
+ Set_Is_Immediately_Visible
+ (Defining_Entity (Specification (Wrap_Spec)),
+ False);
end if;
Next_Elmt (Prim_Elmt);
end loop;
- return;
+ goto Leave;
end;
-- For non-concurrent types, transfer explicit primitives, but
end if;
elsif Is_Dispatching_Operation (Prim)
- and then Disp_Typ /= Full_T
+ and then Disp_Typ /= Full_T
then
-- Verify that it is not otherwise controlled by a
Set_Class_Wide_Type
(Base_Type (Full_T), Class_Wide_Type (Priv_T));
- Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
- Set_Has_Protected
- (Class_Wide_Type (Priv_T), Has_Protected (Full_T));
+ Propagate_Concurrent_Flags (Class_Wide_Type (Priv_T), Full_T);
end if;
end;
end if;
Set_Has_Specified_Stream_Output (Full_T);
end if;
- -- Propagate the attributes related to pragma Default_Initial_Condition
- -- from the private to the full view. Note that both flags are mutually
- -- exclusive.
-
- if Has_Default_Init_Cond (Priv_T)
- or else Has_Inherited_Default_Init_Cond (Priv_T)
- then
- Propagate_Default_Init_Cond_Attributes
- (From_Typ => Priv_T,
- To_Typ => Full_T,
- Private_To_Full_View => True);
-
- -- In the case where the full view is derived from another private type,
- -- the attributes related to pragma Default_Initial_Condition must be
- -- propagated from the full to the private view to maintain consistency
- -- of views.
-
- -- package Pack is
- -- type Parent_Typ is private
- -- with Default_Initial_Condition ...;
- -- private
- -- type Parent_Typ is ...;
- -- end Pack;
-
- -- with Pack; use Pack;
- -- package Pack_2 is
- -- type Deriv_Typ is private; -- must inherit
- -- private
- -- type Deriv_Typ is new Parent_Typ; -- must inherit
- -- end Pack_2;
-
- elsif Has_Default_Init_Cond (Full_T)
- or else Has_Inherited_Default_Init_Cond (Full_T)
- then
- Propagate_Default_Init_Cond_Attributes
- (From_Typ => Full_T,
- To_Typ => Priv_T,
- Private_To_Full_View => True);
- end if;
-
- if Is_Ghost_Entity (Priv_T) then
+ -- Propagate Default_Initial_Condition-related attributes from the
+ -- partial view to the full view and its base type.
- -- The Ghost policy in effect at the point of declaration and at the
- -- point of completion must match (SPARK RM 6.9(14)).
+ Propagate_DIC_Attributes (Full_T, From_Typ => Priv_T);
+ Propagate_DIC_Attributes (Base_Type (Full_T), From_Typ => Priv_T);
- Check_Ghost_Completion (Priv_T, Full_T);
+ -- Propagate invariant-related attributes from the partial view to the
+ -- full view and its base type.
- -- In the case where the private view of a tagged type lacks a parent
- -- type and is subject to pragma Ghost, ensure that the parent type
- -- specified by the full view is also Ghost (SPARK RM 6.9(9)).
+ Propagate_Invariant_Attributes (Full_T, From_Typ => Priv_T);
+ Propagate_Invariant_Attributes (Base_Type (Full_T), From_Typ => Priv_T);
- if Is_Derived_Type (Full_T) then
- Check_Ghost_Derivation (Full_T);
- end if;
-
- -- Propagate the attributes related to pragma Ghost from the private
- -- to the full view.
-
- Mark_Full_View_As_Ghost (Priv_T, Full_T);
- end if;
-
- -- Propagate invariants to full type
-
- if Has_Invariants (Priv_T) then
- Set_Has_Invariants (Full_T);
- Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T));
- end if;
-
- if Has_Inheritable_Invariants (Priv_T) then
- Set_Has_Inheritable_Invariants (Full_T);
- end if;
-
- -- Check hidden inheritance of class-wide type invariants
+ -- AI12-0041: Detect an attempt to inherit a class-wide type invariant
+ -- in the full view without advertising the inheritance in the partial
+ -- view. This can only occur when the partial view has no parent type
+ -- and the full view has an interface as a parent. Any other scenarios
+ -- are illegal because implemented interfaces must match between the
+ -- two views.
- if Ada_Version >= Ada_2012
- and then not Has_Inheritable_Invariants (Full_T)
- and then In_Private_Part (Current_Scope)
- and then Has_Interfaces (Full_T)
- then
+ if Is_Tagged_Type (Priv_T) and then Is_Tagged_Type (Full_T) then
declare
- Ifaces : Elist_Id;
- AI : Elmt_Id;
+ Full_Par : constant Entity_Id := Etype (Full_T);
+ Priv_Par : constant Entity_Id := Etype (Priv_T);
begin
- Collect_Interfaces (Full_T, Ifaces, Exclude_Parents => True);
-
- AI := First_Elmt (Ifaces);
- while Present (AI) loop
- if Has_Inheritable_Invariants (Node (AI)) then
- Error_Msg_N
- ("hidden inheritance of class-wide type invariants " &
- "not allowed", N);
- exit;
- end if;
-
- Next_Elmt (AI);
- end loop;
+ if not Is_Interface (Priv_Par)
+ and then Is_Interface (Full_Par)
+ and then Has_Inheritable_Invariants (Full_Par)
+ then
+ Error_Msg_N
+ ("hidden inheritance of class-wide type invariants not "
+ & "allowed", N);
+ end if;
end;
end if;
-- built. Still it is a cheap check and seems safer to make it.
if Has_Predicates (Priv_T) then
+ Set_Has_Predicates (Full_T);
+
if Present (Predicate_Function (Priv_T)) then
Set_Predicate_Function (Full_T, Predicate_Function (Priv_T));
end if;
-
- Set_Has_Predicates (Full_T);
end if;
+
+ <<Leave>>
+ Restore_Ghost_Mode (Mode);
end Process_Full_View;
-----------------------------------
May_Have_Null_Exclusion : Boolean;
- procedure Check_Incomplete (T : Entity_Id);
+ procedure Check_Incomplete (T : Node_Id);
-- Called to verify that an incomplete type is not used prematurely
----------------------
-- Check_Incomplete --
----------------------
- procedure Check_Incomplete (T : Entity_Id) is
+ procedure Check_Incomplete (T : Node_Id) is
begin
-- Ada 2005 (AI-412): Incomplete subtypes are legal
Constrain_Integer (Def_Id, S);
Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
- when E_Record_Type |
- E_Record_Subtype |
- Class_Wide_Kind |
- E_Incomplete_Type =>
+ when Class_Wide_Kind
+ | E_Incomplete_Type
+ | E_Record_Subtype
+ | E_Record_Type
+ =>
Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
if Ekind (Def_Id) = E_Incomplete_Type then
when Private_Kind =>
Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
- Set_Private_Dependents (Def_Id, New_Elmt_List);
+
+ -- The base type may be private but Def_Id may be a full view
+ -- in an instance.
+
+ if Is_Private_Type (Def_Id) then
+ Set_Private_Dependents (Def_Id, New_Elmt_List);
+ end if;
-- In case of an invalid constraint prevent further processing
-- since the type constructed is missing expected fields.
end if;
end Process_Subtype;
- --------------------------------------------
- -- Propagate_Default_Init_Cond_Attributes --
- --------------------------------------------
-
- procedure Propagate_Default_Init_Cond_Attributes
- (From_Typ : Entity_Id;
- To_Typ : Entity_Id;
- Parent_To_Derivation : Boolean := False;
- Private_To_Full_View : Boolean := False)
- is
- procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id);
- -- Remove the default initial procedure (if any) from the rep chain of
- -- type Typ.
-
- ----------------------------------------
- -- Remove_Default_Init_Cond_Procedure --
- ----------------------------------------
-
- procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id) is
- Found : Boolean := False;
- Prev : Entity_Id;
- Subp : Entity_Id;
-
- begin
- Prev := Typ;
- Subp := Subprograms_For_Type (Typ);
- while Present (Subp) loop
- if Is_Default_Init_Cond_Procedure (Subp) then
- Found := True;
- exit;
- end if;
-
- Prev := Subp;
- Subp := Subprograms_For_Type (Subp);
- end loop;
-
- if Found then
- Set_Subprograms_For_Type (Prev, Subprograms_For_Type (Subp));
- Set_Subprograms_For_Type (Subp, Empty);
- end if;
- end Remove_Default_Init_Cond_Procedure;
-
- -- Local variables
-
- Inherit_Procedure : Boolean := False;
-
- -- Start of processing for Propagate_Default_Init_Cond_Attributes
-
- begin
- if Has_Default_Init_Cond (From_Typ) then
-
- -- A derived type inherits the attributes from its parent type
-
- if Parent_To_Derivation then
- Set_Has_Inherited_Default_Init_Cond (To_Typ);
-
- -- A full view shares the attributes with its private view
-
- else
- Set_Has_Default_Init_Cond (To_Typ);
- end if;
-
- Inherit_Procedure := True;
-
- -- Due to the order of expansion, a derived private type is processed
- -- by two routines which both attempt to set the attributes related
- -- to pragma Default_Initial_Condition - Build_Derived_Type and then
- -- Process_Full_View.
-
- -- package Pack is
- -- type Parent_Typ is private
- -- with Default_Initial_Condition ...;
- -- private
- -- type Parent_Typ is ...;
- -- end Pack;
-
- -- with Pack; use Pack;
- -- package Pack_2 is
- -- type Deriv_Typ is private
- -- with Default_Initial_Condition ...;
- -- private
- -- type Deriv_Typ is new Parent_Typ;
- -- end Pack_2;
-
- -- When Build_Derived_Type operates, it sets the attributes on the
- -- full view without taking into account that the private view may
- -- define its own default initial condition procedure. This becomes
- -- apparent in Process_Full_View which must undo some of the work by
- -- Build_Derived_Type and propagate the attributes from the private
- -- to the full view.
-
- if Private_To_Full_View then
- Set_Has_Inherited_Default_Init_Cond (To_Typ, False);
- Remove_Default_Init_Cond_Procedure (To_Typ);
- end if;
-
- -- A type must inherit the default initial condition procedure from a
- -- parent type when the parent itself is inheriting the procedure or
- -- when it is defining one. This circuitry is also used when dealing
- -- with the private / full view of a type.
-
- elsif Has_Inherited_Default_Init_Cond (From_Typ)
- or (Parent_To_Derivation
- and Present (Get_Pragma
- (From_Typ, Pragma_Default_Initial_Condition)))
- then
- Set_Has_Inherited_Default_Init_Cond (To_Typ);
- Inherit_Procedure := True;
- end if;
-
- if Inherit_Procedure
- and then No (Default_Init_Cond_Procedure (To_Typ))
- then
- Set_Default_Init_Cond_Procedure
- (To_Typ, Default_Init_Cond_Procedure (From_Typ));
- end if;
- end Propagate_Default_Init_Cond_Attributes;
-
-----------------------------
-- Record_Type_Declaration --
-----------------------------
Init_Component_Location (Component);
end if;
- if Has_Task (Etype (Component)) then
- Set_Has_Task (T);
- end if;
-
- if Has_Protected (Etype (Component)) then
- Set_Has_Protected (T);
- end if;
+ Propagate_Concurrent_Flags (T, Etype (Component));
if Ekind (Component) /= E_Component then
null;
R : Node_Id;
Subt : Entity_Id)
is
- Kind : constant Entity_Kind := Ekind (Def_Id);
+ Kind : constant Entity_Kind := Ekind (Def_Id);
begin
-- Defend against previous error
projects / gcc.git / blobdiff