[multiple changes]

2014-07-29  Robert Dewar  <dewar@adacore.com>

	* gnat_ugn.texi: Add section on Wide_Wide_Character encodings.
	* erroutc.adb (Output_Error_Msgs): Take wide characters into
	account in computing position of error flags.
	* sinput.adb (Get_Column_Number): Take wide characters into
	account.

2014-07-29  Ed Schonberg  <schonberg@adacore.com>

	* par-ch3.adb (P_Access_Type_Definition): The subtype indication
	in an access type definition can carry a null_exclusion indicator.
	* sem_ch3.adb (Access_Type_Declaration): If the subtype indication
	carries a null_exclusion indicator, verify that the subtype
	indication denotes an access type, and create a null-excluding
	subtype for it.
	* sinfo.ads, sinfo.adb: New attribute Null_Excluding_Subtype,
	defined on N_Access_To_Object_Definition to indicate that the
	subtype indication carries a null_exclusion indicator.

2014-07-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch6.adb (Add_Extra_Actual): Do not construct
	the extra actual by name, generate a reference instead.

2014-07-29  Arnaud Charlet  <charlet@adacore.com>

	* sem_prag.adb (Analyze_Pragma): Do not crash analyzing
	Allow_Integer_Address if already set.
	* a-except-2005.adb (Rcheck_PE_Stream_Operation_Not_Allowed):
	Fix order, for consistency with Rmsg_xx declarations.

From-SVN: r213172

11 files changed, 251 insertions, 37 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 218c225..d85f487 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,35 @@
+2014-07-29  Robert Dewar  <dewar@adacore.com>
+
+	* gnat_ugn.texi: Add section on Wide_Wide_Character encodings.
+	* erroutc.adb (Output_Error_Msgs): Take wide characters into
+	account in computing position of error flags.
+	* sinput.adb (Get_Column_Number): Take wide characters into
+	account.
+
+2014-07-29  Ed Schonberg  <schonberg@adacore.com>
+
+	* par-ch3.adb (P_Access_Type_Definition): The subtype indication
+	in an access type definition can carry a null_exclusion indicator.
+	* sem_ch3.adb (Access_Type_Declaration): If the subtype indication
+	carries a null_exclusion indicator, verify that the subtype
+	indication denotes an access type, and create a null-excluding
+	subtype for it.
+	* sinfo.ads, sinfo.adb: New attribute Null_Excluding_Subtype,
+	defined on N_Access_To_Object_Definition to indicate that the
+	subtype indication carries a null_exclusion indicator.
+
+2014-07-29  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch6.adb (Add_Extra_Actual): Do not construct
+	the extra actual by name, generate a reference instead.
+
+2014-07-29  Arnaud Charlet  <charlet@adacore.com>
+
+	* sem_prag.adb (Analyze_Pragma): Do not crash analyzing
+	Allow_Integer_Address if already set.
+	* a-except-2005.adb (Rcheck_PE_Stream_Operation_Not_Allowed):
+	Fix order, for consistency with Rmsg_xx declarations.
+
 2014-07-29  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_ch4.adb (Complete_Object_Operation): If the type of the
diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb
index 52de66f..ab29b09 100644
--- a/gcc/ada/a-except-2005.adb
+++ b/gcc/ada/a-except-2005.adb
@@ -403,6 +403,9 @@ package body Ada.Exceptions is
    --  These routines raise a specific exception with a reason message
    --  attached. The parameters are the file name and line number in each
    --  case. The names are defined by Exp_Ch11.Get_RT_Exception_Name.
+   --  Note that these routines should be declared in the same order as the
+   --  corresponding Rmsg_xx constants below, this is needed by the
+   --  .NET runtime (see exceptmsg.awk script).
 
    procedure Rcheck_CE_Access_Check
      (File : System.Address; Line : Integer);
@@ -462,8 +465,6 @@ package body Ada.Exceptions is
      (File : System.Address; Line : Integer);
    procedure Rcheck_PE_Potentially_Blocking_Operation
      (File : System.Address; Line : Integer);
