From: Arnaud Charlet Date: Tue, 12 Oct 2010 10:41:11 +0000 (+0200) Subject: [multiple changes] X-Git-Tag: upstream/12.2.0~89451 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=f0709ca650996f4df1d8d9a7015b8dc127ea3ed3;p=platform%2Fupstream%2Fgcc.git [multiple changes] 2010-10-12 Robert Dewar * sem_ch6.adb (Process_PPCs): Handle inherited postconditions. 2010-10-12 Arnaud Charlet * exp_disp.adb (Set_All_DT_Position): Disable emit error message on abstract inherited private operation in CodePeer mode. From-SVN: r165358 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b473f21..bc7f0b4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2010-10-12 Robert Dewar + + * sem_ch6.adb (Process_PPCs): Handle inherited postconditions. + +2010-10-12 Arnaud Charlet + + * exp_disp.adb (Set_All_DT_Position): Disable emit error message on + abstract inherited private operation in CodePeer mode. + 2010-10-12 Thomas Quinot * a-exetim.ads: Minor reformatting. diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index ce9c335..93bada1 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -7536,7 +7536,11 @@ package body Exp_Disp is -- excluded from this check because interfaces must be visible in -- the public and private part (RM 7.3 (7.3/2)) - if Is_Abstract_Type (Typ) + -- We disable this check in CodePeer mode, to accomodate legacy + -- Ada code. + + if not CodePeer_Mode + and then Is_Abstract_Type (Typ) and then Is_Abstract_Subprogram (Prim) and then Present (Alias (Prim)) and then not Is_Interface diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index ea919c0..4b16ae6 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4636,10 +4636,12 @@ package body Sem_Ch6 is and then (not Is_Hidden (Overridden_Subp) or else ((Chars (Overridden_Subp) = Name_Initialize - or else Chars (Overridden_Subp) = Name_Adjust - or else Chars (Overridden_Subp) = Name_Finalize) - and then Present (Alias (Overridden_Subp)) - and then not Is_Hidden (Alias (Overridden_Subp)))) + or else + Chars (Overridden_Subp) = Name_Adjust + or else + Chars (Overridden_Subp) = Name_Finalize) + and then Present (Alias (Overridden_Subp)) + and then not Is_Hidden (Alias (Overridden_Subp)))) then if Must_Not_Override (Spec) then Error_Msg_Sloc := Sloc (Overridden_Subp); @@ -8584,25 +8586,58 @@ package body Sem_Ch6 is Body_Id : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); + Plist : List_Id := No_List; Prag : Node_Id; - Plist : List_Id := No_List; Subp : Entity_Id; Parms : List_Id; - function Grab_PPC (Nam : Name_Id) return Node_Id; - -- Prag contains an analyzed precondition or postcondition pragma. - -- This function copies the pragma, changes it to the corresponding - -- Check pragma and returns the Check pragma as the result. The - -- argument Nam is either Name_Precondition or Name_Postcondition. + function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id; + -- Prag contains an analyzed precondition or postcondition pragma. This + -- function copies the pragma, changes it to the corresponding Check + -- pragma and returns the Check pragma as the result. If Pspec is non- + -- empty, this is the case of inheriting a PPC, where we must change + -- references to parameters of the inherited subprogram to point to the + -- corresponding parameters of the current subprogram. -------------- -- Grab_PPC -- -------------- - function Grab_PPC (Nam : Name_Id) return Node_Id is - CP : constant Node_Id := New_Copy_Tree (Prag); + function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id is + Nam : constant Name_Id := Pragma_Name (Prag); + Map : Elist_Id; + CP : Node_Id; begin + -- Prepare map if this is the case where we have to map entities of + -- arguments in the overridden subprogram to corresponding entities + -- of the current subprogram. + + if No (Pspec) then + Map := No_Elist; + + else + declare + PF : Entity_Id; + CF : Entity_Id; + + begin + Map := New_Elmt_List; + PF := First_Formal (Pspec); + CF := First_Formal (Spec_Id); + while Present (PF) loop + Append_Elmt (PF, Map); + Append_Elmt (CF, Map); + Next_Formal (PF); + Next_Formal (CF); + end loop; + end; + end if; + + -- Now we can copy the tree, doing any required substituations + + CP := New_Copy_Tree (Prag, Map => Map, New_Scope => Current_Scope); + -- Set Analyzed to false, since we want to reanalyze the check -- procedure. Note that it is only at the outer level that we -- do this fiddling, for the spec cases, the already preanalyzed @@ -8630,6 +8665,23 @@ package body Sem_Ch6 is Make_Identifier (Sloc (Prag), Chars => Name_Check)); + -- If this is inherited case then the current message starts with + -- "failed p" and we change this to "failed inherited p". + + if Present (Pspec) then + String_To_Name_Buffer + (Strval (Expression (Last (Pragma_Argument_Associations (CP))))); + pragma Assert (Name_Buffer (1 .. 8) = "failed p"); + Name_Len := Name_Len + 10; + Name_Buffer (17 .. Name_Len) := Name_Buffer (7 .. Name_Len - 10); + Name_Buffer (7 .. 16) := " inherited"; + Set_Strval + (Expression (Last (Pragma_Argument_Associations (CP))), + String_From_Name_Buffer); + end if; + + -- Return the check pragma + return CP; end Grab_PPC; @@ -8660,7 +8712,7 @@ package body Sem_Ch6 is -- which is what we want since new entries were chained to -- the head of the list. - Prepend (Grab_PPC (Name_Precondition), Declarations (N)); + Prepend (Grab_PPC, Declarations (N)); end if; Prag := Next_Pragma (Prag); @@ -8698,13 +8750,13 @@ package body Sem_Ch6 is Analyze (Prag); - -- If expansion is disabled, as in a generic unit, - -- save pragma for later expansion. + -- If expansion is disabled, as in a generic unit, save + -- pragma for later expansion. if not Expander_Active then - Prepend (Grab_PPC (Name_Postcondition), Declarations (N)); + Prepend (Grab_PPC, Declarations (N)); else - Append (Grab_PPC (Name_Postcondition), Plist); + Append (Grab_PPC, Plist); end if; end if; @@ -8726,27 +8778,78 @@ package body Sem_Ch6 is -- Now deal with any postconditions from the spec if Present (Spec_Id) then + declare + Parent_Op : Node_Id; + + procedure Process_Post_Conditions + (Spec : Node_Id; + Class : Boolean); + -- This processes the Spec_PPC_List from Spec, processing any + -- postconditions from the list. If Class is True, then only + -- postconditions marked with Class_Present are considered. + -- The caller has checked that Spec_PPC_List is non-Empty. + + ----------------------------- + -- Process_Post_Conditions -- + ----------------------------- + + procedure Process_Post_Conditions + (Spec : Node_Id; + Class : Boolean) + is + Pspec : Node_Id; - -- Loop through PPC pragmas from spec - - Prag := Spec_PPC_List (Spec_Id); - while Present (Prag) loop - if Pragma_Name (Prag) = Name_Postcondition - and then Pragma_Enabled (Prag) - then - if Plist = No_List then - Plist := Empty_List; - end if; - - if not Expander_Active then - Prepend (Grab_PPC (Name_Postcondition), Declarations (N)); + begin + if Class then + Pspec := Spec; else - Append (Grab_PPC (Name_Postcondition), Plist); + Pspec := Empty; end if; + + -- Loop through PPC pragmas from spec + + Prag := Spec_PPC_List (Spec); + loop + if Pragma_Name (Prag) = Name_Postcondition + and then Pragma_Enabled (Prag) + and then (not Class or else Class_Present (Prag)) + then + if Plist = No_List then + Plist := Empty_List; + end if; + + if not Expander_Active then + Prepend + (Grab_PPC (Pspec), Declarations (N)); + else + Append (Grab_PPC (Pspec), Plist); + end if; + end if; + + Prag := Next_Pragma (Prag); + exit when No (Prag); + end loop; + end Process_Post_Conditions; + + begin + if Present (Spec_PPC_List (Spec_Id)) then + Process_Post_Conditions (Spec_Id, Class => False); end if; - Prag := Next_Pragma (Prag); - end loop; + -- Process directly inherited specifications + + Parent_Op := Spec_Id; + loop + Parent_Op := Overridden_Operation (Parent_Op); + exit when No (Parent_Op); + + if Ekind (Parent_Op) /= E_Enumeration_Literal + and then Present (Spec_PPC_List (Parent_Op)) + then + Process_Post_Conditions (Parent_Op, Class => True); + end if; + end loop; + end; end if; -- If we had any postconditions and expansion is enabled, build @@ -8773,6 +8876,7 @@ package body Sem_Ch6 is Make_Defining_Identifier (Loc, Chars => Name_uPostconditions); -- The entity for the _Postconditions procedure + begin Prepend_To (Declarations (N), Make_Subprogram_Body (Loc,