diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 31 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/exp_ch8.adb | 68 | ||||
| -rw-r--r-- | gcc/ada/par-ch13.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/par-ch4.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/par-util.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/snames.adb-tmpl | 11 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 15 |
10 files changed, 89 insertions, 80 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 627ccaf..57d3b04 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2012-07-09 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb: Extend previous change to elementary types. + +2012-07-09 Javier Miranda <miranda@adacore.com> + + * exp_ch8.adb (Expand_N_Subprogram_Renaming_Declaration): Reverse + previous patch since unconditionally handling as renaming_as_body + renamings of predefined dispatching equality and unequality operator + cause visibility problems with private overridings of the equality + operator (see ACATS C854001). + +2012-07-09 Vincent Pucci <pucci@adacore.com> + + * exp_attr.adb (Signal_Bad_Attribute): Raise Program_Error in + case of internal attribute names (already rejected by the parser). + * par-ch13.adb (P_Representation_Clause): Complain if an internal + attribute name that comes from source occurs. + * par-ch4.adb (P_Name): Complain if an internal attribute name + occurs in the context of an attribute reference. + * par-util.adb (Signal_Bad_Attribute): Don't complain about + mispelling attribute with internal attributes. + * sem_attr.adb (Analyze_Attribute): Raise Program_Error in case + of internal attribute names (already rejected by the parser). + * snames.adb-tmpl (Is_Internal_Attribute_Name): New routine. + * snames.ads-tmpl: Attributes CPU, Dispatching_Domain and + Interrupt_Priority are marked as INT attributes since they + don't denote real attribute and are only used internally in + the compiler. + (Is_Internal_Attribute_Name): New routine. + 2012-07-09 Thomas Quinot <quinot@adacore.com> * einfo.adb (Set_Reverse_Storage_Order): Update assertion, diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index ad75f90..5859b6e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -835,13 +835,16 @@ package body Exp_Attr is Attribute_Default_Iterator | Attribute_Implicit_Dereference | Attribute_Iterator_Element | - Attribute_Variable_Indexing => null; + Attribute_Variable_Indexing => + null; - -- Attributes related to Ada 2012 aspects + -- Internal attributes used to deal with Ada 2012 delayed aspects + -- (already diagnosed by parser, thus nothing more to do here). when Attribute_CPU | Attribute_Dispatching_Domain | - Attribute_Interrupt_Priority => null; + Attribute_Interrupt_Priority => + raise Program_Error; ------------ -- Access -- diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 3647ceb..b0e525e 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -300,8 +300,7 @@ package body Exp_Ch8 is -- Handle cases where we build a body for a renamed equality if Is_Entity_Name (Nam) - and then (Chars (Entity (Nam)) = Name_Op_Ne - or else Chars (Entity (Nam)) = Name_Op_Eq) + and then Chars (Entity (Nam)) = Name_Op_Eq and then Scope (Entity (Nam)) = Standard_Standard then declare @@ -315,7 +314,6 @@ package body Exp_Ch8 is -- untagged record type (AI05-0123). if Ada_Version >= Ada_2012 - and then Chars (Entity (Nam)) = Name_Op_Eq and then Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) @@ -337,71 +335,11 @@ package body Exp_Ch8 is Expand_Record_Equality (Id, Typ => Typ, - Lhs => - Make_Identifier (Loc, Chars (First_Formal (Id))), - Rhs => - Make_Identifier - (Loc, Chars (Next_Formal (First_Formal (Id)))), + Lhs => Make_Identifier (Loc, Chars (Left)), + Rhs => Make_Identifier (Loc, Chars (Right)), Bodies => Declarations (Decl)))))); Append (Decl, List_Containing (N)); - - -- Handle renamings of predefined dispatching equality operators. - -- When we analyze a renaming of the equality operator of a tagged - -- type, the predefined dispatching primitives are not available - -- (since they are added by the expander when the tagged type is - -- frozen) and hence they are left decorated as renamings of the - -- standard non-dispatching operators. Here we generate a body - -- for such renamings which invokes the predefined dispatching - -- equality operator. - - -- Example: - - -- type T is tagged null record; - -- function Eq (X, Y : T1) return Boolean renames "="; - -- function Neq (X, Y : T1) return Boolean renames "/="; - - elsif Is_Record_Type (Typ) - and then Is_Tagged_Type (Typ) - and then Is_Dispatching_Operation (Id) - and then not Is_Dispatching_Operation (Entity (Nam)) - then - pragma Assert (not Is_Frozen (Typ)); - - Decl := Build_Body_For_Renaming; - - -- Clean decoration of intrinsic subprogram - - Set_Is_Intrinsic_Subprogram (Id, False); - Set_Convention (Id, Convention_Ada); - - if Chars (Entity (Nam)) = Name_Op_Ne then - Set_Handled_Statement_Sequence (Decl, - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Make_Op_Not (Loc, - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (Left, Loc), - Right_Opnd => - New_Reference_To (Right, Loc))))))); - - else pragma Assert (Chars (Entity (Nam)) = Name_Op_Eq); - Set_Handled_Statement_Sequence (Decl, - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (Left, Loc), - Right_Opnd => - New_Reference_To (Right, Loc)))))); - end if; - - Append (Decl, List_Containing (N)); end if; end; end if; diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 9526e32..79d9098 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -221,7 +221,14 @@ package body Ch13 is if Token = Tok_Identifier then Attr_Name := Token_Name; - if not Is_Attribute_Name (Attr_Name) then + -- Note that the parser must complain in case of an internal + -- attribute names that comes from source since internal names + -- are meant to be used only by the compiler. + + if not Is_Attribute_Name (Attr_Name) + or else (Is_Internal_Attribute_Name (Attr_Name) + and then Comes_From_Source (Token_Node)) + then Signal_Bad_Attribute; end if; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 79aa85f..f16d828 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -434,7 +434,12 @@ package body Ch4 is elsif Token = Tok_Identifier then Attr_Name := Token_Name; - if not Is_Attribute_Name (Attr_Name) then + -- Note that internal attributes names don't denote real + -- attribute. + + if not Is_Attribute_Name (Attr_Name) + or else Is_Internal_Attribute_Name (Attr_Name) + then if Apostrophe_Should_Be_Semicolon then Expr_Form := EF_Name; return Name_Node; diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index f281c79..eb19a0a 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -721,7 +721,12 @@ package body Util is Error_Msg_Name_1 := First_Attribute_Name; while Error_Msg_Name_1 <= Last_Attribute_Name loop - if Is_Bad_Spelling_Of (Token_Name, Error_Msg_Name_1) then + -- No mispelling possible with internal attribute names since they + -- don't denote real attribute. + + if not Is_Internal_Attribute_Name (Error_Msg_Name_1) + and then Is_Bad_Spelling_Of (Token_Name, Error_Msg_Name_1) + then Error_Msg_N -- CODEFIX ("\possible misspelling of %", Token_Node); exit; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index efb6037f..dd5faef 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -2215,13 +2215,13 @@ package body Sem_Attr is Attribute_Variable_Indexing => Error_Msg_N ("illegal attribute", N); - -- Attributes related to Ada 2012 aspects. Attribute definition clause - -- exists for these, but they cannot be queried. + -- Internal attributes used to deal with Ada 2012 delayed aspects + -- (already diagnosed by parser, thus nothing more to do here). when Attribute_CPU | Attribute_Dispatching_Domain | Attribute_Interrupt_Priority => - Error_Msg_N ("illegal attribute", N); + raise Program_Error; ------------------ -- Abort_Signal -- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index e475000..049ba05 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -7737,10 +7737,10 @@ package body Sem_Ch13 is -- Reject patently improper size values. - if Is_Scalar_Type (T) + if Is_Elementary_Type (T) and then Siz > UI_From_Int (Int'Last) then - Error_Msg_N ("Size value too large for scalar type", N); + Error_Msg_N ("Size value too large for elementary type", N); if Nkind (Original_Node (N)) = N_Op_Expon then Error_Msg_N ("\maybe '* was meant, rather than '*'*", Original_Node (N)); diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index 4ac3c22..da17d310 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -392,6 +392,17 @@ package body Snames is or else N not in Ada_2012_Reserved_Words); end Is_Keyword_Name; + -------------------------------- + -- Is_Internal_Attribute_Name -- + -------------------------------- + + function Is_Internal_Attribute_Name (N : Name_Id) return Boolean is + begin + return N = Name_CPU + or N = Name_Interrupt_Priority + or N = Name_Dispatching_Domain; + end Is_Internal_Attribute_Name; + ---------------------------- -- Is_Locking_Policy_Name -- ---------------------------- diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index bffc420..1697957 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -753,6 +753,11 @@ package Snames is -- implementation dependent attributes may be found in the appropriate -- section in Sem_Attr. + -- The entries marked INT are not real attributes. They are special names + -- used internally by GNAT in order to deal with delayed aspects + -- (Aspect_CPU, Aspect_Dispatching_Domain, Aspect_Interrupt_Priority) that + -- don't have corresponding pragma or attribute. + -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. @@ -779,7 +784,7 @@ package Snames is Name_Constant_Indexing : constant Name_Id := N + $; -- GNAT Name_Constrained : constant Name_Id := N + $; Name_Count : constant Name_Id := N + $; - Name_CPU : constant Name_Id := N + $; -- Ada 12 + Name_CPU : constant Name_Id := N + $; -- INT Name_Default_Bit_Order : constant Name_Id := N + $; -- GNAT Name_Default_Iterator : constant Name_Id := N + $; -- GNAT Name_Definite : constant Name_Id := N + $; @@ -787,7 +792,7 @@ package Snames is Name_Denorm : constant Name_Id := N + $; Name_Descriptor_Size : constant Name_Id := N + $; Name_Digits : constant Name_Id := N + $; - Name_Dispatching_Domain : constant Name_Id := N + $; -- Ada 12 + Name_Dispatching_Domain : constant Name_Id := N + $; -- INT Name_Elaborated : constant Name_Id := N + $; -- GNAT Name_Emax : constant Name_Id := N + $; -- Ada 83 Name_Enabled : constant Name_Id := N + $; -- GNAT @@ -809,7 +814,7 @@ package Snames is Name_Img : constant Name_Id := N + $; -- GNAT Name_Implicit_Dereference : constant Name_Id := N + $; -- GNAT Name_Integer_Value : constant Name_Id := N + $; -- GNAT - Name_Interrupt_Priority : constant Name_Id := N + $; -- Ada 12 + Name_Interrupt_Priority : constant Name_Id := N + $; -- INT Name_Invalid_Value : constant Name_Id := N + $; -- GNAT Name_Iterator_Element : constant Name_Id := N + $; -- GNAT Name_Large : constant Name_Id := N + $; -- Ada 83 @@ -1826,6 +1831,10 @@ package Snames is -- Test to see if the name N is the name of a recognized entity attribute, -- i.e. an attribute reference that returns an entity. + function Is_Internal_Attribute_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of an INT attribute (Name_CPU, + -- Name_Dispatching_Domain, Name_Interrupt_Priority). + function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean; -- Test to see if the name N is the name of a recognized attribute that -- designates a procedure (and can therefore appear as a statement). |