-   procedure Rcheck_PE_Stream_Operation_Not_Allowed
-     (File : System.Address; Line : Integer);
    procedure Rcheck_PE_Stubbed_Subprogram_Called
      (File : System.Address; Line : Integer);
    procedure Rcheck_PE_Unchecked_Union_Restriction
@@ -476,6 +477,8 @@ package body Ada.Exceptions is
      (File : System.Address; Line : Integer);
    procedure Rcheck_SE_Object_Too_Large
      (File : System.Address; Line : Integer);
+   procedure Rcheck_PE_Stream_Operation_Not_Allowed
+     (File : System.Address; Line : Integer);
 
    procedure Rcheck_CE_Access_Check_Ext
      (File : System.Address; Line, Column : Integer);
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index 66ab8f1..4e5070a 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -42,6 +42,7 @@ with Snames;   use Snames;
 with Stringt;  use Stringt;
 with Targparm; use Targparm;
 with Uintp;    use Uintp;
+with Widechar; use Widechar;
 
 package body Erroutc is
 
@@ -445,32 +446,75 @@ package body Erroutc is
            and then Errors.Table (T).Line = Errors.Table (E).Line
            and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
          loop
-            --  Loop to output blanks till current flag position
+            declare
+               Src : Source_Buffer_Ptr
+                       renames Source_Text (Errors.Table (T).Sfile);
 
-            while P < Errors.Table (T).Sptr loop
-               if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
-                  Write_Char (ASCII.HT);
-               else
-                  Write_Char (' ');
-               end if;
+            begin
+               --  Loop to output blanks till current flag position
 
-               P := P + 1;
-            end loop;
+               while P < Errors.Table (T).Sptr loop
 
-            --  Output flag (unless already output, this happens if more
-            --  than one error message occurs at the same flag position).
+                  --  Horizontal tab case, just echo the tab
 
-            if P = Errors.Table (T).Sptr then
-               if (Flag_Num = 1 and then not Mult_Flags)
-                 or else Flag_Num > 9
-               then
-                  Write_Char ('|');
-               else
-                  Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
-               end if;
+                  if Src (P) = ASCII.HT then
+                     Write_Char (ASCII.HT);
+                     P := P + 1;
 
-               P := P + 1;
-            end if;
+                  --  Deal with wide character case, but don't include brackets
+                  --  notation in this circuit, since we know that this will
+                  --  display unencoded (no one encodes brackets notation).
+
+                  elsif Src (P) /= '['
+                    and then Is_Start_Of_Wide_Char (Src, P)
+                  then
+                     Skip_Wide (Src, P);
+                     Write_Char (' ');
+
+                  --  Normal non-wide character case (or bracket)
+
+                  else
+                     P := P + 1;
+                     Write_Char (' ');
+                  end if;
+               end loop;
+
+               --  Output flag (unless already output, this happens if more
+               --  than one error message occurs at the same flag position).
+
+               if P = Errors.Table (T).Sptr then
+                  if (Flag_Num = 1 and then not Mult_Flags)
+                    or else Flag_Num > 9
+                  then
+                     Write_Char ('|');
+                  else
+                     Write_Char
+                       (Character'Val (Character'Pos ('0') + Flag_Num));
+                  end if;
+
+                  --  Skip past the corresponding source text character
+
+                  --  Horizontal tab case, we output a flag at the tab position
+                  --  so now we output a tab to match up with the text.
+
+                  if Src (P) = ASCII.HT then
+                     Write_Char (ASCII.HT);
+                     P := P + 1;
+
+                  --  Skip wide character other than left bracket
+
+                  elsif Src (P) /= '['
+                    and then Is_Start_Of_Wide_Char (Src, P)
+                  then
+                     Skip_Wide (Src, P);
+
+                  --  Skip normal non-wide character case (or bracket)
+
+                  else
+                     P := P + 1;
+                  end if;
+               end if;
+            end;
 
             Set_Next_Non_Deleted_Msg (T);
             Flag_Num := Flag_Num + 1;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 9344e40..703a427 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -2106,7 +2106,7 @@ package body Exp_Ch6 is
 
          Append_To (Extra_Actuals,
            Make_Parameter_Association (Loc,
-             Selector_Name             => Make_Identifier (Loc, Chars (EF)),
+             Selector_Name             => New_Occurrence_Of (EF, Loc),
              Explicit_Actual_Parameter => Expr));
 
          Analyze_And_Resolve (Expr, Etype (EF));
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 6b8079c..b4a7025 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -1378,7 +1378,8 @@ of the compiler (@pxref{Character Set Control}).
 @menu
 * Latin-1::
 * Other 8-Bit Codes::
