X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=gcc%2Fada%2Fsem_ch3.adb;h=1f774c00a62ece2d3284ff60460d45e25acad08d;hb=d43584ca123f03c24aa7e59a43ecf2bd3a6e4863;hp=62cc79105a148f546ab37a3e8f97ff00a4dbcbc3;hpb=113522092bb252b2b5ee9e51ebd36d59677b1199;p=gcc.git diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 62cc79105a1..1f774c00a62 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -23,64 +23,63 @@ -- -- ------------------------------------------------------------------------------ -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 @@ -93,16 +92,6 @@ 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; @@ -658,17 +647,6 @@ package body Sem_Ch3 is -- 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; @@ -1355,7 +1333,9 @@ package body Sem_Ch3 is 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 @@ -1427,7 +1407,7 @@ package body Sem_Ch3 is 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 @@ -1449,8 +1429,9 @@ package body Sem_Ch3 is -- 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 @@ -1869,7 +1850,6 @@ package body Sem_Ch3 is when others => return False; - end case; end Contains_POC; @@ -2176,16 +2156,45 @@ package body Sem_Ch3 is -- (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 -- @@ -2200,6 +2209,135 @@ package body Sem_Ch3 is 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 -- -------------------------------------- @@ -2281,10 +2419,37 @@ package body Sem_Ch3 is 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 -- -------------------------------- @@ -2301,16 +2466,34 @@ package body Sem_Ch3 is 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 @@ -2357,12 +2540,14 @@ package body Sem_Ch3 is -- (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); @@ -2378,19 +2563,58 @@ package body Sem_Ch3 is 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. @@ -2410,51 +2634,98 @@ package body Sem_Ch3 is 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 @@ -2464,15 +2735,6 @@ package body Sem_Ch3 is 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. @@ -2483,71 +2745,52 @@ package body Sem_Ch3 is 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; @@ -2556,9 +2799,8 @@ package body Sem_Ch3 is ----------------------------------- 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; @@ -2568,6 +2810,10 @@ package body Sem_Ch3 is 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 @@ -2576,8 +2822,112 @@ package body Sem_Ch3 is -- 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 -- @@ -2616,26 +2966,11 @@ package body Sem_Ch3 is 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. @@ -2768,12 +3103,10 @@ package body Sem_Ch3 is when others => raise Program_Error; - end case; end if; if Etype (T) = Any_Type then - Restore_Globals; return; end if; @@ -2783,13 +3116,6 @@ package body Sem_Ch3 is 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)); @@ -2882,9 +3208,9 @@ package body Sem_Ch3 is 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); @@ -2915,7 +3241,11 @@ package body Sem_Ch3 is 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; ---------------------------------- @@ -2923,18 +3253,12 @@ package body Sem_Ch3 is ---------------------------------- 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 @@ -2951,13 +3275,6 @@ package body Sem_Ch3 is 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. @@ -2968,27 +3285,20 @@ package body Sem_Ch3 is 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; ----------------------------------- @@ -3035,10 +3345,9 @@ package body Sem_Ch3 is -- 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); @@ -3063,47 +3372,16 @@ package body Sem_Ch3 is -------------------------------- 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 @@ -3113,8 +3391,6 @@ package body Sem_Ch3 is Set_Etype (Id, Universal_Integer); Set_Ekind (Id, E_Named_Integer); Set_Is_Frozen (Id, True); - - Restore_Globals; return; end if; @@ -3171,7 +3447,7 @@ package body Sem_Ch3 is 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); @@ -3216,8 +3492,6 @@ package body Sem_Ch3 is Set_Ekind (Id, E_Constant); Set_Never_Set_In_Source (Id, True); Set_Is_True_Constant (Id, True); - - Restore_Globals; return; end if; @@ -3232,183 +3506,20 @@ package body Sem_Ch3 is 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; @@ -3421,9 +3532,9 @@ package body Sem_Ch3 is 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; @@ -3437,9 +3548,6 @@ package body Sem_Ch3 is -- Any other relevant delayed aspects on object declarations ??? - procedure Restore_Globals; - -- Restore the values of all saved global variables - ----------------- -- Count_Tasks -- ----------------- @@ -3518,14 +3626,11 @@ package body Sem_Ch3 is 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 @@ -3574,19 +3679,30 @@ package body Sem_Ch3 is 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'); @@ -3594,7 +3710,7 @@ package body Sem_Ch3 is 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); @@ -3631,13 +3747,13 @@ package body Sem_Ch3 is 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 @@ -3731,9 +3847,7 @@ package body Sem_Ch3 is -- 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 @@ -3745,12 +3859,21 @@ package body Sem_Ch3 is -- 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. @@ -3839,11 +3962,18 @@ package body Sem_Ch3 is -- 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); @@ -3866,8 +3996,7 @@ package body Sem_Ch3 is 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 @@ -3947,12 +4076,16 @@ package body Sem_Ch3 is -- 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; @@ -3974,14 +4107,15 @@ package body Sem_Ch3 is -- 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) @@ -3995,8 +4129,16 @@ package body Sem_Ch3 is 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 @@ -4112,23 +4254,6 @@ package body Sem_Ch3 is 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, @@ -4138,12 +4263,28 @@ package body Sem_Ch3 is 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; @@ -4159,7 +4300,10 @@ package body Sem_Ch3 is 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); @@ -4189,9 +4333,10 @@ package body Sem_Ch3 is 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; @@ -4293,24 +4438,6 @@ package body Sem_Ch3 is 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 @@ -4445,7 +4572,7 @@ package body Sem_Ch3 is -- 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 @@ -4492,15 +4619,6 @@ package body Sem_Ch3 is 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; - <> -- Initialize the refined state of a variable here because this is a -- common destination for legal and illegal object declarations. @@ -4522,7 +4640,9 @@ package body Sem_Ch3 is Check_No_Hidden_State (Id); end if; - Restore_Globals; + if Mode_Set then + Restore_Ghost_Mode (Mode); + end if; end Analyze_Object_Declaration; --------------------------- @@ -4543,19 +4663,14 @@ package body Sem_Ch3 is ------------------------------------------- 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 @@ -4617,8 +4732,8 @@ package body Sem_Ch3 is 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); @@ -4639,7 +4754,6 @@ package body Sem_Ch3 is 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; @@ -4652,9 +4766,8 @@ package body Sem_Ch3 is 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)); @@ -4667,13 +4780,35 @@ package body Sem_Ch3 is 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 @@ -4695,33 +4830,29 @@ package body Sem_Ch3 is (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 @@ -4769,11 +4900,6 @@ package body Sem_Ch3 is 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; --------------------------------- @@ -4784,18 +4910,11 @@ package body Sem_Ch3 is (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); @@ -4872,6 +4991,24 @@ package body Sem_Ch3 is 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 @@ -4943,8 +5080,8 @@ package body Sem_Ch3 is 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); @@ -4983,6 +5120,9 @@ package body Sem_Ch3 is 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)); @@ -5013,7 +5153,9 @@ package body Sem_Ch3 is 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 @@ -5168,7 +5310,7 @@ package body Sem_Ch3 is 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: @@ -5230,11 +5372,36 @@ package body Sem_Ch3 is 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); @@ -5289,9 +5456,9 @@ package body Sem_Ch3 is 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), @@ -5359,29 +5526,7 @@ package body Sem_Ch3 is 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); @@ -5394,10 +5539,29 @@ package body Sem_Ch3 is 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; -------------------------------- @@ -5500,13 +5664,13 @@ package body Sem_Ch3 is 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 @@ -5562,8 +5726,8 @@ package body Sem_Ch3 is 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'); @@ -5689,23 +5853,20 @@ package body Sem_Ch3 is -- 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 @@ -5718,8 +5879,7 @@ package body Sem_Ch3 is 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 @@ -5861,9 +6021,10 @@ package body Sem_Ch3 is 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); @@ -5908,7 +6069,7 @@ package body Sem_Ch3 is 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 @@ -5956,15 +6117,20 @@ package body Sem_Ch3 is 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 @@ -6009,16 +6175,24 @@ package body Sem_Ch3 is 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; @@ -6071,6 +6245,11 @@ package body Sem_Ch3 is 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)); @@ -6102,16 +6281,6 @@ package body Sem_Ch3 is 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; @@ -6123,6 +6292,7 @@ package body Sem_Ch3 is -- ??? 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) @@ -6176,12 +6346,6 @@ package body Sem_Ch3 is 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 @@ -6760,8 +6924,12 @@ package body Sem_Ch3 is -- 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); @@ -6889,10 +7057,10 @@ package body Sem_Ch3 is 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 @@ -7345,6 +7513,7 @@ package body Sem_Ch3 is 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 @@ -7402,6 +7571,7 @@ package body Sem_Ch3 is 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 @@ -7508,6 +7678,7 @@ package body Sem_Ch3 is 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 @@ -8835,36 +9006,6 @@ package body Sem_Ch3 is 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 @@ -8901,6 +9042,9 @@ package body Sem_Ch3 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 @@ -8943,8 +9087,6 @@ package body Sem_Ch3 is 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 @@ -9057,12 +9199,11 @@ package body Sem_Ch3 is 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)); @@ -9097,13 +9238,62 @@ package body Sem_Ch3 is 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; @@ -9111,18 +9301,6 @@ package body Sem_Ch3 is 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. @@ -9130,8 +9308,9 @@ package body Sem_Ch3 is 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); @@ -9146,9 +9325,10 @@ package body Sem_Ch3 is 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; @@ -9218,6 +9398,7 @@ package body Sem_Ch3 is 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); @@ -9524,12 +9705,19 @@ package body Sem_Ch3 is -- 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. @@ -9545,9 +9733,8 @@ package body Sem_Ch3 is 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; @@ -9567,7 +9754,7 @@ package body Sem_Ch3 is 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)))) @@ -9581,7 +9768,7 @@ package body Sem_Ch3 is then Error_Msg_NE ("constraint for discriminant& must be access to variable", - Def, Discr); + Def, Discr); end if; end if; @@ -9910,6 +10097,7 @@ package body Sem_Ch3 is Analyze (Indic); Set_Underlying_Full_View (Typ, Full_View (Subt)); + Set_Is_Underlying_Full_View (Full_View (Subt)); end Build_Underlying_Full_View; ------------------------------- @@ -10120,9 +10308,6 @@ package body Sem_Ch3 is -- 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 @@ -10156,7 +10341,6 @@ package body Sem_Ch3 is 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 @@ -11706,12 +11890,13 @@ package body Sem_Ch3 is 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 @@ -11788,12 +11973,22 @@ package body Sem_Ch3 is -- 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); @@ -11919,9 +12114,11 @@ package body Sem_Ch3 is 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 @@ -11930,16 +12127,26 @@ package body Sem_Ch3 is 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); @@ -11973,8 +12180,18 @@ package body Sem_Ch3 is -- 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 @@ -13143,15 +13360,13 @@ package body Sem_Ch3 is 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 -- @@ -13175,6 +13390,11 @@ package body Sem_Ch3 is 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 @@ -13192,17 +13412,36 @@ package body Sem_Ch3 is 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) @@ -13243,23 +13482,23 @@ package body Sem_Ch3 is 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; --------------------------- @@ -13791,8 +14030,7 @@ package body Sem_Ch3 is 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)); @@ -14015,8 +14253,8 @@ package body Sem_Ch3 is -- 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; @@ -14111,7 +14349,8 @@ package body Sem_Ch3 is 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; @@ -14499,7 +14738,7 @@ package body Sem_Ch3 is ----------------------- 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; @@ -14666,7 +14905,7 @@ package body Sem_Ch3 is -- 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 @@ -14738,9 +14977,10 @@ package body Sem_Ch3 is 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; @@ -14797,8 +15037,8 @@ package body Sem_Ch3 is 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')); @@ -14876,12 +15116,6 @@ package body Sem_Ch3 is 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. @@ -15080,7 +15314,7 @@ package body Sem_Ch3 is -- 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 @@ -15088,6 +15322,10 @@ package body Sem_Ch3 is -- 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; @@ -15098,7 +15336,7 @@ package body Sem_Ch3 is 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 @@ -15166,7 +15404,7 @@ package body Sem_Ch3 is --------------------------------- procedure Derive_Interface_Subprogram - (New_Subp : in out Entity_Id; + (New_Subp : out Entity_Id; Subp : Entity_Id; Actual_Subp : Entity_Id) is @@ -15186,11 +15424,27 @@ package body Sem_Ch3 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. @@ -15784,25 +16038,23 @@ package body Sem_Ch3 is 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 @@ -15817,19 +16069,17 @@ package body Sem_Ch3 is 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; @@ -15843,8 +16093,8 @@ package body Sem_Ch3 is 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; @@ -16438,50 +16688,93 @@ package body Sem_Ch3 is 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; @@ -16604,9 +16897,9 @@ package body Sem_Ch3 is 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); @@ -17906,8 +18199,9 @@ package body Sem_Ch3 is 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 => @@ -17922,14 +18216,15 @@ package body Sem_Ch3 is 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 => @@ -17991,7 +18286,7 @@ package body Sem_Ch3 is 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 @@ -18018,11 +18313,38 @@ package body Sem_Ch3 is 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 @@ -18165,7 +18487,8 @@ package body Sem_Ch3 is 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); @@ -18174,6 +18497,9 @@ package body Sem_Ch3 is 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))); @@ -18325,7 +18651,7 @@ package body Sem_Ch3 is -- 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); @@ -18703,11 +19029,14 @@ package body Sem_Ch3 is 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; @@ -18720,8 +19049,22 @@ package body Sem_Ch3 is -- 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 => @@ -18741,16 +19084,18 @@ package body Sem_Ch3 is -- 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 @@ -19244,9 +19589,9 @@ package body Sem_Ch3 is 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)) @@ -19321,6 +19666,10 @@ package body Sem_Ch3 is -- 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; @@ -19415,11 +19764,14 @@ package body Sem_Ch3 is 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 @@ -19532,7 +19884,7 @@ package body Sem_Ch3 is -- 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 @@ -19552,8 +19904,8 @@ package body Sem_Ch3 is 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 @@ -19607,9 +19959,9 @@ package body Sem_Ch3 is 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 @@ -19622,8 +19974,8 @@ package body Sem_Ch3 is 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 @@ -19641,13 +19993,13 @@ package body Sem_Ch3 is -- 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 ????? @@ -19865,19 +20217,26 @@ package body Sem_Ch3 is (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 @@ -19935,7 +20294,7 @@ package body Sem_Ch3 is 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 @@ -19958,9 +20317,7 @@ package body Sem_Ch3 is 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; @@ -20016,103 +20373,39 @@ package body Sem_Ch3 is 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; @@ -20122,12 +20415,15 @@ package body Sem_Ch3 is -- 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; + + <> + Restore_Ghost_Mode (Mode); end Process_Full_View; ----------------------------------- @@ -20587,14 +20883,14 @@ package body Sem_Ch3 is 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 @@ -20844,10 +21140,11 @@ package body Sem_Ch3 is 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 @@ -20856,7 +21153,13 @@ package body Sem_Ch3 is 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. @@ -20917,124 +21220,6 @@ package body Sem_Ch3 is 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 -- ----------------------------- @@ -21318,13 +21503,7 @@ package body Sem_Ch3 is 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; @@ -21503,7 +21682,7 @@ package body Sem_Ch3 is 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