diff options
Diffstat (limited to 'gcc/ada/sem_prag.adb')
| -rw-r--r-- | gcc/ada/sem_prag.adb | 44 |
1 files changed, 42 insertions, 2 deletions
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index d564b1e590e..f1ea658a10b 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 @@ -1818,6 +1857,7 @@ package body Sem_Prag is ("aspect % requires ''Class for null procedure"); elsif not Nkind_In (PO, N_Subprogram_Declaration, + N_Expression_Function, N_Generic_Subprogram_Declaration, N_Entry_Declaration) then |