From 811ef5ba910ae7449d73226143271a89d1da6936 Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Tue, 12 Oct 2010 10:20:00 +0000 Subject: [PATCH] par-ch13.adb (P_Aspect_Specifications): Fix handling of 'Class aspects 2010-10-12 Robert Dewar * par-ch13.adb (P_Aspect_Specifications): Fix handling of 'Class aspects * sem_ch13.adb (Analyze_Aspect_Specifications): Fix bad Sloc on aspects * sem_prag.adb (Fix_Error): Only change pragma names for pragmas from aspects. (Check_Optional_Identifier): Handle case of direct arguments (Chain_PPC): Test for abstract case, giving appropriate messages * sinfo.ads, sinfo.adb (Class_Present): Allowed on N_Pragma node From-SVN: r165355 --- gcc/ada/ChangeLog | 10 +++++++ gcc/ada/par-ch13.adb | 7 +++-- gcc/ada/sem_ch13.adb | 54 +++++++++++++++++++--------------- gcc/ada/sem_prag.adb | 70 ++++++++++++++++++++++++++++++++++++-------- gcc/ada/sinfo.adb | 6 ++-- gcc/ada/sinfo.ads | 1 + 6 files changed, 109 insertions(+), 39 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 02f1e543cd7..5daf93f4c8c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2010-10-12 Robert Dewar + + * par-ch13.adb (P_Aspect_Specifications): Fix handling of 'Class aspects + * sem_ch13.adb (Analyze_Aspect_Specifications): Fix bad Sloc on aspects + * sem_prag.adb (Fix_Error): Only change pragma names for pragmas from + aspects. + (Check_Optional_Identifier): Handle case of direct arguments + (Chain_PPC): Test for abstract case, giving appropriate messages + * sinfo.ads, sinfo.adb (Class_Present): Allowed on N_Pragma node + 2010-10-12 Robert Dewar * par-endh.adb (Check_End): Don't swallow semicolon or aspects after diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 85067438bee..890a8b4bbfa 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -409,10 +409,9 @@ package body Ch13 is -- We have an identifier (which should be an aspect identifier) - Aspect := Token_Node; A_Id := Get_Aspect_Id (Token_Name); Aspect := - Make_Aspect_Specification (Sloc (Aspect), + Make_Aspect_Specification (Token_Ptr, Identifier => Token_Node); -- No valid aspect identifier present @@ -465,6 +464,10 @@ package body Ch13 is if Token = Tok_Identifier then Scan; -- past identifier not CLASS end if; + + else + Scan; -- past CLASS + Set_Class_Present (Aspect); end if; end if; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 71966d87937..9d15092317e 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -663,10 +663,11 @@ package body Sem_Ch13 is Aspect := First (L); while Present (Aspect) loop declare - Id : constant Node_Id := Identifier (Aspect); - Expr : constant Node_Id := Expression (Aspect); - Nam : constant Name_Id := Chars (Id); - A_Id : constant Aspect_Id := Get_Aspect_Id (Nam); + Loc : constant Source_Ptr := Sloc (Aspect); + Id : constant Node_Id := Identifier (Aspect); + Expr : constant Node_Id := Expression (Aspect); + Nam : constant Name_Id := Chars (Id); + A_Id : constant Aspect_Id := Get_Aspect_Id (Nam); Anod : Node_Id; T : Entity_Id; @@ -728,7 +729,7 @@ package body Sem_Ch13 is -- Build corresponding pragma node Aitem := - Make_Pragma (Sloc (Aspect), + Make_Pragma (Loc, Pragma_Argument_Associations => New_List (Ent), Pragma_Identifier => Make_Identifier (Sloc (Id), Chars (Id))); @@ -797,7 +798,7 @@ package body Sem_Ch13 is -- Construct the attribute definition clause Aitem := - Make_Attribute_Definition_Clause (Sloc (Aspect), + Make_Attribute_Definition_Clause (Loc, Name => Ent, Chars => Chars (Id), Expression => Relocate_Node (Expr)); @@ -823,7 +824,7 @@ package body Sem_Ch13 is -- Construct the pragma Aitem := - Make_Pragma (Sloc (Aspect), + Make_Pragma (Loc, Pragma_Argument_Associations => New_List ( New_Occurrence_Of (E, Sloc (Expr)), Relocate_Node (Expr)), @@ -844,54 +845,61 @@ package body Sem_Ch13 is -- Construct the pragma Aitem := - Make_Pragma (Sloc (Aspect), + Make_Pragma (Loc, Pragma_Argument_Associations => New_List ( Relocate_Node (Expr), New_Occurrence_Of (E, Sloc (Expr))), Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); + Make_Identifier (Sloc (Id), Chars (Id)), + Class_Present => Class_Present (Aspect)); -- We don't have to play the delay game here, since the only -- values are check names which don't get analyzed anyway. Delay_Required := False; - -- Aspect Post corresponds to pragma Postcondition with single + -- Aspect Pre corresponds to pragma Precondition with single -- argument that is the expression (we never give a message - -- argument. This is inserted right after the declaration, + -- argument). This is inserted right after the declaration, -- to get the required pragma placement. - when Aspect_Post => + when Aspect_Pre => -- Construct the pragma Aitem := - Make_Pragma (Sloc (Expr), - Pragma_Argument_Associations => New_List ( - Relocate_Node (Expr)), + Make_Pragma (Loc, Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Postcondition)); + Make_Identifier (Sloc (Id), Name_Precondition), + Class_Present => Class_Present (Aspect), + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Expr), + Chars => Name_Check, + Expression => Relocate_Node (Expr)))); -- We don't have to play the delay game here. The required -- delay in this case is already implemented by the pragma. Delay_Required := False; - -- Aspect Pre corresponds to pragma Precondition with single + -- Aspect Post corresponds to pragma Postcondition with single -- argument that is the expression (we never give a message - -- argument). This is inserted right after the declaration, + -- argument. This is inserted right after the declaration, -- to get the required pragma placement. - when Aspect_Pre => + when Aspect_Post => -- Construct the pragma Aitem := - Make_Pragma (Sloc (Expr), - Pragma_Argument_Associations => New_List ( - Relocate_Node (Expr)), + Make_Pragma (Sloc (Aspect), Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Precondition)); + Make_Identifier (Sloc (Id), Name_Postcondition), + Class_Present => Class_Present (Aspect), + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Expr), + Chars => Name_Check, + Expression => Relocate_Node (Expr)))); -- We don't have to play the delay game here. The required -- delay in this case is already implemented by the pragma. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c7414b94d9a..da5c60117f0 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -566,9 +566,8 @@ package body Sem_Prag is -- This is called prior to issuing an error message. Msg is a string -- which typically contains the substring pragma. If the current pragma -- comes from an aspect, each such "pragma" substring is replaced with - -- the characters "aspect", and in addition, if Error_Msg_Name_1 is - -- Name_Precondition (resp Name_Postcondition) it is replaced with - -- Name_Pre (resp Name_Post). + -- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition + -- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post). procedure Gather_Associations (Names : Name_List; @@ -1463,7 +1462,10 @@ package body Sem_Prag is procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is begin - if Present (Arg) and then Chars (Arg) /= No_Name then + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + and then Chars (Arg) /= No_Name + then if Chars (Arg) /= Id then Error_Msg_Name_1 := Pname; Error_Msg_Name_2 := Id; @@ -1499,11 +1501,26 @@ package body Sem_Prag is --------------- procedure Chain_PPC (PO : Node_Id) is - S : Node_Id; + S : Entity_Id; + P : Node_Id; begin - if not Nkind_In (PO, N_Subprogram_Declaration, - N_Generic_Subprogram_Declaration) + if Nkind (PO) = N_Abstract_Subprogram_Declaration then + if not From_Aspect_Specification (N) then + Error_Pragma + ("pragma% cannot be applied to abstract subprogram"); + + elsif Class_Present (N) then + Error_Pragma + ("aspect `%''Class` not implemented yet"); + + else + Error_Pragma + ("aspect % requires ''Class for abstract subprogram"); + end if; + + elsif not Nkind_In (PO, N_Subprogram_Declaration, + N_Generic_Subprogram_Declaration) then Pragma_Misplaced; end if; @@ -1512,6 +1529,35 @@ package body Sem_Prag is S := Defining_Unit_Name (Specification (PO)); + -- Make sure we do not have the case of a pre/postcondition + -- pragma when the corresponding aspect is present. This is + -- never allowed. We allow either pragmas or aspects, not both. + + -- We do this by looking at pragmas already chained to the entity + -- since the aspect derived pragma will be put on this list first. + + if not From_Aspect_Specification (N) then + P := Spec_PPC_List (S); + while Present (P) loop + if Pragma_Name (P) = Pragma_Name (N) + and then From_Aspect_Specification (P) + then + Error_Msg_Sloc := Sloc (P); + + if Prag_Id = Pragma_Precondition then + Error_Msg_Name_2 := Name_Pre; + else + Error_Msg_Name_2 := Name_Post; + end if; + + Error_Pragma + ("pragma% not allowed, % aspect given#"); + end if; + + P := Next_Pragma (P); + end loop; + end if; + -- Analyze the pragma unless it appears within a package spec, -- which is the case where we delay the analysis of the PPC until -- the end of the package declarations (for details, see @@ -2059,12 +2105,12 @@ package body Sem_Prag is Msg (J .. J + 5) := "aspect"; end if; end loop; - end if; - 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; + 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; end if; end Fix_Error; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 5a144846821..ead2fcb8708 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -412,7 +412,8 @@ package body Sinfo is (N : Node_Id) return Boolean is begin pragma Assert (False - or else NT (N).Nkind = N_Aspect_Specification); + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); return Flag6 (N); end Class_Present; @@ -3372,7 +3373,8 @@ package body Sinfo is (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False - or else NT (N).Nkind = N_Aspect_Specification); + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); Set_Flag6 (N, Val); end Set_Class_Present; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index cc2704063ca..a7f4370bd92 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -2028,6 +2028,7 @@ package Sinfo is -- Is_Delayed_Aspect (Flag14-Sem) -- Import_Interface_Present (Flag16-Sem) -- Aspect_Cancel (Flag11-Sem) + -- Class_Present (Flag6) (set False if not from Aspect with 'Class) -- Note: we should have a section on what pragmas are passed on to -- the back end to be processed. This section should note that pragma -- 2.30.2