-* Wide Character Encodings::
+* Wide_Character Encodings::
+* Wide_Wide_Character Encodings::
 @end menu
 
 @node Latin-1
@@ -1471,8 +1472,8 @@ equivalences that are recognized, see the file @file{csets.adb} in
 the GNAT compiler sources. You will need to obtain a full source release
 of GNAT to obtain this file.
 
-@node Wide Character Encodings
-@subsection Wide Character Encodings
+@node Wide_Character Encodings
+@subsection Wide_Character Encodings
 
 @noindent
 GNAT allows wide character codes to appear in character and string
@@ -1545,8 +1546,9 @@ where the @var{xxx} bits correspond to the left-padded bits of the
 are represented as ASCII bytes and all upper half characters and
 other wide characters are represented as sequences of upper-half
 (The full UTF-8 scheme allows for encoding 31-bit characters as
-6-byte sequences, but in this implementation, all UTF-8 sequences
-of four or more bytes length will be treated as illegal).
+6-byte sequences, and in the following section on wide wide
+characters, the use of these sequences is documented).
+
 @item Brackets Coding
 In this encoding, a wide character is represented by the following eight
 character sequence:
@@ -1564,8 +1566,8 @@ Brackets coding for upper half characters. For example, the code
 @code{16#A3#} can be represented as @code{[``A3'']}.
 
 This scheme is compatible with use of the full Wide_Character set,
-and is also the method used for wide character encoding in the standard
-ACVC (Ada Compiler Validation Capability) test suite distributions.
+and is also the method used for wide character encoding in some standard
+ACATS (Ada Conformity Assessment Test Suite) test suite distributions.
 
 @end table
 
@@ -1574,6 +1576,60 @@ Note: Some of these coding schemes do not permit the full use of the
 Ada character set. For example, neither Shift JIS, nor EUC allow the
 use of the upper half of the Latin-1 set.
 
+@node Wide_Wide_Character Encodings
+@subsection Wide_Wide_Character Encodings
+
+@noindent
+GNAT allows wide wide character codes to appear in character and string
+literals, and also optionally in identifiers, by means of the following
+possible encoding schemes:
+
+@table @asis
+
+@item UTF-8 Coding
+A wide character is represented using
+UCS Transformation Format 8 (UTF-8) as defined in Annex R of ISO
+10646-1/Am.2. Depending on the character value, the representation
+of character codes with values greater than 16#FFFF# is a
+is a four, five, or six byte sequence:
+
+@smallexample
+@iftex
+@leftskip=.7cm
+@end iftex
+16#01_0000#-16#10_FFFF#:     11110xxx 10xxxxxx 10xxxxxx
+                             10xxxxxx
+16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx
+                             10xxxxxx 10xxxxxx
+16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx
+                             10xxxxxx 10xxxxxx 10xxxxxx
+@end smallexample
+
+@noindent
+where the @var{xxx} bits correspond to the left-padded bits of the
+32-bit character value.
+
+@item Brackets Coding
+In this encoding, a wide wide character is represented by the following ten or
+twelve byte character sequence:
+
+@smallexample
+[ " a b c d e f " ]
+[ " a b c d e f g h " ]
+@end smallexample
+
+@noindent
+Where @code{a-h} are the six or eight hexadecimal
+characters (using uppercase letters) of the wide wide character code. For
+example, ["1F4567"] is used to represent the wide wide character with code
+@code{16#001F_4567#}.
+
+This scheme is compatible with use of the full Wide_Wide_Character set,
+and is also the method used for wide wide character encoding in some standard
+ACATS (Ada Conformity Assessment Test Suite) test suite distributions.
+
+@end table
+
 @node File Naming Rules
 @section File Naming Rules
 
@@ -7222,7 +7278,7 @@ UTF-8 encoding (brackets encoding also recognized)
 Brackets encoding only (default value)
 @end table
 For full details on these encoding
-methods see @ref{Wide Character Encodings}.
+methods see @ref{Wide_Character Encodings}.
 Note that brackets coding is always accepted, even if one of the other
 options is specified, so for example @option{-gnatW8} specifies that both
 brackets and UTF-8 encodings will be recognized. The units that are
diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb
index 3d6161b..1bad005 100644
--- a/gcc/ada/par-ch3.adb
+++ b/gcc/ada/par-ch3.adb
@@ -3930,6 +3930,7 @@ package body Ch3 is
       Access_Loc       : constant Source_Ptr := Token_Ptr;
       Prot_Flag        : Boolean;
       Not_Null_Present : Boolean := False;
+      Not_Null_Subtype : Boolean := False;
       Type_Def_Node    : Node_Id;
       Result_Not_Null  : Boolean;
       Result_Node      : Node_Id;
@@ -3964,8 +3965,16 @@ package body Ch3 is
 
    begin
       if not Header_Already_Parsed then
-         Not_Null_Present := P_Null_Exclusion;         --  Ada 2005 (AI-231)
+
+         --  not null access .. is a common form of access definition
+         --  access non null ..  is certainly rare, but syntactically legal.
+         --  not null access not null .. is rarer yet, and also legal.
+         --  The last two cases are only meaningful if the following subtype
+         --  indication denotes an access type (semantic check).
+
+         Not_Null_Present := P_Null_Exclusion;     --  Ada 2005 (AI-231)
          Scan; -- past ACCESS
+         Not_Null_Subtype := P_Null_Exclusion;     --  Might also appear.
       end if;
 
       if Token_Name = Name_Protected then
@@ -4040,6 +4049,7 @@ package body Ch3 is
          Type_Def_Node :=
            New_Node (N_Access_To_Object_Definition, Access_Loc);
          Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
+         Set_Null_Excluding_Subtype (Type_Def_Node, Not_Null_Subtype);
 
          if Token = Tok_All or else Token = Tok_Constant then
             if Ada_Version = Ada_83 then
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index a2aeaf9..e93230a 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -1337,6 +1337,34 @@ package body Sem_Ch3 is
               Process_Subtype (S, P, T, 'P'));
          end if;
 
+         --  If the access definition is of the form : access not null ..
+         --  the subtype indication must be of an access type. Create
+         --  a null-excluding subtype of it.
+
+         if Null_Excluding_Subtype (Def) then
+            if not Is_Access_Type (Entity (S)) then
+               Error_Msg_N ("null exclusion must apply to access type", Def);
+
+            else
+               declare
+                  Loc  : constant Source_Ptr := Sloc (S);
+                  Decl : Node_Id;
+                  Nam  : constant Entity_Id := Make_Temporary (Loc, 'S');
+
+               begin
+                  Decl :=
+                    Make_Subtype_Declaration (Loc,
+                      Defining_Identifier => Nam,
+                      Subtype_Indication =>
+                        New_Occurrence_Of (Entity (S), Loc));
+                  Set_Null_Exclusion_Present (Decl);
+                  Insert_Before (Parent (Def), Decl);
+                  Analyze (Decl);
+                  Set_Entity (S, Nam);
+               end;
+            end if;
+         end if;
+
       else
          Set_Directly_Designated_Type (T,
            Process_Subtype (S, P, T, 'P'));
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 66b5640..208a954 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -11019,8 +11019,13 @@ package body Sem_Prag is
             --  integer address values. If Address is not private (e.g. on
             --  VMS, where it is an integer type), then this pragma has no
             --  purpose, so it is simply ignored.
+            --  If Allow_Integer_Address is already set do nothing, otherwise
+            --  calling RTE on RE_Address would cause a crash when loading
+            --  system.ads.
 
-            if Is_Private_Type (RTE (RE_Address)) then
+            if not Opt.Allow_Integer_Address
+              and then Is_Private_Type (RTE (RE_Address))
+            then
                Opt.Allow_Integer_Address := True;
             end if;
 
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index 232e0bc..3ea385c 100644
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -2382,6 +2382,14 @@ package body Sinfo is
       return Flag13 (N);
    end Null_Present;
 
+   function Null_Excluding_Subtype
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Access_To_Object_Definition);
+      return Flag16 (N);
+   end Null_Excluding_Subtype;
+
    function Null_Exclusion_Present
       (N : Node_Id) return Boolean is
    begin
