From 6f104d01c71f83925f92499024dd6d3952d051ac Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 22 Oct 2010 10:09:51 +0000 Subject: [PATCH] 2010-10-22 Robert Dewar * sprint.adb: Minor reformatting. 2010-10-22 Robert Dewar * exp_ch3.adb (Expand_N_Object_Declaration): Do required predicate checks. * sem_ch3.adb (Complete_Private_Subtype): Propagate predicates to full view. * sem_ch6.adb (Invariants_Or_Predicates_Present): New name for Invariants_Present. (Process_PPCs): Handle predicates generating post conditions * sem_util.adb (Is_Partially_Initialized_Type): Add Include_Null parameter. * sem_util.ads (Is_Partially_Initialized_Type): Add Include_Null parameter. 2010-10-22 Sergey Rybin * gnat_ugn.texi (gnatelim): Add description for '--ignore' option 2010-10-22 Thomas Quinot * sem_prag.adb (Check_First_Subtype): Specialize error messages for case where argument is not a type. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165815 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 27 +++++++++++++++++++++++ gcc/ada/exp_ch3.adb | 18 ++++++++++++++++ gcc/ada/gnat_ugn.texi | 5 +++++ gcc/ada/sem_ch3.adb | 7 ++++++ gcc/ada/sem_ch6.adb | 60 +++++++++++++++++++++++++++++++++------------------ gcc/ada/sem_prag.adb | 30 ++++++++++++++++---------- gcc/ada/sem_util.adb | 17 ++++++++++----- gcc/ada/sem_util.ads | 8 ++++++- gcc/ada/sprint.adb | 1 + 9 files changed, 135 insertions(+), 38 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a640b46..a726dd9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,32 @@ 2010-10-22 Robert Dewar + * sprint.adb: Minor reformatting. + +2010-10-22 Robert Dewar + + * exp_ch3.adb (Expand_N_Object_Declaration): Do required predicate + checks. + * sem_ch3.adb (Complete_Private_Subtype): Propagate predicates to full + view. + * sem_ch6.adb (Invariants_Or_Predicates_Present): New name for + Invariants_Present. + (Process_PPCs): Handle predicates generating post conditions + * sem_util.adb (Is_Partially_Initialized_Type): Add + Include_Null parameter. + * sem_util.ads (Is_Partially_Initialized_Type): Add + Include_Null parameter. + +2010-10-22 Sergey Rybin + + * gnat_ugn.texi (gnatelim): Add description for '--ignore' option + +2010-10-22 Thomas Quinot + + * sem_prag.adb (Check_First_Subtype): Specialize error messages for + case where argument is not a type. + +2010-10-22 Robert Dewar + * exp_ch5.adb, par-ch4.adb, par-ch5.adb, sem_ch5.adb, sinfo.ads: Minor reformatting. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 0cb2b5b..b7d4c3b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4508,6 +4508,24 @@ package body Exp_Ch3 is return; end if; + -- Deal with predicate check before we start to do major rewriting. + -- it is OK to initialize and then check the initialized value, since + -- the object goes out of scope if we get a predicate failure. + + -- 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. + + if Present (Predicate_Function (Typ)) + and then + (Present (Expr) + or else + Is_Partially_Initialized_Type (Typ, Include_Null => False)) + then + Insert_After (N, + Make_Predicate_Check (Typ, New_Occurrence_Of (Def_Id, Loc))); + end if; + -- Force construction of dispatch tables of library level tagged types if Tagged_Type_Expansion diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 9e4fe98..85459e4 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -10911,6 +10911,11 @@ Duplicate all the output sent to @file{stderr} into a specified log file. @item ^--no-elim-dispatch^/NO_DISPATCH^ Do not generate pragmas for dispatching operations. +@item ^--ignore^/IGNORE^=@var{filename} +@cindex @option{^--ignore^/IGNORE^} (@command{gnatelim}) +Do not generate pragmas for subprograms declared in the sources +listed in a specified file + @cindex @option{^-o^/OUTPUT^} (@command{gnatelim}) @item ^-o^/OUTPUT^=@var{report_file} Put @command{gnatelim} output into a specified file. If this file already exists, diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 22d2fdf..dfbd788 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9913,6 +9913,13 @@ package body Sem_Ch3 is Corresponding_Record_Type (Full_Base)); end if; end if; + + -- Copy rep item chain, and also setting of Has_Predicates from + -- private subtype to full subtype, since we will need these on the + -- full subtype to create the predicate function. + + Set_First_Rep_Item (Full, First_Rep_Item (Priv)); + Set_Has_Predicates (Full, Has_Predicates (Priv)); end Complete_Private_Subtype; ---------------------------- diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 88918f3..98cb237 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -207,8 +207,8 @@ package body Sem_Ch6 is -- conditions for the body and assembling and inserting the _postconditions -- procedure. N is the node for the subprogram body and Body_Id/Spec_Id are -- the entities for the body and separate spec (if there is no separate - -- spec, Spec_Id is Empty). Note that invariants also provide a source - -- of postconditions, which are also handled in this procedure. + -- spec, Spec_Id is Empty). Note that invariants and predicates may also + -- provide postconditions, and are also handled in this procedure. procedure Set_Formal_Validity (Formal_Id : Entity_Id); -- Formal_Id is an formal parameter entity. This procedure deals with @@ -8681,9 +8681,10 @@ package body Sem_Ch6 is -- references to parameters of the inherited subprogram to point to the -- corresponding parameters of the current subprogram. - function Invariants_Present return Boolean; - -- Determines if any invariants are present for any OUT or IN OUT - -- parameters of the subprogram, or (for a function) for the return. + 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 + -- return value has an invariant. -------------- -- Grab_PPC -- @@ -8782,12 +8783,12 @@ package body Sem_Ch6 is return CP; end Grab_PPC; - ------------------------ - -- Invariants_Present -- - ------------------------ + -------------------------------------- + -- Invariants_Or_Predicates_Present -- + -------------------------------------- - function Invariants_Present return Boolean is - Formal : Entity_Id; + function Invariants_Or_Predicates_Present return Boolean is + Formal : Entity_Id; begin -- Check function return result @@ -8803,7 +8804,9 @@ package body Sem_Ch6 is Formal := First_Formal (Designator); while Present (Formal) loop if Ekind (Formal) /= E_In_Parameter - and then Has_Invariants (Etype (Formal)) + and then + (Has_Invariants (Etype (Formal)) + or else Present (Predicate_Function (Etype (Formal)))) then return True; end if; @@ -8812,7 +8815,7 @@ package body Sem_Ch6 is end loop; return False; - end Invariants_Present; + end Invariants_Or_Predicates_Present; -- Start of processing for Process_PPCs @@ -9084,7 +9087,7 @@ package body Sem_Ch6 is -- If we had any postconditions and expansion is enabled, or if the -- procedure has invariants, then build the _Postconditions procedure. - if (Present (Plist) or else Invariants_Present) + if (Present (Plist) or else Invariants_Or_Predicates_Present) and then Expander_Active then if No (Plist) then @@ -9127,21 +9130,33 @@ package body Sem_Ch6 is Parms := No_List; end if; - -- Add invariant calls for parameters. Note that this is done for - -- functions as well, since in Ada 2012 they can have IN OUT args. + -- Add invariant calls and predicate calls for parameters. Note that + -- this is done for functions as well, since in Ada 2012 they can + -- have IN OUT args. declare Formal : Entity_Id; + Ftype : Entity_Id; begin Formal := First_Formal (Designator); while Present (Formal) loop - if Ekind (Formal) /= E_In_Parameter - and then Has_Invariants (Etype (Formal)) - and then Present (Invariant_Procedure (Etype (Formal))) - then - Append_To (Plist, - Make_Invariant_Call (New_Occurrence_Of (Formal, Loc))); + if Ekind (Formal) /= E_In_Parameter then + Ftype := Etype (Formal); + + if Has_Invariants (Ftype) + and then Present (Invariant_Procedure (Ftype)) + then + Append_To (Plist, + Make_Invariant_Call + (New_Occurrence_Of (Formal, Loc))); + end if; + + if Present (Predicate_Function (Ftype)) then + Append_To (Plist, + Make_Predicate_Check + (Ftype, New_Occurrence_Of (Formal, Loc))); + end if; end if; Next_Formal (Formal); @@ -9365,6 +9380,7 @@ package body Sem_Ch6 is if Ekind (Scope (Formal_Id)) = E_Function or else Ekind (Scope (Formal_Id)) = E_Generic_Function then + -- [IN] OUT parameters allowed for functions in Ada 2012 if Ada_Version >= Ada_2012 then if In_Present (Spec) then @@ -9373,6 +9389,8 @@ package body Sem_Ch6 is Set_Ekind (Formal_Id, E_Out_Parameter); end if; + -- But not in earlier versions of Ada + else Error_Msg_N ("functions can only have IN parameters", Spec); Set_Ekind (Formal_Id, E_In_Parameter); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 552f4b1..6bd33a9 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -410,8 +410,8 @@ package body Sem_Prag is -- case, and if found, issues an appropriate error message. procedure Check_First_Subtype (Arg : Node_Id); - -- Checks that Arg, whose expression is an entity name referencing a - -- subtype, does not reference a type that is not a first subtype. + -- Checks that Arg, whose expression is an entity name, references a + -- first subtype. procedure Check_In_Main_Program; -- Common checks for pragmas that appear within a main program @@ -976,8 +976,7 @@ package body Sem_Prag is Check_Arg_Is_Identifier (Argx); if not Is_Locking_Policy_Name (Chars (Argx)) then - Error_Pragma_Arg - ("& is not a valid locking policy name", Argx); + Error_Pragma_Arg ("& is not a valid locking policy name", Argx); end if; end Check_Arg_Is_Locking_Policy; @@ -1032,7 +1031,6 @@ package body Sem_Prag is Error_Pragma_Arg ("invalid argument for pragma%", Argx); end if; end Check_Arg_Is_One_Of; - --------------------------------- -- Check_Arg_Is_Queuing_Policy -- --------------------------------- @@ -1044,8 +1042,7 @@ package body Sem_Prag is Check_Arg_Is_Identifier (Argx); if not Is_Queuing_Policy_Name (Chars (Argx)) then - Error_Pragma_Arg - ("& is not a valid queuing policy name", Argx); + Error_Pragma_Arg ("& is not a valid queuing policy name", Argx); end if; end Check_Arg_Is_Queuing_Policy; @@ -1210,9 +1207,7 @@ package body Sem_Prag is S : Entity_Id := Id; begin - while Present (S) - and then S /= Standard_Standard - loop + while Present (S) and then S /= Standard_Standard loop if Ekind (S) = E_Generic_Package and then In_Package_Body (S) then @@ -1342,10 +1337,22 @@ package body Sem_Prag is procedure Check_First_Subtype (Arg : Node_Id) is Argx : constant Node_Id := Get_Pragma_Arg (Arg); + Ent : constant Entity_Id := Entity (Argx); begin - if not Is_First_Subtype (Entity (Argx)) then + if Is_First_Subtype (Ent) then + null; + + elsif Is_Type (Ent) then Error_Pragma_Arg ("pragma% cannot apply to subtype", Argx); + + elsif Is_Object (Ent) then + Error_Pragma_Arg + ("pragma% cannot apply to object, requires a type", Argx); + + else + Error_Pragma_Arg + ("pragma% cannot apply to&, requires a type", Argx); end if; end Check_First_Subtype; @@ -2188,6 +2195,7 @@ package body Sem_Prag is if Error_Msg_Name_1 = Name_Precondition then Error_Msg_Name_1 := Name_Pre; + elsif Error_Msg_Name_1 = Name_Postcondition then Error_Msg_Name_1 := Name_Post; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 109ee58..fb25906 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6776,19 +6776,24 @@ package body Sem_Util is -- Is_Partially_Initialized_Type -- ----------------------------------- - function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is + function Is_Partially_Initialized_Type + (Typ : Entity_Id; + Include_Null : Boolean := True) return Boolean + is begin if Is_Scalar_Type (Typ) then return False; elsif Is_Access_Type (Typ) then - return True; + return Include_Null; elsif Is_Array_Type (Typ) then -- If component type is partially initialized, so is array type - if Is_Partially_Initialized_Type (Component_Type (Typ)) then + if Is_Partially_Initialized_Type + (Component_Type (Typ), Include_Null) + then return True; -- Otherwise we are only partially initialized if we are fully @@ -6841,7 +6846,9 @@ package body Sem_Util is -- If a component is of a type which is itself partially -- initialized, then the enclosing record type is also. - elsif Is_Partially_Initialized_Type (Etype (Ent)) then + elsif Is_Partially_Initialized_Type + (Etype (Ent), Include_Null) + then return True; end if; end if; @@ -6880,7 +6887,7 @@ package body Sem_Util is if No (U) then return True; else - return Is_Partially_Initialized_Type (U); + return Is_Partially_Initialized_Type (U, Include_Null); end if; end; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index be4987b..975d724 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -760,12 +760,18 @@ package Sem_Util is -- the Is_Variable sense) with a non-tagged type target are considered view -- conversions and hence variables. - function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean; + function Is_Partially_Initialized_Type + (Typ : Entity_Id; + Include_Null : Boolean := True) return Boolean; -- Typ is a type entity. This function returns true if this type is partly -- initialized, meaning that an object of the type is at least partly -- initialized (in particular in the record case, that at least one -- component has an initialization expression). Note that initialization -- resulting from the use of pragma Normalized_Scalars does not count. + -- Include_Null controls the handling of access types, and components of + -- access types not explicitly initialized. If set to True, the default, + -- default initialization of access types counts as making the type be + -- partially initialized. If False, this does not count. function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean; -- Determines if type T is a potentially persistent type. A potentially diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 627fb2f..e984b5b 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -1995,6 +1995,7 @@ package body Sprint is Sprint_Node (Condition (Node)); else Write_Str_With_Col_Check_Sloc ("for "); + if Present (Iterator_Specification (Node)) then Sprint_Node (Iterator_Specification (Node)); else -- 2.7.4