From acf49e88aaf315ea29c1b96950a91bffd7e7ea3d Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Fri, 17 Feb 2012 14:17:21 +0000 Subject: [PATCH] sem_prag.adb (Analyze_PPC_In_Decl_Part): Pre'Class and Post'Class aspects can only be specified for a primitive... 2012-02-17 Steve Baird * sem_prag.adb (Analyze_PPC_In_Decl_Part): Pre'Class and Post'Class aspects can only be specified for a primitive operation of a tagged type. From-SVN: r184342 --- gcc/ada/ChangeLog | 6 ++++++ gcc/ada/sem_prag.adb | 43 +++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 47 insertions(+), 2 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a7e3dee..4aba46d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2012-02-17 Steve Baird + + * sem_prag.adb (Analyze_PPC_In_Decl_Part): Pre'Class and + Post'Class aspects can only be specified for a primitive operation + of a tagged type. + 2012-02-17 Yannick Moy * gnat_rm.texi: Minor shuffling. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9098d53..f1ea658 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -278,13 +278,19 @@ package body Sem_Prag is -- overriding operation (see ARM12 6.6.1 (7)). if Class_Present (N) then - declare + Class_Wide_Condition : declare T : constant Entity_Id := Find_Dispatching_Type (S); ACW : Entity_Id := Empty; -- Access to T'class, created if there is a controlling formal -- that is an access parameter. + function Aspect_Name return String; + -- Return the name of the aspect being specified ("Pre" or "Post") + -- properly capitalized for use in an error message. Precondition + -- is Present (Corresponding_Aspect (N)), which will be satisfied + -- if Class_Present (N). + function Get_ACW return Entity_Id; -- If the expression has a reference to an controlling access -- parameter, create an access to T'class for the necessary @@ -299,6 +305,19 @@ package body Sem_Prag is -- type access-to-T'Class. This ensures the expression is well- -- defined for a primitive subprogram of a type descended from T. + ----------------- + -- Aspect_Name -- + ----------------- + + function Aspect_Name return String is + begin + if Chars (Identifier (Corresponding_Aspect (N))) = Name_Pre then + return "Pre"; + else + return "Post"; + end if; + end Aspect_Name; + ------------- -- Get_ACW -- ------------- @@ -365,9 +384,29 @@ package body Sem_Prag is procedure Replace_Type is new Traverse_Proc (Process); + -- Start of processing for Class_Wide_Condition + begin + if not Present (T) then + + -- This is weird code, why not just set Err_Msg_Name_1 to + -- Identifier (Corresponding_Aspect (N)), and Err_Msg_Name_2 + -- to Name_Class and then use + + -- "aspect `%''%` can only be specified ... + + -- That would be the more normal way of doing things ??? + -- Then you get proper identifier casing mode as well, + -- instead of presuming mixed case ??? + + Error_Msg_N + ("aspect " & Aspect_Name & "''Class can only be specified " & + "for a primitive operation of a tagged type", + Corresponding_Aspect (N)); + end if; + Replace_Type (Get_Pragma_Arg (Arg1)); - end; + end Class_Wide_Condition; end if; -- Remove the subprogram from the scope stack now that the pre-analysis -- 2.7.4