diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 23 | ||||
| -rw-r--r-- | gcc/ada/a-dispat.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/a-stcoed.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/errout.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/errout.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/namet.adb | 39 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 31 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 32 |
8 files changed, 137 insertions, 35 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3a26255..12f09a3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,28 @@ 2015-02-20 Robert Dewar <dewar@adacore.com> + * a-dispat.adb, a-stcoed.ads: Minor reformatting. + +2015-02-20 Robert Dewar <dewar@adacore.com> + + * sem_ch13.adb (Build_Discrete_Static_Predicate): Allow static + predicate for non-static subtype. + (Build_Predicate_Functions): Do not assume subtype associated with a + static predicate must be static. + +2015-02-20 Robert Dewar <dewar@adacore.com> + + * errout.adb (Set_Msg_Node): Better handling of internal names + (Set_Msg_Node): Kill message when we cannot eliminate internal name. + * errout.ads: Document additional case of message deletion. + * namet.adb (Is_Internal_Name): Refined to consider wide + strings in brackets notation and character literals not to be + internal names. + * sem_ch8.adb (Find_Selected_Component): Give additional error + when selector name is a subprogram whose first parameter has + the same type as the prefix, but that type is untagged. + +2015-02-20 Robert Dewar <dewar@adacore.com> + * g-allein.ads, g-alveop.adb, g-alveop.ads, opt.ads: Minor reformatting 2015-02-20 Tristan Gingold <gingold@adacore.com> diff --git a/gcc/ada/a-dispat.adb b/gcc/ada/a-dispat.adb index b00a17f..3525c4e 100644 --- a/gcc/ada/a-dispat.adb +++ b/gcc/ada/a-dispat.adb @@ -37,7 +37,7 @@ package body Ada.Dispatching is procedure Yield is Self_Id : constant System.Tasking.Task_Id := - System.Task_Primitives.Operations.Self; + System.Task_Primitives.Operations.Self; begin -- If pragma Detect_Blocking is active, Program_Error must be diff --git a/gcc/ada/a-stcoed.ads b/gcc/ada/a-stcoed.ads index a6436ff..0d39cc3 100644 --- a/gcc/ada/a-stcoed.ads +++ b/gcc/ada/a-stcoed.ads @@ -27,5 +27,5 @@ package Ada.Synchronous_Task_Control.EDF is procedure Suspend_Until_True_And_Set_Deadline (S : in out Suspension_Object; - TS : Ada.Real_Time.Time_Span); + TS : Ada.Real_Time.Time_Span); end Ada.Synchronous_Task_Control.EDF; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index bb8fb08..d236bb5 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -2792,18 +2792,29 @@ package body Errout is Nam := Pragma_Name (Node); Loc := Sloc (Node); - -- The other cases have Chars fields, and we want to test for possible - -- internal names, which generally represent something gone wrong. An - -- exception is the case of internal type names, where we try to find a - -- reasonable external representation for the external name + -- The other cases have Chars fields + + -- First deal with internal names, which generally represent something + -- gone wrong. First attempt: if this is a rewritten node that rewrites + -- something with a Chars field that is not an internal name, use that. + + elsif Is_Internal_Name (Chars (Node)) + and then Nkind (Original_Node (Node)) in N_Has_Chars + and then not Is_Internal_Name (Chars (Original_Node (Node))) + then + Nam := Chars (Original_Node (Node)); + Loc := Sloc (Original_Node (Node)); + + -- Another shot for internal names, in the case of internal type names, + -- we try to find a reasonable representation for the external name. elsif Is_Internal_Name (Chars (Node)) and then ((Is_Entity_Name (Node) - and then Present (Entity (Node)) - and then Is_Type (Entity (Node))) - or else - (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node))) + and then Present (Entity (Node)) + and then Is_Type (Entity (Node))) + or else + (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node))) then if Nkind (Node) = N_Identifier then Ent := Entity (Node); @@ -2826,7 +2837,8 @@ package body Errout is Nam := Chars (Ent); end if; - -- If not internal name, just use name in Chars field + -- If not internal name, or if we could not find a reasonable possible + -- substitution for the internal name, just use name in Chars field. else Nam := Chars (Node); @@ -2854,6 +2866,12 @@ package body Errout is Kill_Message := True; end if; + -- If we still have an internal name, kill the message (will only + -- work if we already had errors!) + + if Is_Internal_Name then + Kill_Message := True; + end if; -- Remaining step is to adjust casing and possibly add 'Class Adjust_Name_Case (Loc); diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index d189240..d02febe 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -104,6 +104,13 @@ package Errout is -- messages. Warning messages are only suppressed for case 1, and -- when they come from other than the main extended unit. + -- 7. If an error or warning references an internal name, and we have + -- already placed an error (not warning) message at that location, + -- then we assume this is cascaded junk and delete the message. + + -- This normal suppression action may be overridden in cases 2-5 (but not + -- in case 1 or 7 by setting All_Errors mode, or by setting the special + -- unconditional message insertion character (!) as described below. -- This normal suppression action may be overridden in cases 2-5 (but -- not in case 1) by setting All_Errors mode, or by setting the special -- unconditional message insertion character (!) as described below. diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 0eab3a1..9de0fec 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -833,8 +833,12 @@ package body Namet is function Is_Internal_Name (Id : Name_Id) return Boolean is begin - Get_Name_String (Id); - return Is_Internal_Name; + if Id in Error_Name_Or_No_Name then + return False; + else + Get_Name_String (Id); + return Is_Internal_Name; + end if; end Is_Internal_Name; ---------------------- @@ -844,18 +848,41 @@ package body Namet is -- Version taking its input from Name_Buffer function Is_Internal_Name return Boolean is + J : Natural; + begin + -- AAny name starting with underscore is internal + if Name_Buffer (1) = '_' or else Name_Buffer (Name_Len) = '_' then return True; + -- Allow quoted character + + elsif Name_Buffer (1) = ''' then + return False; + + -- All other cases, scan name + else -- Test backwards, because we only want to test the last entity -- name if the name we have is qualified with other entities. - for J in reverse 1 .. Name_Len loop - if Is_OK_Internal_Letter (Name_Buffer (J)) then + J := Name_Len; + while J /= 0 loop + + -- Skip stuff between brackets (A-F OK there) + + if Name_Buffer (J) = ']' then + loop + J := J - 1; + exit when J = 1 or else Name_Buffer (J) = '['; + end loop; + + -- Test for internal letter + + elsif Is_OK_Internal_Letter (Name_Buffer (J)) then return True; -- Quit if we come to terminating double underscore (note that @@ -869,6 +896,8 @@ package body Namet is then return False; end if; + + J := J - 1; end loop; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index f717523..ed86d90f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6681,9 +6681,11 @@ package body Sem_Ch13 is BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp)); -- Low bound and high bound value of base type of Typ - TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ)); - THi : constant Uint := Expr_Value (Type_High_Bound (Typ)); - -- Low bound and high bound values of static subtype Typ + TLo : Uint; + THi : Uint; + -- Bounds for constructing the static predicate. We use the bound of the + -- subtype if it is static, otherwise the corresponding base type bound. + -- Note: a non-static subtype can have a static predicate. type REnt is record Lo, Hi : Uint; @@ -7406,6 +7408,20 @@ package body Sem_Ch13 is -- Start of processing for Build_Discrete_Static_Predicate begin + -- Establish bounds for the predicate + + if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then + TLo := Expr_Value (Type_Low_Bound (Typ)); + else + TLo := BLo; + end if; + + if Compile_Time_Known_Value (Type_High_Bound (Typ)) then + THi := Expr_Value (Type_High_Bound (Typ)); + else + THi := BHi; + end if; + -- Analyze the expression to see if it is a static predicate declare @@ -8570,15 +8586,6 @@ package body Sem_Ch13 is -- For discrete subtype, build the static predicate list if Is_Discrete_Type (Typ) then - if not Is_Static_Subtype (Typ) then - - -- This can only happen in the presence of previous - -- semantic errors. - - pragma Assert (Serious_Errors_Detected > 0); - return; - end if; - Build_Discrete_Static_Predicate (Typ, Expr, Object_Name); -- If we don't get a static predicate list, it means that we diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index bd01588..c8d81f0 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -6862,20 +6862,38 @@ package body Sem_Ch8 is Premature_Usage (P); elsif Nkind (P) /= N_Attribute_Reference then - Error_Msg_N ( - "invalid prefix in selected component&", P); + + -- This may have been meant as a prefixed call to a primitive + -- of an untagged type. + + declare + F : constant Entity_Id := + Current_Entity (Selector_Name (N)); + begin + if Present (F) + and then Is_Overloadable (F) + and then Present (First_Entity (F)) + and then Etype (First_Entity (F)) = Etype (P) + and then not Is_Tagged_Type (Etype (P)) + then + Error_Msg_N + ("prefixed call is only allowed for objects " + & "of a tagged type", N); + end if; + end; + + Error_Msg_N ("invalid prefix in selected component&", P); if Is_Access_Type (P_Type) and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type then Error_Msg_N - ("\dereference must not be of an incomplete type " & - "(RM 3.10.1)", P); + ("\dereference must not be of an incomplete type " + & "(RM 3.10.1)", P); end if; else - Error_Msg_N ( - "invalid prefix in selected component", P); + Error_Msg_N ("invalid prefix in selected component", P); end if; end if; |