[multiple changes]

2017-04-25  Arnaud Charlet  <charlet@adacore.com>

	* exp_ch4.adb (Expand_N_Case_Expression): Emit error message when
	generating C code on complex case expressions.

2017-04-25  Arnaud Charlet  <charlet@adacore.com>

	* sem_prag.adb (Analyze_Pragma): Generate a warning instead
	of silently ignoring pragma Ada_xxx in Latest_Ada_Only mode.
	* directio.ads, ioexcept.ads, sequenio.ads, text_io.ads: Use
	Ada_2012 instead of Ada_2005 to be compatible with the above
	change.
	* bindgen.adb: Silence new warning on pragma Ada_95.

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* checks.adb (Generate_Range_Check): Revert part of previous change.

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Try_Container_Indexing): Handle properly a
	container indexing operation that appears as a an actual in a
	parameter association in a procedure call.

2017-04-25  Olivier Ramonat  <ramonat@adacore.com>

	* prj-proc.adb, sem_util.adb, s-stposu.adb, sem_attr.adb, prj-conf.ads:
	Fix spelling mistakes.

2017-04-25  Bob Duff  <duff@adacore.com>

	* types.ads, osint.adb, sinput-c.adb, sinput-d.adb, sinput-l.adb,
	* sinput-p.adb: Use regular fat pointers, with bounds checking,
	for source buffers.  Fix misc obscure bugs.
	* sinput.ads, sinput.adb: Use regular fat pointers, with bounds
	checking, for source buffers.  Modify representation clause for
	Source_File_Record as appropriate.  Move Source_File_Index_Table
	from spec to body, because it is not used outside the body.
	Move Set_Source_File_Index_Table into the private part, because
	it is used only in the body and in children.  Use trickery to
	modify the dope in the generic instantiation case.  It's ugly,
	but not as ugly as the previous method.  Fix documentation.
	Remove obsolete code.
	* fname-sf.adb, targparm.adb: Fix misc out-of-bounds
	indexing in source buffers.
	* fmap.adb: Avoid conversions from one string type to another.
	Remove a use of global name buffer.
	* osint.ads, sfn_scan.ads, sfn_scan.adb, sinput-c.ads: Comment
	fixes.

From-SVN: r247252

1 files changed, 163 insertions, 134 deletions

diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb
index b3cfa49..3cb9a0e 100644
--- a/gcc/ada/sinput.adb
+++ b/gcc/ada/sinput.adb
@@ -42,7 +42,7 @@ with Widechar; use Widechar;
 
 with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
 
-with System;         use System;
+with System.Storage_Elements;
 with System.Memory;
 with System.WCh_Con; use System.WCh_Con;
 
@@ -51,11 +51,7 @@ with Unchecked_Deallocation;
 
 package body Sinput is
 
-   use ASCII;
-   --  Make control characters visible
-
-   First_Time_Around : Boolean := True;
-   --  This needs a comment ???
+   use ASCII, System;
 
    --  Routines to support conversion between types Lines_Table_Ptr,
    --  Logical_Lines_Table_Ptr and System.Address.
@@ -78,6 +74,24 @@ package body Sinput is
 
    pragma Warnings (On);
 
