From: Arnaud Charlet Date: Mon, 1 Oct 2012 08:49:03 +0000 (+0200) Subject: [multiple changes] X-Git-Tag: misc/gccgo-go1_1_2~531 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=d85be3ba3ba37ceb2b08a62f0974cb6883c24637;p=thirdparty%2Fgcc.git [multiple changes] 2012-10-01 Ed Schonberg * exp_ch3.ads (Build_Array_Invariant_Proc): moved to body. * exp_ch3.adb (Build_Array_Invariant_Proc, Build_Record_Invariant_Proc): transform into functions. (Insert_Component_Invariant_Checks): for composite types that have components with specified invariants, build a checking procedure, and make into the invariant procedure of the composite type, or incorporate it into the user- defined invariant procedure if one has been created. * sem_ch3.adb (Array_Type_Declaration): Checking for invariants on the component type is defered to the expander. 2012-10-01 Thomas Quinot * xsnamest.adb, namet.h, sem_ch10.adb, s-oscons-tmplt.c, xoscons.adb: Minor reformatting. 2012-10-01 Hristian Kirtchev * checks.adb (Apply_Parameter_Aliasing_And_Validity_Checks): Do not process subprogram renaminds because a) those cannot have PPC pragmas b) the renamed entity already has the PPCs. (Build_PPC_Pragma): Prepend a PPC pragma for consistency with Process_PPCs. * sem_ch6.adb (Last_Implicit_Declaration): Removed. (Process_PPCs): Insert a post condition body at the start of the declarative region of the related subprogram. This way the body will not freeze anything it shouldn't. From-SVN: r191903 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index db3e9b826a08..105b9845fc29 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,33 @@ +2012-10-01 Ed Schonberg + + * exp_ch3.ads (Build_Array_Invariant_Proc): moved to body. + * exp_ch3.adb (Build_Array_Invariant_Proc, + Build_Record_Invariant_Proc): transform into functions. + (Insert_Component_Invariant_Checks): for composite types that have + components with specified invariants, build a checking procedure, + and make into the invariant procedure of the composite type, + or incorporate it into the user- defined invariant procedure if + one has been created. + * sem_ch3.adb (Array_Type_Declaration): Checking for invariants + on the component type is defered to the expander. + +2012-10-01 Thomas Quinot + + * xsnamest.adb, namet.h, sem_ch10.adb, s-oscons-tmplt.c, + xoscons.adb: Minor reformatting. + +2012-10-01 Hristian Kirtchev + + * checks.adb (Apply_Parameter_Aliasing_And_Validity_Checks): + Do not process subprogram renaminds because a) those cannot + have PPC pragmas b) the renamed entity already has the PPCs. + (Build_PPC_Pragma): Prepend a PPC pragma for consistency with + Process_PPCs. + * sem_ch6.adb (Last_Implicit_Declaration): Removed. + (Process_PPCs): Insert a post condition body at the start of the + declarative region of the related subprogram. This way the body + will not freeze anything it shouldn't. + 2012-10-01 Robert Dewar * freeze.adb, sem_ch6.adb, opt.ads, sem_ch13.adb, diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 8d40abcb06e2..85f232b5efa3 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -1918,7 +1918,7 @@ package body Checks is Set_Declarations (Subp_Decl, Decls); end if; - Append_To (Decls, Prag); + Prepend_To (Decls, Prag); -- Ensure the proper visibility of the subprogram body and its -- parameters. @@ -1971,6 +1971,11 @@ package body Checks is or else Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration + -- Do not consider subprogram renaminds because the renamed entity + -- already has the proper PPC pragmas. + + or else Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration + -- Do not process null procedures because there is no benefit of -- adding the checks to a no action routine. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index cf993757406d..dc7aa350c07e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -88,6 +88,22 @@ package body Exp_Ch3 is -- used for attachment of any actions required in its construction. -- It also supplies the source location used for the procedure. + function Build_Array_Invariant_Proc + (A_Type : Entity_Id; + Nod : Node_Id) return Node_Id; + -- If the component of type of array type has invariants, build procedure + -- that checks invariant on all components of the array. Ada 2012 specifies + -- that an invariant on some type T must be applied to in-out parameters + -- and return values that include a part of type T. If the array type has + -- an otherwise specified invariant, the component check procedure is + -- called from within the user-specified invariant. Otherwise this becomes + -- the invariant procedure for the array type. + + function Build_Record_Invariant_Proc + (R_Type : Entity_Id; + Nod : Node_Id) return Node_Id; + -- Ditto for record types. + function Build_Discriminant_Formals (Rec_Id : Entity_Id; Use_Dl : Boolean) return List_Id; @@ -118,10 +134,6 @@ package body Exp_Ch3 is -- Build record initialization procedure. N is the type declaration -- node, and Rec_Ent is the corresponding entity for the record type. - procedure Build_Record_Invariant_Proc (R_Type : Entity_Id; Nod : Node_Id); - -- If the record type has components whose types have invariant, build - -- an invariant procedure for the record type itself. - procedure Build_Slice_Assignment (Typ : Entity_Id); -- Build assignment procedure for one-dimensional arrays of controlled -- types. Other array and slice assignments are expanded in-line, but @@ -184,6 +196,14 @@ package body Exp_Ch3 is -- Treat user-defined stream operations as renaming_as_body if the -- subprogram they rename is not frozen when the type is frozen. + procedure Insert_Component_Invariant_Checks + (N : Node_Id; + Typ : Entity_Id; + Proc : Node_Id); + -- If a composite type has invariants and also has components with defined + -- invariants. the component invariant procedure is inserted into the user- + -- defined invariant procedure and added to the checks to be performed. + procedure Initialization_Warning (E : Entity_Id); -- If static elaboration of the package is requested, indicate -- when a type does meet the conditions for static initialization. If @@ -788,7 +808,10 @@ package body Exp_Ch3 is -- Build_Array_Invariant_Proc -- -------------------------------- - procedure Build_Array_Invariant_Proc (A_Type : Entity_Id; Nod : Node_Id) is + function Build_Array_Invariant_Proc + (A_Type : Entity_Id; + Nod : Node_Id) return Node_Id + is Loc : constant Source_Ptr := Sloc (Nod); Object_Name : constant Name_Id := New_Internal_Name ('I'); @@ -882,9 +905,7 @@ package body Exp_Ch3 is Proc_Id := Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (A_Type), "Invariant")); - Set_Has_Invariants (Proc_Id); - Set_Invariant_Procedure (A_Type, Proc_Id); + Chars => New_External_Name (Chars (A_Type), "CInvariant")); Body_Stmts := Check_One_Dimension (1); @@ -912,10 +933,7 @@ package body Exp_Ch3 is Set_Debug_Info_Off (Proc_Id); end if; - -- The procedure body is placed after the freeze node for the type. - - Insert_After (Nod, Proc_Body); - Analyze (Proc_Body); + return Proc_Body; end Build_Array_Invariant_Proc; -------------------------------- @@ -3619,7 +3637,10 @@ package body Exp_Ch3 is -- Build_Record_Invariant_Proc -- -------------------------------- - procedure Build_Record_Invariant_Proc (R_Type : Entity_Id; Nod : Node_Id) is + function Build_Record_Invariant_Proc + (R_Type : Entity_Id; + Nod : Node_Id) return Node_Id + is Loc : constant Source_Ptr := Sloc (Nod); Object_Name : constant Name_Id := New_Internal_Name ('I'); @@ -3745,19 +3766,16 @@ package body Exp_Ch3 is then Stmts := Build_Invariant_Checks (Component_List (Type_Def)); else - return; + return Empty; end if; if not Invariant_Found then - return; + return Empty; end if; Proc_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (R_Type), "Invariant")); - Set_Has_Invariants (Proc_Id); - Set_Has_Invariants (R_Type); - Set_Invariant_Procedure (R_Type, Proc_Id); Proc_Body := Make_Subprogram_Body (Loc, @@ -3779,10 +3797,9 @@ package body Exp_Ch3 is Set_Is_Internal (Proc_Id); Set_Has_Completion (Proc_Id); - -- The procedure body is placed after the freeze node for the type. - - Insert_After (Nod, Proc_Body); - Analyze (Proc_Body); + return Proc_Body; + -- Insert_After (Nod, Proc_Body); + -- Analyze (Proc_Body); end Build_Record_Invariant_Proc; ---------------------------- @@ -5843,7 +5860,11 @@ package body Exp_Ch3 is end if; if Has_Invariants (Component_Type (Base)) then - Build_Array_Invariant_Proc (Base, N); + + -- Generate component invariant checking procedure. + + Insert_Component_Invariant_Checks + (N, Base, Build_Array_Invariant_Proc (Base, N)); end if; end Expand_Freeze_Array_Type; @@ -6812,9 +6833,11 @@ package body Exp_Ch3 is end; end if; - if not Has_Invariants (Def_Id) then - Build_Record_Invariant_Proc (Def_Id, N); - end if; + -- Check whether individual components have a defined invariant, + -- and add the corresponding component invariant checks. + + Insert_Component_Invariant_Checks + (N, Def_Id, Build_Record_Invariant_Proc (Def_Id, N)); end Expand_Freeze_Record_Type; ------------------------------ @@ -7579,6 +7602,63 @@ package body Exp_Ch3 is return Is_RTU (S1, System) or else Is_RTU (S1, Ada); end In_Runtime; + --------------------------------------- + -- Insert_Component_Invariant_Checks -- + --------------------------------------- + + procedure Insert_Component_Invariant_Checks + (N : Node_Id; + Typ : Entity_Id; + Proc : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Typ); + Proc_Id : Entity_Id; + + begin + if Present (Proc) then + Proc_Id := Defining_Entity (Proc); + + if not Has_Invariants (Typ) then + Set_Has_Invariants (Typ); + Set_Has_Invariants (Proc_Id); + Set_Invariant_Procedure (Typ, Proc_Id); + Insert_After (N, Proc); + Analyze (Proc); + + else + + -- Find already created invariant body, insert body of component + -- invariant proc in it, and add call after other checks. + + declare + Bod : Node_Id; + Inv_Id : constant Entity_Id := Invariant_Procedure (Typ); + Call : constant Node_Id := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc_Id, Loc), + Parameter_Associations => + New_List + (New_Reference_To (First_Formal (Inv_Id), Loc))); + + begin + + -- The invariant body has not been analyzed yet, so we do a + -- sequential search forward, and retrieve it by name. + + Bod := Next (N); + while Present (Bod) loop + exit when Nkind (Bod) = N_Subprogram_Body + and then Chars (Defining_Entity (Bod)) = Chars (Inv_Id); + Next (Bod); + end loop; + + Append_To (Declarations (Bod), Proc); + Append_To (Statements (Handled_Statement_Sequence (Bod)), Call); + end; + end if; + end if; + end Insert_Component_Invariant_Checks; + ---------------------------- -- Initialization_Warning -- ---------------------------- diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 1abc4567a330..d43366812ec7 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -46,12 +46,6 @@ package Exp_Ch3 is procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id); -- Add a field _parent in the extension part of the record - procedure Build_Array_Invariant_Proc (A_Type : Entity_Id; Nod : Node_Id); - -- If the component of type of array type has invariants, build procedure - -- that checks invariant on all components of the array. Ada 2012 specifies - -- that an invariant on some type T must be applied to in-out parameters - -- and return values that include a part of type T. - procedure Build_Discr_Checking_Funcs (N : Node_Id); -- Builds function which checks whether the component name is consistent -- with the current discriminants. N is the full type declaration node, diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h index ec2b488a5eff..0bc841ac85d1 100644 --- a/gcc/ada/namet.h +++ b/gcc/ada/namet.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2011, Free Software Foundation, Inc. * + * Copyright (C) 1992-2012, 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- * @@ -24,7 +24,8 @@ ****************************************************************************/ /* This is the C file that corresponds to the Ada package specification - Namet. It was created manually from files namet.ads and namet.adb. */ + Namet. It was created manually from files namet.ads and namet.adb. + Some subprograms from Sinput are also made acessable here. */ #ifdef __cplusplus extern "C" { @@ -111,7 +112,8 @@ extern char *Spec_Filename, *Body_Filename; #define Is_Non_Ada_Error exp_ch11__is_non_ada_error extern Boolean Is_Non_Ada_Error (Entity_Id); -/* Here are some functions in sinput.adb we call from a-trans.c. */ +/* Here are some functions in sinput.adb we call from trans.c. */ + typedef Nat Source_File_Index; typedef Int Logical_Line_Number; typedef Int Column_Number; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index eef71b4b7191..50a55e43d231 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -288,8 +288,12 @@ C("Target_OS", OS_Type, TARGET_OS, "") #define Target_Name TARGET CST(Target_Name, "") -#define sizeof_unsigned_int sizeof (unsigned int) -CND(sizeof_unsigned_int, "Size of unsigned int") +/** + ** Note: the name of the following constant is recognized specially by + ** xoscons (case sensitive). + **/ +#define SIZEOF_unsigned_int sizeof (unsigned int) +CND(SIZEOF_unsigned_int, "Size of unsigned int") /* diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 31e8e5564e53..ded081fc3e1e 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -1822,7 +1822,7 @@ package body Sem_Ch10 is Set_Corresponding_Stub (Unit (Comp_Unit), N); -- Collect SCO information for loaded subunit if we are - -- in the main unit). + -- in the main unit. if Generate_SCO and then diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 6b9e88bfd409..483e7055f035 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4974,12 +4974,9 @@ package body Sem_Ch3 is Subtype_Indication (Component_Def)); end if; - -- Ada 2012: if the element type has invariants we must create an - -- invariant procedure for the array type as well. - - if Has_Invariants (Element_Type) then - Set_Has_Invariants (T); - end if; + -- There may be an invariant declared for the component type, but + -- the construction of the component invariant checking procedure + -- takes place during expansion. end Array_Type_Declaration; ------------------------------------------------------ diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5ace348d3250..8c88d8f9acbc 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -11087,6 +11087,9 @@ package body Sem_Ch6 is -- references to parameters of the inherited subprogram to point to the -- corresponding parameters of the current subprogram. + procedure Insert_Before_First_Source_Declaration (Nod : Node_Id); + -- Insert node Nod before the first source declaration of the context + function Invariants_Or_Predicates_Present return Boolean; -- Determines if any invariants or predicates are present for any OUT -- or IN OUT parameters of the subprogram, or (for a function) if the @@ -11101,9 +11104,6 @@ package body Sem_Ch6 is -- that an invariant check is required (for an IN OUT parameter, or -- the returned value of a function. - function Last_Implicit_Declaration return Node_Id; - -- Return the last internally-generated declaration of N - ------------- -- Grab_CC -- ------------- @@ -11281,6 +11281,36 @@ package body Sem_Ch6 is return CP; end Grab_PPC; + -------------------------------------------- + -- Insert_Before_First_Source_Declaration -- + -------------------------------------------- + + procedure Insert_Before_First_Source_Declaration (Nod : Node_Id) is + Decls : constant List_Id := Declarations (N); + Decl : Node_Id; + + begin + if No (Decls) then + Set_Declarations (N, New_List (Nod)); + else + Decl := First (Decls); + + while Present (Decl) loop + if Comes_From_Source (Decl) then + exit; + end if; + + Next (Decl); + end loop; + + if No (Decl) then + Append_To (Decls, Nod); + else + Insert_Before (Decl, Nod); + end if; + end if; + end Insert_Before_First_Source_Declaration; + -------------------------------------- -- Invariants_Or_Predicates_Present -- -------------------------------------- @@ -11358,50 +11388,6 @@ package body Sem_Ch6 is end if; end Is_Public_Subprogram_For; - ------------------------------- - -- Last_Implicit_Declaration -- - ------------------------------- - - function Last_Implicit_Declaration return Node_Id is - Loc : constant Source_Ptr := Sloc (N); - Decls : List_Id := Declarations (N); - Decl : Node_Id; - Succ : Node_Id; - - begin - if No (Decls) then - Decls := New_List (Make_Null_Statement (Loc)); - Set_Declarations (N, Decls); - - elsif Is_Empty_List (Declarations (N)) then - Append_To (Decls, Make_Null_Statement (Loc)); - end if; - - -- Implicit and source declarations may be interspersed. Search for - -- the last implicit declaration which is either succeeded by a - -- source construct or is the last node in the declarative list. - - Decl := First (Declarations (N)); - while Present (Decl) loop - Succ := Next (Decl); - - -- The current declaration is the last one, do not return Empty - - if No (Succ) then - exit; - - -- The successor is a source construct - - elsif Comes_From_Source (Succ) then - exit; - end if; - - Next (Decl); - end loop; - - return Decl; - end Last_Implicit_Declaration; - -- Start of processing for Process_PPCs begin @@ -11807,7 +11793,12 @@ package body Sem_Ch6 is -- The entity for the _Postconditions procedure begin - Insert_After (Last_Implicit_Declaration, + -- Insert the corresponding body of a post condition pragma before + -- the first source declaration of the context. This ensures that + -- any [sub]types generated in relation to the formals of the + -- subprogram are still visible in the _postcondition body. + + Insert_Before_First_Source_Declaration ( Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb index c740aa25383f..90d1b2d4de72 100644 --- a/gcc/ada/xoscons.adb +++ b/gcc/ada/xoscons.adb @@ -387,7 +387,7 @@ procedure XOSCons is Info.Value_Len := Info.Text_Value'Length; end if; - if Info.Constant_Name.all = "sizeof_unsigned_int" then + if Info.Constant_Name.all = "SIZEOF_unsigned_int" then Size_Of_Unsigned_Int := 8 * Integer (Info.Int_Value.Abs_Value); end if; diff --git a/gcc/ada/xsnamest.adb b/gcc/ada/xsnamest.adb index 9b8297438135..a22eec02aa7a 100644 --- a/gcc/ada/xsnamest.adb +++ b/gcc/ada/xsnamest.adb @@ -229,10 +229,11 @@ begin Output_Header_Line (Prag); end if; else - Oval := Lpad (V (Val), 3, '0'); if Match (Name0, "Last_") then Oval := Lpad (V (Val - 1), 3, '0'); + else + Oval := Lpad (V (Val), 3, '0'); end if; Put_Line