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.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@247168 138bc75d-0d04-0410-961f-82ee72b054a4

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;