diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 34 | ||||
| -rw-r--r-- | gcc/ada/a-strbou.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/exp_intr.adb | 31 | ||||
| -rw-r--r-- | gcc/ada/exp_prag.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/par.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 3 |
10 files changed, 100 insertions, 45 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ac39123cec2..e108648cf6b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2017-04-25 Bob Duff <duff@adacore.com> + + * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings): + Use Source_Index (Current_Sem_Unit) to find the correct casing. + * exp_prag.adb (Expand_Pragma_Check): Use Source_Index + (Current_Sem_Unit) to find the correct casing. + * par.adb (Par): Null out Current_Source_File, to ensure that + the above bugs won't rear their ugly heads again. + +2017-04-25 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Find_Type): For an attribute reference + 'Class, if prefix type is synchronized and previous errors + have suppressed the creation of the corresponding record type, + create a spurious class-wide for the synchonized type itself, + to catch other misuses of the attribute + +2017-04-25 Steve Baird <baird@adacore.com> + + * exp_ch6.adb (Expand_Simple_Function_Return): if CodePeer_Mode + is True, then don't generate the accessibility check for the + tag of a tagged result. + * exp_intr.adb (Expand_Dispatching_Constructor_Call): + if CodePeer_Mode is True, then don't generate the + tag checks for the result of call to an instance of + Ada.Tags.Generic_Dispatching_Constructor (i.e., both the "is a + descendant of" check and the accessibility check). + +2017-04-25 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb: Code cleanups. + * a-strbou.ads: minor whitespace fix in Trim for bounded strings. + * sem_ch8.ads: Minor comment fix. + 2017-04-25 Eric Botcazou <ebotcazou@adacore.com> * exp_ch4.adb (Library_Level_Target): New function. diff --git a/gcc/ada/a-strbou.ads b/gcc/ada/a-strbou.ads index 7703b728107..5e7a9c71d15 100644 --- a/gcc/ada/a-strbou.ads +++ b/gcc/ada/a-strbou.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -391,8 +391,8 @@ package Ada.Strings.Bounded is function Trim (Source : Bounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return Bounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Bounded_String; procedure Trim (Source : in out Bounded_String; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index cb90fd259cd..8c4868d7eb3 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6635,15 +6635,20 @@ package body Exp_Ch6 is Attribute_Name => Name_Tag); end if; - Insert_Action (Exp, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node), - Right_Opnd => - Make_Integer_Literal (Loc, - Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), - Reason => PE_Accessibility_Check_Failed)); + if not CodePeer_Mode then + -- CodePeer doesn't do anything useful with + -- Ada.Tags.Type_Specific_Data components + + Insert_Action (Exp, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node), + Right_Opnd => + Make_Integer_Literal (Loc, + Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), + Reason => PE_Accessibility_Check_Failed)); + end if; end; -- AI05-0073: If function has a controlling access result, check that diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 4363c75a190..fde0617aa83 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -421,20 +421,22 @@ package body Exp_Intr is Result_Typ := Class_Wide_Type (Etype (Act_Constr)); -- Check that the accessibility level of the tag is no deeper than that - -- of the constructor function. + -- of the constructor function (unless CodePeer_Mode) - Insert_Action (N, - Make_Implicit_If_Statement (N, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => - Build_Get_Access_Level (Loc, New_Copy_Tree (Tag_Arg)), - Right_Opnd => - Make_Integer_Literal (Loc, Scope_Depth (Act_Constr))), - - Then_Statements => New_List ( - Make_Raise_Statement (Loc, - New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + if not CodePeer_Mode then + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + Build_Get_Access_Level (Loc, New_Copy_Tree (Tag_Arg)), + Right_Opnd => + Make_Integer_Literal (Loc, Scope_Depth (Act_Constr))), + + Then_Statements => New_List ( + Make_Raise_Statement (Loc, + New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + end if; if Is_Interface (Etype (Act_Constr)) then @@ -505,10 +507,11 @@ package body Exp_Intr is -- Do not generate a run-time check on the built object if tag -- checks are suppressed for the result type or tagged type expansion - -- is disabled. + -- is disabled or if CodePeer_Mode. if Tag_Checks_Suppressed (Etype (Result_Typ)) or else not Tagged_Type_Expansion + or else CodePeer_Mode then null; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index b8490a74a2c..da6a4c3ab8b 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -33,6 +33,7 @@ with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; with Expander; use Expander; with Inline; use Inline; +with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -432,11 +433,12 @@ package body Exp_Prag is Add_Str_To_Name_Buffer ("failed invariant from "); -- For all other checks, the string is "xxx failed at yyy" - -- where xxx is the check name with current source file casing. + -- where xxx is the check name with appropriate casing. else Get_Name_String (Nam); - Set_Casing (Identifier_Casing (Current_Source_File)); + Set_Casing + (Identifier_Casing (Source_Index (Current_Sem_Unit))); Add_Str_To_Name_Buffer (" failed at "); end if; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 26730d497e6..863149b0cdd 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -1457,6 +1457,8 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is procedure Labl is separate; procedure Load is separate; + Result : List_Id := Empty_List; + -- Start of processing for Par begin @@ -1472,13 +1474,13 @@ begin begin loop if Token = Tok_EOF then - Compiler_State := Analyzing; - return Pragmas; + Result := Pragmas; + exit; elsif Token /= Tok_Pragma then Error_Msg_SC ("only pragmas allowed in configuration file"); - Compiler_State := Analyzing; - return Error_List; + Result := Error_List; + exit; else P_Node := P_Pragma; @@ -1690,7 +1692,9 @@ begin Restore_Opt_Config_Switches (Save_Config_Switches); Set_Comes_From_Source_Default (False); - Compiler_State := Analyzing; - return Empty_List; end if; + + Compiler_State := Analyzing; + Current_Source_File := No_Source_File; + return Result; end Par; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5be65af3d8f..14d71af0746 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1680,7 +1680,7 @@ package body Sem_Ch13 is end if; -- A variable is most likely modified from the outside. Take - -- Take the optimistic approach to avoid spurious errors. + -- the optimistic approach to avoid spurious errors. if Ekind (E) = E_Variable then Set_Never_Set_In_Source (E, False); @@ -3208,13 +3208,15 @@ package body Sem_Ch13 is end if; -- Check that the class-wide predicate cannot be applied to - -- an operation of a synchronized type that is not a tagged - -- type. Other legality checks are performed when analyzing - -- the contract of the operation. + -- an operation of a synchronized type. AI12-0182 forbids + -- these altogether, while earlier language semantics made + -- them legal on tagged synchronized types. + + -- Other legality checks are performed when analyzing the + -- contract of the operation. if Class_Present (Aspect) and then Is_Concurrent_Type (Current_Scope) - and then not Is_Tagged_Type (Current_Scope) and then Ekind_In (E, E_Entry, E_Function, E_Procedure) then Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Aspect); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index ee6bcddcaf0..a3d8f40a9ae 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -7345,10 +7345,14 @@ package body Sem_Ch8 is if Is_Concurrent_Type (T) then if No (Corresponding_Record_Type (Entity (Prefix (N)))) then - -- Previous error. Use current type, which at least - -- provides some operations. + -- Previous error. Create a class-wide type for the + -- synchronized type itself, with minimal semantic + -- attributes, to catch other errors in some ACATS tests. - C := Entity (Prefix (N)); + pragma Assert (Serious_Errors_Detected > 0); + Make_Class_Wide_Type (T); + C := Class_Wide_Type (T); + Set_First_Entity (C, First_Entity (T)); else C := Class_Wide_Type diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads index 99d2b1485d4..ae63e172cee 100644 --- a/gcc/ada/sem_ch8.ads +++ b/gcc/ada/sem_ch8.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -171,7 +171,7 @@ package Sem_Ch8 is procedure Set_Use (L : List_Id); -- Find use clauses that are declarative items in a package declaration - -- and set the potentially use-visible flags of imported entities before + -- and set the potentially use-visible flags of imported entities before -- analyzing the corresponding package body. procedure ws; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 7a996bf975f..77fc34b47c4 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -9416,7 +9416,8 @@ package body Sem_Prag is if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then Set_Casing - (Identifier_Casing (Current_Source_File)); + (Identifier_Casing + (Source_Index (Current_Sem_Unit))); Error_Msg_String (1 .. Rnm'Length) := Name_Buffer (1 .. Name_Len); Error_Msg_Strlen := Rnm'Length; |