@@ -5565,6 +5573,14 @@ package body Sinfo is
       Set_Flag13 (N, Val);
    end Set_Null_Present;
 
+   procedure Set_Null_Excluding_Subtype
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Access_To_Object_Definition);
+      Set_Flag16 (N, Val);
+   end Set_Null_Excluding_Subtype;
+
    procedure Set_Null_Exclusion_Present
       (N : Node_Id; Val : Boolean := True) is
    begin
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 1fb1acf..1b2ae3e 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -3369,6 +3369,7 @@ package Sinfo is
       --  Sloc points to ACCESS
       --  All_Present (Flag15)
       --  Null_Exclusion_Present (Flag11)
+      --  Null_Excluding_Subtype (Flag16)
       --  Subtype_Indication (Node5)
       --  Constant_Present (Flag17)
 
@@ -9363,6 +9364,9 @@ package Sinfo is
    function Null_Present
      (N : Node_Id) return Boolean;    -- Flag13
 
+   function Null_Excluding_Subtype
+     (N : Node_Id) return Boolean;    -- Flag16
+
    function Null_Exclusion_Present
      (N : Node_Id) return Boolean;    -- Flag11
 
@@ -10377,6 +10381,9 @@ package Sinfo is
    procedure Set_Null_Present
      (N : Node_Id; Val : Boolean := True);    -- Flag13
 