+   -----------------------------
+   -- Source_File_Index_Table --
+   -----------------------------
+
+   --  The Get_Source_File_Index function is called very frequently. Earlier
+   --  versions cached a single entry, but then reverted to a serial search,
+   --  and this proved to be a significant source of inefficiency. We then
+   --  switched to using a table with a start point followed by a serial
+   --  search. Now we make sure source buffers are on a reasonable boundary
+   --  (see Types.Source_Align), and we can just use a direct look up in the
+   --  following table.
+
+   --  Note that this array is pretty large, but in most operating systems
+   --  it will not be allocated in physical memory unless it is actually used.
+
+   Source_File_Index_Table :
+     array (Int range 0 .. 1 + (Int'Last / Source_Align)) of Source_File_Index;
+
    ---------------------------
    -- Add_Line_Tables_Entry --
    ---------------------------
@@ -328,6 +342,26 @@ package body Sinput is
       return SIE.Inlined_Body;
    end Comes_From_Inlined_Body;
 
+   ------------------------
+   -- Free_Source_Buffer --
+   ------------------------
+
+   procedure Free_Source_Buffer (Src : in out Source_Buffer_Ptr) is
+      --  Unchecked_Deallocation doesn't work for access-to-constant; we need
+      --  to first Unchecked_Convert to access-to-variable.
+
+      function To_Source_Buffer_Ptr_Var is new
+        Unchecked_Conversion (Source_Buffer_Ptr, Source_Buffer_Ptr_Var);
+
+      Temp : Source_Buffer_Ptr_Var := To_Source_Buffer_Ptr_Var (Src);
+
+      procedure Free_Ptr is new
+        Unchecked_Deallocation (Source_Buffer, Source_Buffer_Ptr_Var);
+   begin
+      Free_Ptr (Temp);
+      Src := null;
+   end Free_Source_Buffer;
+
    -----------------------
    -- Get_Column_Number --
    -----------------------
@@ -472,8 +506,51 @@ package body Sinput is
    ---------------------------
 
    function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is
+      Result : Source_File_Index;
+
+      procedure Assertions;
+      --  Assert various properties of the result
+
+      procedure Assertions is
+         --  ???The old version using zero-origin array indexing without array
+         --  bounds checks returned 1 (i.e. system.ads) for these special
+         --  locations, presumably by accident. We are mimicing that here.
+         Special : constant Boolean :=
+           S = No_Location or else S = Standard_Location
+           or else S = Standard_ASCII_Location or else S = System_Location;
+         pragma Assert ((S > No_Location) xor Special);
+
+         pragma Assert (Result in Source_File.First .. Source_File.Last);
+
+         SFR : Source_File_Record renames Source_File.Table (Result);
+      begin
+         --  SFR.Source_Text = null if and only if this is the SFR for a debug
+         --  output file (*.dg), and that file is under construction.
+
+         if not Null_Source_Buffer_Ptr (SFR.Source_Text) then
+            pragma Assert (SFR.Source_Text'First = SFR.Source_First);
+            pragma Assert (SFR.Source_Text'Last = SFR.Source_Last);
+            null;
+         end if;
+
+         if not Special then
+            pragma Assert (S in SFR.Source_First .. SFR.Source_Last);
+            null;
+         end if;
+      end Assertions;
+
+   --  Start of processing for Get_Source_File_Index
+
    begin
-      return Source_File_Index_Table (Int (S) / Source_Align);
+      if S > No_Location then
+         Result := Source_File_Index_Table (Int (S) / Source_Align);
+      else
+         Result := 1;
+      end if;
+
+      pragma Debug (Assertions);
+
+      return Result;
    end Get_Source_File_Index;
 
    ----------------
@@ -482,11 +559,8 @@ package body Sinput is
 
    procedure Initialize is
    begin
-      Source_gnat_adc    := No_Source_File;
-      First_Time_Around  := True;
-
+      Source_gnat_adc := No_Source_File;
       Source_File.Init;
-
       Instances.Init;
       Instances.Append (No_Location);
       pragma Assert (Instances.Last = No_Instance_Id);
@@ -791,6 +865,33 @@ package body Sinput is
       end;
    end Skip_Line_Terminators;
 
+   --------------
+   -- Set_Dope --
+   --------------
+
+   procedure Set_Dope
+     (Src : System.Address; New_Dope : Dope_Ptr)
+   is
+      --  A fat pointer is a pair consisting of data pointer and dope pointer,
+      --  in that order. So we want to overwrite the second word.
+      Dope : Address;
+      pragma Import (Ada, Dope);
+      use System.Storage_Elements;
+      for Dope'Address use Src + System.Address'Size / 8;
+   begin
+      Dope := New_Dope.all'Address;
+   end Set_Dope;
+
+   procedure Free_Dope (Src : System.Address) is
+      Dope : Dope_Ptr;
+      pragma Import (Ada, Dope);
+      use System.Storage_Elements;
+      for Dope'Address use Src + System.Address'Size / 8;
+      procedure Free is new Unchecked_Deallocation (Dope_Rec, Dope_Ptr);
+   begin
+      Free (Dope);
+   end Free_Dope;
+
    ----------------
    -- Sloc_Range --
    ----------------
@@ -871,60 +972,29 @@ package body Sinput is
    begin
       --  First we must free any old source buffer pointers
 
-      if not First_Time_Around then
-         for J in Source_File.First .. Source_File.Last loop
-            declare
-               S : Source_File_Record renames Source_File.Table (J);
-
-               type Source_Buffer_Ptr_Var is access all Big_Source_Buffer;
-
-               procedure Free_Ptr is new Unchecked_Deallocation
-                 (Big_Source_Buffer, Source_Buffer_Ptr_Var);
-               --  This works only because we're calling malloc, which keeps
-               --  track of the size on its own, ignoring the size of
-               --  Big_Source_Buffer, which is the wrong size.
-
-               pragma Warnings (Off);
-               --  This unchecked conversion is aliasing safe, since it is not
-               --  used to create improperly aliased pointer values.
-
-               function To_Source_Buffer_Ptr_Var is new
-                 Unchecked_Conversion (Address, Source_Buffer_Ptr_Var);
-
-               pragma Warnings (On);
-
-               Tmp1 : Source_Buffer_Ptr_Var;
+      for J in Source_File.First .. Source_File.Last loop
+         declare
+            S : Source_File_Record renames Source_File.Table (J);
+         begin
+            if S.Instance = No_Instance_Id then
+               Free_Source_Buffer (S.Source_Text);
 
-            begin
-               if S.Instance /= No_Instance_Id then
-                  null;
+               if S.Lines_Table /= null then
+                  Memory.Free (To_Address (S.Lines_Table));
+                  S.Lines_Table := null;
+               end if;
 
-               else
-                  --  Free the buffer, we use Free here, because we used malloc
-                  --  or realloc directly to allocate the tables. That is
-                  --  because we were playing the big array trick.
-
-                  --  We have to recreate a proper pointer to the actual array
-                  --  from the zero origin pointer stored in the source table.
-
-                  Tmp1 :=
-                    To_Source_Buffer_Ptr_Var
-                      (S.Source_Text (S.Source_First)'Address);
-                  Free_Ptr (Tmp1);
-
-                  if S.Lines_Table /= null then
-                     Memory.Free (To_Address (S.Lines_Table));
-                     S.Lines_Table := null;
-                  end if;
-
-                  if S.Logical_Lines_Table /= null then
-                     Memory.Free (To_Address (S.Logical_Lines_Table));
-                     S.Logical_Lines_Table := null;
-                  end if;
+               if S.Logical_Lines_Table /= null then
+                  Memory.Free (To_Address (S.Logical_Lines_Table));
+                  S.Logical_Lines_Table := null;
                end if;
-            end;
-         end loop;
-      end if;
+
+            else
+               Free_Dope (S.Source_Text'Address);
+               S.Source_Text := null;
+            end if;
+         end;
+      end loop;
 
       --  Read in source file table and instance table
 
@@ -938,56 +1008,10 @@ package body Sinput is
       for J in Source_File.First .. Source_File.Last loop
          declare
             S : Source_File_Record renames Source_File.Table (J);
-
          begin
-            --  For the instantiation case, we do not read in any data. Instead
-            --  we share the data for the generic template entry. Since the
-            --  template always occurs first, we can safely refer to its data.
-
-            if S.Instance /= No_Instance_Id then
-               declare
-                  ST : Source_File_Record renames
-                         Source_File.Table (S.Template);
-
-               begin
-                  --  The lines tables are copied from the template entry
-
-                  S.Lines_Table :=
-                    Source_File.Table (S.Template).Lines_Table;
-                  S.Logical_Lines_Table :=
-                    Source_File.Table (S.Template).Logical_Lines_Table;
-
-                  --  In the case of the source table pointer, we share the
-                  --  same data as the generic template, but the virtual origin
-                  --  is adjusted. For example, if the first subscript of the
-                  --  template is 100, and that of the instantiation is 200,
-                  --  then the instantiation pointer is obtained by subtracting
-                  --  100 from the template pointer.
-
-                  declare
-                     pragma Suppress (All_Checks);
-
-                     pragma Warnings (Off);
-                     --  This unchecked conversion is aliasing safe since it
-                     --  not used to create improperly aliased pointer values.
-
-                     function To_Source_Buffer_Ptr is new
-                       Unchecked_Conversion (Address, Source_Buffer_Ptr);
-
-                     pragma Warnings (On);
-
-                  begin
-                     S.Source_Text :=
-                       To_Source_Buffer_Ptr
-                          (ST.Source_Text
-                            (ST.Source_First - S.Source_First)'Address);
-                  end;
-               end;
-
             --  Normal case (non-instantiation)
 
-            else
-               First_Time_Around := False;
+            if S.Instance = No_Instance_Id then
                S.Lines_Table := null;
                S.Logical_Lines_Table := null;
                Alloc_Line_Tables (S, Int (S.Last_Source_Line));
@@ -1002,33 +1026,42 @@ package body Sinput is
                   end loop;
                end if;
 
-               --  Allocate source buffer and read in the data and then set the
-               --  virtual origin to point to the logical zero'th element. This
-               --  address must be computed with subscript checks turned off.
+               --  Allocate source buffer and read in the data
 
                declare
-                  subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
-                  type Text_Buffer_Ptr is access B;
-                  T : Text_Buffer_Ptr;
-
-                  pragma Suppress (All_Checks);
-
-                  pragma Warnings (Off);
-                  --  This unchecked conversion is aliasing safe, since it is
-                  --  never used to create improperly aliased pointer values.
+                  T : constant Source_Buffer_Ptr_Var :=
+                    new Source_Buffer (S.Source_First .. S.Source_Last);
+               begin
+                  Tree_Read_Data (T (S.Source_First)'Address,
+                     Int (S.Source_Last) - Int (S.Source_First) + 1);
+                  S.Source_Text := T.all'Access;
+               end;
 
-                  function To_Source_Buffer_Ptr is new
-                    Unchecked_Conversion (Address, Source_Buffer_Ptr);
+            --  For the instantiation case, we do not read in any data. Instead
+            --  we share the data for the generic template entry. Since the
+            --  template always occurs first, we can safely refer to its data.
 
-                  pragma Warnings (On);
+            else
+               declare
+                  ST : Source_File_Record renames
+                         Source_File.Table (S.Template);
 
                begin
-                  T := new B;
+                  --  The lines tables are copied from the template entry
 
-                  Tree_Read_Data (T (S.Source_First)'Address,
-                     Int (S.Source_Last) - Int (S.Source_First) + 1);
+                  S.Lines_Table := ST.Lines_Table;
+                  S.Logical_Lines_Table := ST.Logical_Lines_Table;
+
+                  --  The Source_Text of the instance is the same data as that
+                  --  of the template, but with different bounds.
 
-                  S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
+                  declare
+                     Dope : constant Dope_Ptr :=
+                       new Dope_Rec'(S.Source_First, S.Source_Last);
+                  begin
+                     S.Source_Text := ST.Source_Text;
+                     Set_Dope (S.Source_Text'Address, Dope);
+                  end;
                end;
             end if;
          end;
@@ -1058,13 +1091,9 @@ package body Sinput is
             --  For instantiations, there is nothing to do, since the data is
             --  shared with the generic template. When the tree is read, the
             --  pointers must be set, but no extra data needs to be written.
+            --  For the normal case, write out the data of the tables.
 
-            if S.Instance /= No_Instance_Id then
-               null;
-
-            --  For the normal case, write out the data of the tables
-
-            else
+            if S.Instance = No_Instance_Id then
                --  Lines table
 
                for J in 1 .. S.Last_Source_Line loop