diff options
| author | Steve Baird <baird@adacore.com> | 2012-02-17 14:17:21 +0000 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2012-02-17 15:17:21 +0100 |
| commit | acf49e88aaf315ea29c1b96950a91bffd7e7ea3d (patch) | |
| tree | 70f44e7069c5df96d0c1ada4e8eb0630c6084213 | |
| parent | 794b9b72402dbb9eb2182b2fd046322ea2614bc8 (diff) | |
| download | gcc-acf49e88aaf315ea29c1b96950a91bffd7e7ea3d.zip gcc-acf49e88aaf315ea29c1b96950a91bffd7e7ea3d.tar.gz gcc-acf49e88aaf315ea29c1b96950a91bffd7e7ea3d.tar.bz2 | |
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 <baird@adacore.com>
* 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
| -rw-r--r-- | gcc/ada/ChangeLog | 6 | ||||
| -rw-r--r-- | 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 <baird@adacore.com> + + * 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 <moy@adacore.com> * 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 |