+   procedure Set_Null_Excluding_Subtype
+     (N : Node_Id; Val : Boolean := True);    -- Flag16
+
    procedure Set_Null_Exclusion_Present
      (N : Node_Id; Val : Boolean := True);    -- Flag11
 
@@ -12652,6 +12659,7 @@ package Sinfo is
    pragma Inline (No_Truncation);
    pragma Inline (Non_Aliased_Prefix);
    pragma Inline (Null_Present);
+   pragma Inline (Null_Excluding_Subtype);
    pragma Inline (Null_Exclusion_Present);
    pragma Inline (Null_Exclusion_In_Return_Present);
    pragma Inline (Null_Record_Present);
@@ -12985,6 +12993,7 @@ package Sinfo is
    pragma Inline (Set_No_Minimize_Eliminate);
    pragma Inline (Set_No_Truncation);
    pragma Inline (Set_Non_Aliased_Prefix);
+   pragma Inline (Set_Null_Excluding_Subtype);
    pragma Inline (Set_Null_Exclusion_Present);
    pragma Inline (Set_Null_Exclusion_In_Return_Present);
    pragma Inline (Set_Null_Present);
diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb
index dac8dd8..70d4481 100644
--- a/gcc/ada/sinput.adb
+++ b/gcc/ada/sinput.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2014, 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- --
@@ -331,11 +331,22 @@ package body Sinput is
          while S < P loop
             if Src (S) = HT then
                C := (C - 1) / 8 * 8 + (8 + 1);
+               S := S + 1;
+
+            --  Deal with wide character case, but don't include brackets
+            --  notation in this circuit, since we know that this will
+            --  display unencoded (no one encodes brackets notation).
+
+            elsif Src (S) /= '[' and then Is_Start_Of_Wide_Char (Src, S) then
+               C := C + 1;
+               Skip_Wide (Src, S);
+
+            --  Normal (non-wide) character case or brackets sequence
+
             else
                C := C + 1;
+               S := S + 1;
             end if;
-
-            S := S + 1;
          end loop;
 
          return C;