diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 81bc2cc5db1..17e8bdac36b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,53 @@ +2016-04-20 Bob Duff + + * s-os_lib.ads: Minor comment fix. + +2016-04-20 Ed Schonberg + + * exp_ch5.adb (Expand_N_Assignment_Statement): Do no generate + a discriminant check for a type whose partial view has unknown + discriminants when the full view has discriminants with defaults. + +2016-04-20 Javier Miranda + + * exp_util.adb (Remove_Side_Effects): When generating C code + remove side effect of type conversion of access to unconstrained + array type. + (Side_Effect_Free): Return false for the type + conversion of access to unconstrained array type when generating + C code. + * sem_res.adb (Resolved_Type_Conversion): Remove side effects + of access to unconstrained array type conversion when generating + C code. + +2016-04-20 Ed Schonberg + + * sem_ch13.adb (Build_Predicate_Function_Declaration): New + function, to construct the declaration of a predicate function + at the end of the current declarative part rather than at the + (possibly later) freeze point of the type. This also allows uses + of a type with predicates in instantiations elsewhere. + (Resolve_Aspect_Expression): New procedure to detect visiblity + errors in aspect expressions, at the end of the declarative part + that includes the type declaration. + * sem_ch3.adb (Complete_Private_Subtype): Propagate properly the + predicate function from private to full view. + * einfo.adb (Predicate_Function): Refine search for predicate + function when type has a full view and predicate function may + be defined on either view. + +2016-04-20 Javier Miranda + + * frontend.adb: Passing the root of the tree to + Unnest_Subprograms(). + * exp_ch6.adb (Expand_N_Subprogram_Body): Remove code that + took care of adding subprograms to the Unest_Bodies table since + performing such action too early disables the ability to process + generic instantiations. + (Unnest_Subprograms): Adding parameter. + (Search_Unnesting_Subprograms): New subprogram. + * exp_ch6.ads (Unnest_Subrograms): Update documentation. + 2016-04-20 Hristian Kirtchev * exp_util.adb, freeze.adb, sem_util.adb: Minor reformatting. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 5586ea7a268..9f1f3a9fe32 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.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- -- @@ -8213,8 +8213,13 @@ package body Einfo is -- If type is private and has a completion, predicate may be defined -- on the full view. - if Is_Private_Type (Id) and then Present (Full_View (Id)) then + if Is_Private_Type (Id) + and then + (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id))) + and then Present (Full_View (Id)) + then T := Full_View (Id); + else T := Id; end if; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 9f9c832ac47..139f5ca3ae2 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1946,10 +1946,12 @@ package body Exp_Ch5 is -- have a full view with discriminants, but those are nameable only -- in the underlying type, so convert the Rhs to it before potential -- checking. Convert Lhs as well, otherwise the actual subtype might - -- not be constructible. + -- not be constructible. If the discriminants have defaults the type + -- is unconstrained and there is nothing to check. elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs))) and then Has_Discriminants (Typ) + and then not Has_Defaulted_Discriminants (Typ) then Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs)); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 54f4d029a97..876aca98fd9 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.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- -- @@ -5491,28 +5491,6 @@ package body Exp_Ch6 is Qualify_Entity_Names (N); - -- If we are unnesting procedures, and this is an outer level procedure - -- with nested subprograms, do the unnesting operation now. - - if Opt.Unnest_Subprogram_Mode - - -- We are only interested in subprograms (not generic subprograms) - - and then Is_Subprogram (Spec_Id) - - -- Only deal with outer level subprograms. Nested subprograms are - -- handled as part of dealing with the outer level subprogram in - -- which they are nested. - - and then Enclosing_Subprogram (Spec_Id) = Empty - - -- We are only interested in subprograms that have nested subprograms - - and then Has_Nested_Subprogram (Spec_Id) - then - Unest_Bodies.Append ((Spec_Id, N)); - end if; - Ghost_Mode := Save_Ghost_Mode; end Expand_N_Subprogram_Body; @@ -8497,8 +8475,74 @@ package body Exp_Ch6 is -- Unnest_Subprograms -- ------------------------ - procedure Unnest_Subprograms is + procedure Unnest_Subprograms (N : Node_Id) is + + procedure Search_Unnesting_Subprograms (N : Node_Id); + -- Search for outer level procedures with nested subprograms and append + -- them to the Unnest table. + + ---------------------------------- + -- Search_Unnesting_Subprograms -- + ---------------------------------- + + procedure Search_Unnesting_Subprograms (N : Node_Id) is + + function Search_Subprograms (N : Node_Id) return Traverse_Result; + -- Tree visitor that search for outer level procedures with nested + -- subprograms and adds them to the Unnest table. + + ------------------------ + -- Search_Subprograms -- + ------------------------ + + function Search_Subprograms (N : Node_Id) return Traverse_Result is + begin + if Nkind_In (N, N_Subprogram_Body, + N_Subprogram_Body_Stub) + then + declare + Spec_Id : constant Entity_Id := Unique_Defining_Entity (N); + + begin + -- We are only interested in subprograms (not generic + -- subprograms), that have nested subprograms. + + if Is_Subprogram (Spec_Id) + and then Has_Nested_Subprogram (Spec_Id) + and then Is_Library_Level_Entity (Spec_Id) + then + Unest_Bodies.Append ((Spec_Id, N)); + end if; + end; + end if; + + return OK; + end Search_Subprograms; + + --------------- + -- Do_Search -- + --------------- + + procedure Do_Search is new Traverse_Proc (Search_Subprograms); + -- Subtree visitor instantiation + + -- Start of processing for Search_Unnesting_Subprograms + + begin + if Opt.Unnest_Subprogram_Mode then + Do_Search (N); + end if; + end Search_Unnesting_Subprograms; + + -- Start of processing for Unnest_Subprograms + begin + if not Opt.Unnest_Subprogram_Mode then + return; + end if; + + Search_Unnesting_Subprograms (N); + for J in Unest_Bodies.First .. Unest_Bodies.Last loop declare UBJ : Unest_Entry renames Unest_Bodies.Table (J); diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 7ae19de6377..551cb1e6af1 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -212,9 +212,9 @@ package Exp_Ch6 is -- parameter to identify the accessibility level of the function result -- "determined by the point of call". - procedure Unnest_Subprograms; - -- Called to unnest subprograms. If we are in unnest subprogram mode, and - -- subprograms have been gathered in the Unest_Bodies table, this is the - -- call that causes them to be processed for unnesting. + procedure Unnest_Subprograms (N : Node_Id); + -- Called to unnest subprograms. If we are in unnest subprogram mode, this + -- is the call that traverses the tree N and locates all the library level + -- subprograms with nested subprograms to process them. end Exp_Ch6; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index da9ed388521..4b0f1f8fd9a 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -7800,7 +7800,30 @@ package body Exp_Util is elsif Nkind (Exp) = N_Type_Conversion then Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); - goto Leave; + + -- Generating C code the type conversion of an access to constrained + -- array type into an access to unconstrained array type involves + -- initializing a fat pointer and the expression must be free of + -- side effects to safely compute its bounds. + + if Generate_C_Code + and then Is_Access_Type (Etype (Exp)) + and then Is_Array_Type (Designated_Type (Etype (Exp))) + and then not Is_Constrained (Designated_Type (Etype (Exp))) + then + Def_Id := Build_Temporary (Loc, 'R', Exp); + Set_Etype (Def_Id, Exp_Type); + Res := New_Occurrence_Of (Def_Id, Loc); + + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => New_Occurrence_Of (Exp_Type, Loc), + Constant_Present => True, + Expression => Relocate_Node (Exp))); + else + goto Leave; + end if; -- If this is an unchecked conversion that Gigi can't handle, make -- a copy or a use a renaming to capture the value. @@ -9076,6 +9099,19 @@ package body Exp_Util is and then Is_Class_Wide_Type (Typ) then return True; + + -- Generating C the type conversion of an access to constrained array + -- type into an access to unconstrained array type involves initializing + -- a fat pointer and the expression cannot be assumed to be free of side + -- effects since it must referenced several times to compute its bounds. + + elsif Generate_C_Code + and then Nkind (N) = N_Type_Conversion + and then Is_Access_Type (Typ) + and then Is_Array_Type (Designated_Type (Typ)) + and then not Is_Constrained (Designated_Type (Typ)) + then + return False; end if; -- For other than entity names and compile time known values, diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 723096ccc1f..8ed90b0999c 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.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- -- @@ -440,7 +440,7 @@ begin -- At this stage we can unnest subprogram bodies if required - Exp_Ch6.Unnest_Subprograms; + Exp_Ch6.Unnest_Subprograms (Cunit (Main_Unit)); -- List library units if requested diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index f53c2ec1a58..dd0851ded7d 100644 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -454,7 +454,7 @@ package System.OS_Lib is -- that is writable. Returns True if so, False otherwise. Note that this -- function simply interrogates the file attributes (e.g. using the C -- function stat), so it does not indicate a situation in which a file may - -- not actually be writeable due to some other process having exclusive + -- not actually be writable due to some other process having exclusive -- access. function Locate_Exec_On_Path (Exec_Name : String) return String_Access; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 859e67e3c67..57e4c8dcb81 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.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- -- @@ -101,17 +101,24 @@ package body Sem_Ch13 is -- list is stored in Static_Discrete_Predicate (Typ), and the Expr is -- rewritten as a canonicalized membership operation. + function Build_Predicate_Function_Declaration + (Typ : Entity_Id) return Node_Id; + -- Build the declaration for a predicate function. The declaration is built + -- at the end of the declarative part containing the type definition, which + -- may be before the freeze point of the type. The predicate expression is + -- pre-analyzed at this point, to catch visibility errors. + procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id); -- If Typ has predicates (indicated by Has_Predicates being set for Typ), -- then either there are pragma Predicate entries on the rep chain for the -- type (note that Predicate aspects are converted to pragma Predicate), or -- there are inherited aspects from a parent type, or ancestor subtypes. - -- This procedure builds the spec and body for the Predicate function that - -- tests these predicates. N is the freeze node for the type. The spec of - -- the function is inserted before the freeze node, and the body of the - -- function is inserted after the freeze node. If the predicate expression - -- has at least one Raise_Expression, then this procedure also builds the - -- M version of the predicate function for use in membership tests. + -- This procedure builds body for the Predicate function that tests these + -- predicates. N is the freeze node for the type. The spec of the function + -- is inserted before the freeze node, and the body of the function is + -- inserted after the freeze node. If the predicate expression has a least + -- one Raise_Expression, then this procedure also builds the M version of + -- the predicate function for use in membership tests. procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id); -- Called if both Storage_Pool and Storage_Size attribute definition @@ -8419,18 +8426,23 @@ package body Sem_Ch13 is -- function. It differs in that raise expressions are marked for -- special expansion (see Process_REs). - Object_Name : constant Name_Id := New_Internal_Name ('I'); + Object_Name : Name_Id; -- Name for argument of Predicate procedure. Note that we use the same -- name for both predicate functions. That way the reference within the -- predicate expression is the same in both functions. - Object_Entity : constant Entity_Id := - Make_Defining_Identifier (Loc, Chars => Object_Name); + Object_Entity : Entity_Id; -- Entity for argument of Predicate procedure - Object_Entity_M : constant Entity_Id := - Make_Defining_Identifier (Loc, Chars => Object_Name); - -- Entity for argument of Predicate_M procedure + Object_Entity_M : Entity_Id; + -- Entity for argument of separate Predicate procedure when exceptions + -- are present in expression. + + FDecl : Node_Id; + -- The function declaration. + + SId : Entity_Id; + -- Its entity. Raise_Expression_Present : Boolean := False; -- Set True if Expr has at least one Raise_Expression @@ -8669,8 +8681,9 @@ package body Sem_Ch13 is begin -- Return if already built or if type does not have predicates + SId := Predicate_Function (Typ); if not Has_Predicates (Typ) - or else Present (Predicate_Function (Typ)) + or else (Present (SId) and then Has_Completion (SId)) then return; end if; @@ -8684,6 +8697,24 @@ package body Sem_Ch13 is Expr := Empty; + if Present (SId) then + FDecl := Unit_Declaration_Node (SId); + + else + FDecl := Build_Predicate_Function_Declaration (Typ); + SId := Defining_Entity (FDecl); + end if; + + -- Recover name of formal parameter of function that replaces references + -- to the type in predicate expressions. + + Object_Entity := + Defining_Identifier + (First (Parameter_Specifications (Specification (FDecl)))); + + Object_Name := Chars (Object_Entity); + Object_Entity_M := Make_Defining_Identifier (Loc, Chars => Object_Name); + -- Add predicates for ancestor if present. These must come before the -- ones for the current type, as required by AI12-0071-1. @@ -8694,7 +8725,6 @@ package body Sem_Ch13 is Add_Call (Atyp); end if; end; - -- Add Predicates for the current type Add_Predicates; @@ -8757,27 +8787,15 @@ package body Sem_Ch13 is -- Build the main predicate function declare - SId : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); - -- The entity for the function spec - SIdB : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Typ), "Predicate")); -- The entity for the function body Spec : Node_Id; - FDecl : Node_Id; FBody : Node_Id; begin - -- Build function declaration - - Set_Ekind (SId, E_Function); - Set_Is_Internal (SId); - Set_Is_Predicate_Function (SId); - Set_Predicate_Function (Typ, SId); -- The predicate function is shared between views of a type @@ -8792,20 +8810,6 @@ package body Sem_Ch13 is Set_Is_Ghost_Entity (SId); end if; - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Object_Entity, - Parameter_Type => New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); - - FDecl := - Make_Subprogram_Declaration (Loc, - Specification => Spec); - -- Build function body Spec := @@ -8830,9 +8834,14 @@ package body Sem_Ch13 is Make_Simple_Return_Statement (Loc, Expression => Expr)))); - -- Insert declaration before freeze node and body after + -- If declaration has not been analyzed yet, Insert declaration + -- before freeze node. + -- Insert body after freeze node. + + if not Analyzed (FDecl) then + Insert_Before_And_Analyze (N, FDecl); + end if; - Insert_Before_And_Analyze (N, FDecl); Insert_After_And_Analyze (N, FBody); -- Static predicate functions are always side-effect free, and @@ -8863,8 +8872,8 @@ package body Sem_Ch13 is -- The entity for the function body Spec : Node_Id; - FDecl : Node_Id; FBody : Node_Id; + FDecl : Node_Id; BTemp : Entity_Id; begin @@ -9046,6 +9055,59 @@ package body Sem_Ch13 is Ghost_Mode := Save_Ghost_Mode; end Build_Predicate_Functions; + ------------------------------------------ + -- Build_Predicate_Function_Declaration -- + ------------------------------------------ + + function Build_Predicate_Function_Declaration + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + + Object_Entity : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('I')); + + -- The formal parameter of the function + + SId : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + + -- The entity for the function spec + + FDecl : Node_Id; + Spec : Node_Id; + + begin + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity, + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec); + + Set_Ekind (SId, E_Function); + Set_Etype (SId, Standard_Boolean); + Set_Is_Internal (SId); + Set_Is_Predicate_Function (SId); + Set_Predicate_Function (Typ, SId); + + if Comes_From_Source (Typ) then + Insert_After (Parent (Typ), FDecl); + else + Insert_After (Parent (Base_Type (Typ)), FDecl); + end if; + + Analyze (FDecl); + + return FDecl; + end Build_Predicate_Function_Declaration; + ----------------------------------------- -- Check_Aspect_At_End_Of_Declarations -- ----------------------------------------- @@ -12532,6 +12594,37 @@ package body Sem_Ch13 is A_Id : Aspect_Id; Expr : Node_Id; + function Resolve_Name (N : Node_Id) return Traverse_Result; + -- Verify that all identifiers in the expression, with the exception + -- of references to the current entity, denote visible entities. This + -- is done only to detect visibility errors, as the expression will be + -- properly analyzed/expanded during analysis of the predicate function + -- body. + + ------------------ + -- Resolve_Name -- + ------------------ + + function Resolve_Name (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Selected_Component then + if Nkind (Prefix (N)) = N_Identifier + and then Chars (Prefix (N)) /= Chars (E) + then + Find_Selected_Component (Parent (N)); + end if; + return Skip; + + elsif Nkind (N) = N_Identifier and then Chars (N) /= Chars (E) then + Find_Direct_Name (N); + Set_Entity (N, Empty); + end if; + + return OK; + end Resolve_Name; + + procedure Resolve_Aspect_Expression is new Traverse_Proc (Resolve_Name); + begin ASN := First_Rep_Item (E); while Present (ASN) loop @@ -12546,11 +12639,25 @@ package body Sem_Ch13 is when Aspect_Predicate | Aspect_Predicate_Failure | - Aspect_Invariant | - Aspect_Static_Predicate | - Aspect_Dynamic_Predicate => + Aspect_Invariant => null; + when Aspect_Static_Predicate | + Aspect_Dynamic_Predicate => + + -- build predicate function specification and preanalyze + -- expression after type replacement. + + if No (Predicate_Function (E)) then + declare + FDecl : constant Node_Id := + Build_Predicate_Function_Declaration (E); + pragma Unreferenced (FDecl); + begin + Resolve_Aspect_Expression (Expr); + end; + end if; + when Pre_Post_Aspects => null; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index cc82e710795..71af299777d 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- -- @@ -11820,8 +11820,17 @@ 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 diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 2ce47e23f97..8957287dbfd 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -10847,6 +10847,23 @@ package body Sem_Res is then Set_Do_Range_Check (Operand); end if; + + -- Generating C code a type conversion of an access to constrained + -- array type to access to unconstrained array type involves building + -- a fat pointer which in general cannot be generated on the fly. We + -- remove side effects in order to store the result of the conversion + -- into a temporary. + + if Generate_C_Code + and then Nkind (N) = N_Type_Conversion + and then Nkind (Parent (N)) /= N_Object_Declaration + and then Is_Access_Type (Etype (N)) + and then Is_Array_Type (Designated_Type (Etype (N))) + and then not Is_Constrained (Designated_Type (Etype (N))) + and then Is_Constrained (Designated_Type (Etype (Expression (N)))) + then + Remove_Side_Effects (N); + end if; end Resolve_Type_Conversion; ----------------------