* [Ada] Remove zero-origin array indexing for Source_Buffers
@ 2017-04-25 16:09 Arnaud Charlet
0 siblings, 0 replies; only message in thread
From: Arnaud Charlet @ 2017-04-25 16:09 UTC (permalink / raw)
To: gcc-patches; +Cc: Bob Duff
[-- Attachment #1: Type: text/plain, Size: 1854 bytes --]
This patch removes the zero-origin array indexing that was used for
Source_Buffers with thin pointers. It is impossible to implement
zero-origin indexing correctly in Ada without fat pointers.
For one thing, 'First and 'Last can't work. For another thing,
array bounds checking can't work. And finally, "=" can't work,
because the virtual A(0) and B(0) could happen to be at the
same address -- to implement "=" properly, the 'First must
be added to both pointers.
This change makes the compiler slightly slower, but it has the advantage
that "=" (which is used all over) now works reliably. It also has the
advantage of bounds checking (except when checks are suppressed).
We also make the source buffers read-only, to avoid accidental
overwriting. No change in behavior; no test available.
Tested on x86_64-pc-linux-gnu, committed on trunk
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.
[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 76232 bytes --]
Index: fmap.adb
===================================================================
--- fmap.adb (revision 247234)
+++ fmap.adb (working copy)
@@ -45,9 +45,6 @@
-- procedure Initialize, so that no attempt is made to open the mapping
-- file in procedure Update_Mapping_File.
- function To_Big_String_Ptr is new Unchecked_Conversion
- (Source_Buffer_Ptr, Big_String_Ptr);
-
Max_Buffer : constant := 1_500;
Buffer : String (1 .. Max_Buffer);
-- Used to buffer output when writing to a new mapping file
@@ -180,11 +177,9 @@
procedure Initialize (File_Name : String) is
Src : Source_Buffer_Ptr;
Hi : Source_Ptr;
- BS : Big_String_Ptr;
- SP : String_Ptr;
- First : Positive := 1;
- Last : Natural := 0;
+ First : Source_Ptr := 1;
+ Last : Source_Ptr := 0;
Uname : Unit_Name_Type;
Fname : File_Name_Type;
@@ -204,7 +199,7 @@
-- the name buffer contains "/".
procedure Get_Line;
- -- Get a line from the mapping file, where a line is SP (First .. Last)
+ -- Get a line from the mapping file, where a line is Src (First .. Last)
procedure Report_Truncated;
-- Report a warning when the mapping file is truncated
@@ -263,23 +258,23 @@
-- If not at the end of file, skip the end of line
- while First < SP'Last
- and then (SP (First) = CR
- or else SP (First) = LF
- or else SP (First) = EOF)
+ while First < Src'Last
+ and then (Src (First) = CR
+ or else Src (First) = LF
+ or else Src (First) = EOF)
loop
First := First + 1;
end loop;
-- If not at the end of file, find the end of this new line
- if First < SP'Last and then SP (First) /= EOF then
+ if First < Src'Last and then Src (First) /= EOF then
Last := First;
- while Last < SP'Last
- and then SP (Last + 1) /= CR
- and then SP (Last + 1) /= LF
- and then SP (Last + 1) /= EOF
+ while Last < Src'Last
+ and then Src (Last + 1) /= CR
+ and then Src (Last + 1) /= LF
+ and then Src (Last + 1) /= EOF
loop
Last := Last + 1;
end loop;
@@ -302,9 +297,7 @@
begin
Empty_Tables;
- Name_Len := File_Name'Length;
- Name_Buffer (1 .. Name_Len) := File_Name;
- Read_Source_File (Name_Enter, 0, Hi, Src, Config);
+ Read_Source_File (Name_Enter (File_Name), 1, Hi, Src, Config);
if Null_Source_Buffer_Ptr (Src) then
Write_Str ("warning: could not read mapping file """);
@@ -313,9 +306,6 @@
No_Mapping_File := True;
else
- BS := To_Big_String_Ptr (Src);
- SP := BS (1 .. Natural (Hi))'Unrestricted_Access;
-
loop
-- Get the unit name
@@ -325,19 +315,19 @@
exit when First > Last;
- if (Last < First + 2) or else (SP (Last - 1) /= '%')
- or else (SP (Last) /= 's' and then SP (Last) /= 'b')
+ if (Last < First + 2) or else (Src (Last - 1) /= '%')
+ or else (Src (Last) /= 's' and then Src (Last) /= 'b')
then
Write_Line
("warning: mapping file """ & File_Name &
""" is incorrectly formatted");
- Write_Line ("Line = """ & SP (First .. Last) & '"');
+ Write_Line ("Line = """ & String (Src (First .. Last)) & '"');
Empty_Tables;
return;
end if;
- Name_Len := Last - First + 1;
- Name_Buffer (1 .. Name_Len) := SP (First .. Last);
+ Name_Len := Integer (Last - First + 1);
+ Name_Buffer (1 .. Name_Len) := String (Src (First .. Last));
Uname := Find_Unit_Name;
-- Get the file name
@@ -352,8 +342,8 @@
return;
end if;
- Name_Len := Last - First + 1;
- Name_Buffer (1 .. Name_Len) := SP (First .. Last);
+ Name_Len := Integer (Last - First + 1);
+ Name_Buffer (1 .. Name_Len) := String (Src (First .. Last));
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Fname := Find_File_Name;
@@ -369,8 +359,8 @@
return;
end if;
- Name_Len := Last - First + 1;
- Name_Buffer (1 .. Name_Len) := SP (First .. Last);
+ Name_Len := Integer (Last - First + 1);
+ Name_Buffer (1 .. Name_Len) := String (Src (First .. Last));
Pname := Find_File_Name;
-- Add the mappings for this unit name
Index: fname-sf.adb
===================================================================
--- fname-sf.adb (revision 247234)
+++ fname-sf.adb (working copy)
@@ -34,9 +34,6 @@
package body Fname.SF is
- function To_Big_String_Ptr is new Unchecked_Conversion
- (Source_Buffer_Ptr, Big_String_Ptr);
-
----------------------
-- Local Procedures --
----------------------
@@ -66,19 +63,19 @@
procedure Read_Source_File_Name_Pragmas is
Src : Source_Buffer_Ptr;
Hi : Source_Ptr;
- BS : Big_String_Ptr;
- SP : String_Ptr;
begin
- Name_Buffer (1 .. 8) := "gnat.adc";
- Name_Len := 8;
- Read_Source_File (Name_Enter, 0, Hi, Src);
+ Read_Source_File (Name_Enter ("gnat.adc"), 1, Hi, Src);
if not Null_Source_Buffer_Ptr (Src) then
- BS := To_Big_String_Ptr (Src);
- SP := BS (1 .. Natural (Hi))'Unrestricted_Access;
+ -- We need to strip off the trailing EOF that was added by
+ -- Read_Source_File, because there might be another EOF in
+ -- the file, and two in a row causes Scan_SFN_Pragmas to give
+ -- errors.
+
+ pragma Assert (Src (Hi) = EOF);
Scan_SFN_Pragmas
- (SP.all,
+ (String (Src (1 .. Hi - 1)),
Set_File_Name'Access,
Set_File_Name_Pattern'Access);
end if;
Index: namet.adb
===================================================================
--- namet.adb (revision 247227)
+++ namet.adb (working copy)
@@ -809,7 +809,7 @@
end Get_Name_String;
function Get_Name_String (Id : Name_Id) return String is
- Buf : Bounded_String;
+ Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
begin
Append (Buf, Id);
return +Buf;
@@ -1020,7 +1020,7 @@
end Is_Internal_Name;
function Is_Internal_Name (Id : Name_Id) return Boolean is
- Buf : Bounded_String;
+ Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
begin
if Id in Error_Name_Or_No_Name then
return False;
@@ -1132,6 +1132,13 @@
return Name_Entries.Last;
end Name_Enter;
+ function Name_Enter (S : String) return Name_Id is
+ Buf : Bounded_String (Max_Length => S'Length);
+ begin
+ Append (Buf, S);
+ return Name_Enter (Buf);
+ end Name_Enter;
+
--------------------------
-- Name_Entries_Address --
--------------------------
@@ -1240,7 +1247,7 @@
end Name_Find;
function Name_Find (S : String) return Name_Id is
- Buf : Bounded_String;
+ Buf : Bounded_String (Max_Length => S'Length);
begin
Append (Buf, S);
return Name_Find (Buf);
@@ -1743,7 +1750,7 @@
else
declare
- Buf : Bounded_String;
+ Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
begin
Append (Buf, Id);
Write_Str (Buf.Chars (1 .. Buf.Length));
@@ -1758,7 +1765,7 @@
----------------
procedure Write_Name (Id : Name_Id) is
- Buf : Bounded_String;
+ Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
begin
if Id >= First_Name_Id then
Append (Buf, Id);
Index: namet.ads
===================================================================
--- namet.ads (revision 247177)
+++ namet.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
@@ -348,6 +348,7 @@
function Name_Enter
(Buf : Bounded_String := Global_Name_Buffer) return Name_Id;
+ function Name_Enter (S : String) return Name_Id;
-- Name_Enter is similar to Name_Find. The difference is that it does not
-- search the table for an existing match, and also subsequent Name_Find
-- calls using the same name will not locate the entry created by this
Index: osint.adb
===================================================================
--- osint.adb (revision 247242)
+++ osint.adb (working copy)
@@ -2651,49 +2651,23 @@
-- Do the actual read operation
declare
- subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
- -- Physical buffer allocated
-
- type Actual_Source_Ptr is access Actual_Source_Buffer;
- -- This is the pointer type for the physical buffer allocated
-
- Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
- -- And this is the actual physical buffer
-
- begin
+ Var_Ptr : constant Source_Buffer_Ptr_Var :=
+ new Source_Buffer (Lo .. Hi);
-- Allocate source buffer, allowing extra character at end for EOF
-
+ begin
-- Some systems have file types that require one read per line,
-- so read until we get the Len bytes or until there are no more
-- characters.
Hi := Lo;
loop
- Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
+ Actual_Len := Read (Source_File_FD, Var_Ptr (Hi)'Address, Len);
Hi := Hi + Source_Ptr (Actual_Len);
exit when Actual_Len = Len or else Actual_Len <= 0;
end loop;
- Actual_Ptr (Hi) := EOF;
-
- -- Now we need to work out the proper virtual origin pointer to
- -- return. This is exactly Actual_Ptr (0)'Address, but we have to
- -- be careful to suppress checks to compute this address.
-
- declare
- pragma Suppress (All_Checks);
-
- pragma Warnings (Off);
- -- This use of unchecked conversion is aliasing safe
-
- function To_Source_Buffer_Ptr is new
- Unchecked_Conversion (Address, Source_Buffer_Ptr);
-
- pragma Warnings (On);
-
- begin
- Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
- end;
+ Var_Ptr (Hi) := EOF;
+ Src := Var_Ptr.all'Access;
end;
-- Read is complete, get time stamp and close file and we are done
@@ -2703,6 +2677,10 @@
-- The status should never be False. But, if it is, what can we do?
-- So, we don't test it.
+ -- ???We don't really need to return Hi anymore; We could get rid of
+ -- it. We could also make this into a function.
+
+ pragma Assert (Hi = Src'Last);
end Read_Source_File;
-------------------
Index: osint.ads
===================================================================
--- osint.ads (revision 247242)
+++ osint.ads (working copy)
@@ -417,11 +417,8 @@
-- positions other than the last source character are treated as blanks).
--
-- The logical lower bound of the source buffer is the input value of Lo,
- -- and on exit Hi is set to the logical upper bound of the source buffer.
- -- Note that the returned value in Src points to an array with a physical
- -- lower bound of zero. This virtual origin addressing approach means that
- -- a constrained array pointer can be used with a low bound of zero which
- -- results in more efficient code.
+ -- and on exit Hi is set to the logical upper bound of the source buffer,
+ -- which is redundant with Src'Last.
--
-- If the given file cannot be opened, then the action depends on whether
-- this file is the current main unit (i.e. its name matches the name
Index: sfn_scan.adb
===================================================================
--- sfn_scan.adb (revision 247177)
+++ sfn_scan.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2017, 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- --
@@ -102,7 +102,7 @@
-- immediately following is non-alphabetic, non-numeric. If so,
-- P is stepped past the token, and True is returned. If not,
-- P is unchanged (except for possibly skipping past whitespace),
- -- and False is returned. S may contain only lower-case letters
+ -- and False is returned. T may contain only lower-case letters
-- ('a' .. 'z').
procedure Error (Err : String);
Index: sfn_scan.ads
===================================================================
--- sfn_scan.ads (revision 247177)
+++ sfn_scan.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2017, 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- --
@@ -78,7 +78,7 @@
SFN_Ptr : Set_File_Name_Ptr;
SFNP_Ptr : Set_File_Name_Pattern_Ptr);
-- This is the procedure called to scan a gnat.adc file. The Source
- -- parameter points to the full text of the file, with normal line end
+ -- parameter contains the full text of the file, with normal line end
-- characters, in the format normally read by the compiler. The two
-- parameters SFN_Ptr and SFNP_Ptr point to procedures that will be
-- called to register Source_File_Name pragmas as they are found.
@@ -91,6 +91,6 @@
-- that includes only pragmas and comments. It does not do a full
-- syntax correctness scan by any means, but if it does find anything
-- that it can tell is wrong it will immediately raise the exception
- -- to indicate the approximate location of the error
+ -- to indicate the approximate location of the error.
end SFN_Scan;
Index: sinput.adb
===================================================================
--- sinput.adb (revision 247234)
+++ sinput.adb (working copy)
@@ -42,7 +42,7 @@
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,12 +51,8 @@
package body Sinput is
- use ASCII;
- -- Make control characters visible
+ use ASCII, System;
- First_Time_Around : Boolean := True;
- -- This needs a comment ???
-
-- Routines to support conversion between types Lines_Table_Ptr,
-- Logical_Lines_Table_Ptr and System.Address.
@@ -78,6 +74,24 @@
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 @@
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 @@
---------------------------
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 @@
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 @@
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,61 +972,30 @@
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);
+ 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);
- type Source_Buffer_Ptr_Var is access all Big_Source_Buffer;
+ if S.Lines_Table /= null then
+ Memory.Free (To_Address (S.Lines_Table));
+ S.Lines_Table := null;
+ end if;
- 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.
+ if S.Logical_Lines_Table /= null then
+ Memory.Free (To_Address (S.Logical_Lines_Table));
+ S.Logical_Lines_Table := null;
+ end if;
- pragma Warnings (Off);
- -- This unchecked conversion is aliasing safe, since it is not
- -- used to create improperly aliased pointer values.
+ else
+ Free_Dope (S.Source_Text'Address);
+ S.Source_Text := null;
+ end if;
+ end;
+ end loop;
- function To_Source_Buffer_Ptr_Var is new
- Unchecked_Conversion (Address, Source_Buffer_Ptr_Var);
-
- pragma Warnings (On);
-
- Tmp1 : Source_Buffer_Ptr_Var;
-
- begin
- if S.Instance /= No_Instance_Id then
- null;
-
- 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;
- end if;
- end;
- end loop;
- end if;
-
-- Read in source file table and instance table
Source_File.Tree_Read;
@@ -938,56 +1008,10 @@
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 @@
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;
+ 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;
- pragma Suppress (All_Checks);
+ -- 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 (Off);
- -- This unchecked conversion is aliasing safe, since it is
- -- never used to create improperly aliased pointer values.
+ else
+ declare
+ ST : Source_File_Record renames
+ Source_File.Table (S.Template);
- function To_Source_Buffer_Ptr is new
- Unchecked_Conversion (Address, Source_Buffer_Ptr);
+ begin
+ -- The lines tables are copied from the template entry
- pragma Warnings (On);
+ S.Lines_Table := ST.Lines_Table;
+ S.Logical_Lines_Table := ST.Logical_Lines_Table;
- begin
- T := new B;
+ -- The Source_Text of the instance is the same data as that
+ -- of the template, but with different bounds.
- Tree_Read_Data (T (S.Source_First)'Address,
- Int (S.Source_Last) - Int (S.Source_First) + 1);
-
- 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 @@
-- 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
Index: sinput.ads
===================================================================
--- sinput.ads (revision 247234)
+++ sinput.ads (working copy)
@@ -63,6 +63,7 @@
with Alloc;
with Casing; use Casing;
with Namet; use Namet;
+with System;
with Table;
with Types; use Types;
@@ -219,19 +220,17 @@
-- pragmas are used, then the value is set to No_Line_Number.
-- Source_Text : Source_Buffer_Ptr (read-only)
- -- Text of source file. Note that every source file has a distinct set
- -- of non-overlapping logical bounds, so it is possible to determine
- -- which file is referenced from a given subscript (Source_Ptr) value.
+ -- Text of source file. Every source file has a distinct set of
+ -- nonoverlapping bounds, so it is possible to determine which
+ -- file is referenced from a given subscript (Source_Ptr) value.
-- Source_First : Source_Ptr; (read-only)
- -- Subscript of first character in Source_Text. Note that this cannot
- -- be obtained as Source_Text'First, because we use virtual origin
- -- addressing.
+ -- This is always equal to Source_Text'First, except during
+ -- construction of a debug output file (*.dg), when Source_Text = null,
+ -- and Source_First is the size so far. Likewise for Last.
-- Source_Last : Source_Ptr; (read-only)
- -- Subscript of last character in Source_Text. Note that this cannot
- -- be obtained as Source_Text'Last, because we use virtual origin
- -- addressing, so this value is always Source_Ptr'Last.
+ -- Same idea as Source_Last, but for Last
-- Time_Stamp : Time_Stamp_Type; (read-only)
-- Time stamp of the source file
@@ -341,29 +340,6 @@
Main_Source_File : Source_File_Index := No_Source_File;
-- This is set to the source file index of the main unit
- -----------------------------
- -- 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;
-
- procedure Set_Source_File_Index_Table (Xnew : Source_File_Index);
- -- Sets entries in the Source_File_Index_Table for the newly created
- -- Source_File table entry whose index is Xnew. The Source_First and
- -- Source_Last fields of this entry must be set before the call.
-
-----------------------
-- Checksum Handling --
-----------------------
@@ -396,13 +372,13 @@
-- is also possible to find the location of the instantiation.
-- This is achieved as follows. When an instantiation occurs, a new entry
- -- is made in the source file table. This entry points to the same source
- -- text, i.e. the file that contains the instantiation, but has a distinct
- -- set of Source_Ptr index values. The separate range of Sloc values avoids
+ -- is made in the source file table. The Source_Text of the instantiation
+ -- points to the same Source_Buffer as the Source_Text of the template, but
+ -- with different bounds. The separate range of Sloc values avoids
-- confusion, and means that the Sloc values can still be used to uniquely
- -- identify the source file table entry. It is possible for both entries
- -- to point to the same text, because of the virtual origin pointers used
- -- in the source table.
+ -- identify the source file table entry. See Set_Dope below for the
+ -- low-level trickery that allows two different pointers to point at the
+ -- same array, but with different bounds.
-- The Instantiation_Id field of this source file index entry, set
-- to No_Instance_Id for normal entries, instead contains a value that
@@ -858,6 +834,7 @@
-- Max_Source_Line gives the maximum used value, this gives the
-- maximum allocated value.
+ Index : Source_File_Index := 123456789; -- for debugging
end record;
-- The following representation clause ensures that the above record
@@ -892,36 +869,38 @@
Identifier_Casing at 78 range 0 .. 15;
Sloc_Adjust at 80 range 0 .. 31;
Lines_Table_Max at 84 range 0 .. 31;
+ Index at 92 range 0 .. 31;
-- The following fields are pointers, so we have to specialize their
-- lengths using pointer size, obtained above as Standard'Address_Size.
+ -- Note that Source_Text is a fat pointer, so it has size = AS*2.
- Source_Text at 92 range 0 .. AS - 1;
- Lines_Table at 92 range AS .. AS * 2 - 1;
- Logical_Lines_Table at 92 range AS * 2 .. AS * 3 - 1;
- end record;
+ Source_Text at 96 range 0 .. AS * 2 - 1;
+ Lines_Table at 96 range AS * 2 .. AS * 3 - 1;
+ Logical_Lines_Table at 96 range AS * 3 .. AS * 4 - 1;
+ end record; -- Source_File_Record
- for Source_File_Record'Size use 92 * 8 + AS * 3;
+ for Source_File_Record'Size use 96 * 8 + AS * 4;
-- This ensures that we did not leave out any fields
- package Source_File is new Table.Table (
- Table_Component_Type => Source_File_Record,
- Table_Index_Type => Source_File_Index,
- Table_Low_Bound => 1,
- Table_Initial => Alloc.Source_File_Initial,
- Table_Increment => Alloc.Source_File_Increment,
- Table_Name => "Source_File");
+ package Source_File is new Table.Table
+ (Table_Component_Type => Source_File_Record,
+ Table_Index_Type => Source_File_Index,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.Source_File_Initial,
+ Table_Increment => Alloc.Source_File_Increment,
+ Table_Name => "Source_File");
-- Auxiliary table containing source location of instantiations. Index 0
-- is used for code that does not come from an instance.
- package Instances is new Table.Table (
- Table_Component_Type => Source_Ptr,
- Table_Index_Type => Instance_Id,
- Table_Low_Bound => 0,
- Table_Initial => Alloc.Source_File_Initial,
- Table_Increment => Alloc.Source_File_Increment,
- Table_Name => "Instances");
+ package Instances is new Table.Table
+ (Table_Component_Type => Source_Ptr,
+ Table_Index_Type => Instance_Id,
+ Table_Low_Bound => 0,
+ Table_Initial => Alloc.Source_File_Initial,
+ Table_Increment => Alloc.Source_File_Increment,
+ Table_Name => "Instances");
-----------------
-- Subprograms --
@@ -948,4 +927,32 @@
-- correspond to the current value of Num_Source_Lines, releasing
-- any unused storage. This is used by Sinput.L and Sinput.D.
+ procedure Set_Source_File_Index_Table (Xnew : Source_File_Index);
+ -- Sets entries in the Source_File_Index_Table for the newly created
+ -- Source_File table entry whose index is Xnew. The Source_First and
+ -- Source_Last fields of this entry must be set before the call.
+ -- See package body for details.
+
+ type Dope_Rec is record
+ First, Last : Source_Ptr'Base;
+ end record;
+ Dope_Rec_Size : constant := 2 * Source_Ptr'Size;
+ for Dope_Rec'Size use Dope_Rec_Size;
+ for Dope_Rec'Alignment use Dope_Rec_Size / 8;
+ type Dope_Ptr is access all Dope_Rec;
+
+ procedure Set_Dope
+ (Src : System.Address; New_Dope : Dope_Ptr);
+ -- Src is the address of a variable of type Source_Buffer_Ptr, which is a
+ -- fat pointer. This sets the dope part of the fat pointer to point to the
+ -- specified New_Dope. This low-level processing is used to make the
+ -- Source_Text of an instance point to the same text as the template, but
+ -- with different bounds.
+
+ procedure Free_Dope (Src : System.Address);
+ -- Calls Unchecked_Deallocation on the dope part of the fat pointer Src
+
+ procedure Free_Source_Buffer (Src : in out Source_Buffer_Ptr);
+ -- Deallocates the source buffer
+
end Sinput;
Index: sinput-c.adb
===================================================================
--- sinput-c.adb (revision 247177)
+++ sinput-c.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
@@ -23,7 +23,9 @@
-- --
------------------------------------------------------------------------------
+with Debug; use Debug;
with Opt; use Opt;
+with Output; use Output;
with System; use System;
with Ada.Unchecked_Conversion;
@@ -65,6 +67,14 @@
Source_File.Increment_Last;
X := Source_File.Last;
+ if Debug_Flag_L then
+ Write_Str ("Sinput.C.Load_File: created source ");
+ Write_Int (Int (X));
+ Write_Str (" for ");
+ Write_Str (Path);
+ Write_Line ("");
+ end if;
+
if X = Source_File.First then
Lo := First_Source_Ptr;
else
@@ -100,50 +110,24 @@
-- Do the actual read operation
declare
- subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
- -- Physical buffer allocated
-
- type Actual_Source_Ptr is access Actual_Source_Buffer;
- -- This is the pointer type for the physical buffer allocated
-
- Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
- -- And this is the actual physical buffer
-
- begin
+ Var_Ptr : constant Source_Buffer_Ptr_Var :=
+ new Source_Buffer (Lo .. Hi);
-- Allocate source buffer, allowing extra character at end for EOF
+ begin
-- Some systems have file types that require one read per line,
-- so read until we get the Len bytes or until there are no more
-- characters.
Hi := Lo;
loop
- Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
+ Actual_Len := Read (Source_File_FD, Var_Ptr (Hi)'Address, Len);
Hi := Hi + Source_Ptr (Actual_Len);
exit when Actual_Len = Len or else Actual_Len <= 0;
end loop;
- Actual_Ptr (Hi) := EOF;
-
- -- Now we need to work out the proper virtual origin pointer to
- -- return. This is exactly Actual_Ptr (0)'Address, but we have to
- -- be careful to suppress checks to compute this address.
-
- declare
- pragma Suppress (All_Checks);
-
- pragma Warnings (Off);
- -- The following unchecked conversion is aliased safe, since it
- -- is not used to create improperly aliased pointer values.
-
- function To_Source_Buffer_Ptr is new
- Ada.Unchecked_Conversion (Address, Source_Buffer_Ptr);
-
- pragma Warnings (On);
-
- begin
- Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
- end;
+ Var_Ptr (Hi) := EOF;
+ Src := Var_Ptr.all'Access;
end;
-- Read is complete, close the file and we are done (no need to test
@@ -199,7 +183,8 @@
Source_Text => Src,
Template => No_Source_File,
Unit => No_Unit,
- Time_Stamp => Empty_Time_Stamp);
+ Time_Stamp => Empty_Time_Stamp,
+ Index => X);
Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
S.Lines_Table (1) := Lo;
Index: sinput-c.ads
===================================================================
--- sinput-c.ads (revision 247177)
+++ sinput-c.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
@@ -25,8 +25,9 @@
-- This child package contains a procedure to load files
--- It is used by Sinput.P to load project files, and by GPrep to load
--- preprocessor definition files and input files.
+-- It is used by Sinput.P to load project files, by GPrep to load preprocessor
+-- definition files and input files, and by ALI.Util to compute checksums for
+-- source files.
package Sinput.C is
Index: sinput-d.adb
===================================================================
--- sinput-d.adb (revision 247177)
+++ sinput-d.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2017, 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- --
@@ -23,8 +23,10 @@
-- --
------------------------------------------------------------------------------
+with Debug; use Debug;
with Osint; use Osint;
with Osint.C; use Osint.C;
+with Output; use Output;
package body Sinput.D is
@@ -36,11 +38,8 @@
------------------------
procedure Close_Debug_Source is
- S : Source_File_Record renames Source_File.Table (Dfile);
+ SFR : Source_File_Record renames Source_File.Table (Dfile);
Src : Source_Buffer_Ptr;
-
- pragma Warnings (Off, S);
-
begin
Trim_Lines_Table (Dfile);
Close_Debug_File;
@@ -49,8 +48,10 @@
-- subsequent access.
Read_Source_File
- (S.Full_Debug_Name, S.Source_First, S.Source_Last, Src);
- S.Source_Text := Src;
+ (SFR.Full_Debug_Name, SFR.Source_First, SFR.Source_Last, Src);
+ SFR.Source_Text := Src;
+ pragma Assert (SFR.Source_Text'First = SFR.Source_First);
+ pragma Assert (SFR.Source_Text'Last = SFR.Source_Last);
end Close_Debug_Source;
-------------------------
@@ -72,8 +73,10 @@
S : Source_File_Record renames Source_File.Table (Dfile);
begin
+ S.Index := Dfile;
S.Full_Debug_Name := Create_Debug_File (S.File_Name);
S.Debug_Source_Name := Strip_Directory (S.Full_Debug_Name);
+ S.Source_Text := null;
S.Source_First := Loc;
S.Source_Last := Loc;
S.Lines_Table := null;
@@ -85,6 +88,14 @@
Alloc_Line_Tables
(S, Int (Source_File.Table (Source).Last_Source_Line * 3));
S.Lines_Table (1) := Loc;
+
+ if Debug_Flag_L then
+ Write_Str ("Sinput.D.Create_Debug_Source: created source ");
+ Write_Int (Int (Dfile));
+ Write_Str (" for ");
+ Write_Str (Get_Name_String (S.Full_Debug_Name));
+ Write_Line ("");
+ end if;
end;
end Create_Debug_Source;
Index: sinput-l.adb
===================================================================
--- sinput-l.adb (revision 247234)
+++ sinput-l.adb (working copy)
@@ -142,6 +142,12 @@
Source_File.Append (Source_File.Table (Xold));
Xnew := Source_File.Last;
+ if Debug_Flag_L then
+ Write_Str ("Create_Instantiation_Source: created source ");
+ Write_Int (Int (Xnew));
+ Write_Line ("");
+ end if;
+
declare
Sold : Source_File_Record renames Source_File.Table (Xold);
Snew : Source_File_Record renames Source_File.Table (Xnew);
@@ -149,6 +155,7 @@
Inst_Spec : Node_Id;
begin
+ Snew.Index := Xnew;
Snew.Inlined_Body := Inlined_Body;
Snew.Inherited_Pragma := Inherited_Pragma;
Snew.Template := Xold;
@@ -213,8 +220,8 @@
end if;
-- Now compute the new values of Source_First and Source_Last and
- -- adjust the source file pointer to have the correct virtual origin
- -- for the new range of values.
+ -- adjust the source file pointer to have the correct bounds for the
+ -- new range of values.
-- Source_First must be greater than the last Source_Last value and
-- also must be a multiple of Source_Align.
@@ -229,6 +236,19 @@
Snew.Sloc_Adjust := Sold.Sloc_Adjust - Factor.Adjust;
+ -- Modify the Dope of the instance Source_Text to use the
+ -- above-computed bounds.
+
+ declare
+ Dope : constant Dope_Ptr :=
+ new Dope_Rec'(Snew.Source_First, Snew.Source_Last);
+ begin
+ Snew.Source_Text := Sold.Source_Text;
+ Set_Dope (Snew.Source_Text'Address, Dope);
+ pragma Assert (Snew.Source_Text'First = Snew.Source_First);
+ pragma Assert (Snew.Source_Text'Last = Snew.Source_Last);
+ end;
+
if Debug_Flag_L then
Write_Eol;
Write_Str ("*** Create instantiation source for ");
@@ -307,31 +327,6 @@
Write_Location (Sloc (Inst_Node));
Write_Eol;
end if;
-
- -- For a given character in the source, a higher subscript will be
- -- used to access the instantiation, which means that the virtual
- -- origin must have a corresponding lower value. We compute this new
- -- origin by taking the address of the appropriate adjusted element
- -- in the old array. Since this adjusted element will be at a
- -- negative subscript, we must suppress checks.
-
- declare
- pragma Suppress (All_Checks);
-
- pragma Warnings (Off);
- -- This unchecked conversion is aliasing safe, since it is never
- -- used to create improperly aliased pointer values.
-
- function To_Source_Buffer_Ptr is new
- Unchecked_Conversion (Address, Source_Buffer_Ptr);
-
- pragma Warnings (On);
-
- begin
- Snew.Source_Text :=
- To_Source_Buffer_Ptr
- (Sold.Source_Text (-Factor.Adjust)'Address);
- end;
end;
end Create_Instantiation_Source;
@@ -405,6 +400,14 @@
Source_File.Increment_Last;
X := Source_File.Last;
+ if Debug_Flag_L then
+ Write_Str ("Sinput.L.Load_File: created source ");
+ Write_Int (Int (X));
+ Write_Str (" for ");
+ Write_Str (Get_Name_String (N));
+ Write_Line ("");
+ end if;
+
-- Compute starting index, respecting alignment requirement
if X = Source_File.First then
@@ -529,7 +532,8 @@
Source_Text => Src,
Template => No_Source_File,
Unit => No_Unit,
- Time_Stamp => Osint.Current_Source_File_Stamp);
+ Time_Stamp => Osint.Current_Source_File_Stamp,
+ Index => X);
Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
S.Lines_Table (1) := Lo;
@@ -688,54 +692,28 @@
-- Create the new source buffer
declare
- subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
- -- Physical buffer allocated
+ Var_Ptr : constant Source_Buffer_Ptr_Var :=
+ new Source_Buffer (Lo .. Hi);
+ -- Allocate source buffer, allowing extra character at
+ -- end for EOF.
- type Actual_Source_Ptr is access Actual_Source_Buffer;
- -- Pointer type for the physical buffer allocated
-
- Actual_Ptr : constant Actual_Source_Ptr :=
- new Actual_Source_Buffer;
- -- Actual physical buffer
-
begin
- Actual_Ptr (Lo .. Hi - 1) :=
+ Var_Ptr (Lo .. Hi - 1) :=
Prep_Buffer (1 .. Prep_Buffer_Last);
- Actual_Ptr (Hi) := EOF;
+ Var_Ptr (Hi) := EOF;
+ Src := Var_Ptr.all'Access;
+ end;
- -- Now we need to work out the proper virtual origin
- -- pointer to return. This is Actual_Ptr (0)'Address, but
- -- we have to be careful to suppress checks to compute
- -- this address.
+ -- Record in the table the new source buffer and the
+ -- new value of Hi.
- declare
- pragma Suppress (All_Checks);
+ Source_File.Table (X).Source_Text := Src;
+ Source_File.Table (X).Source_Last := Hi;
- pragma Warnings (Off);
- -- This unchecked conversion is aliasing safe, since
- -- it is never used to create improperly aliased
- -- pointer values.
+ -- Reset Last_Line to 1, because the lines do not
+ -- have necessarily the same starts and lengths.
- function To_Source_Buffer_Ptr is new
- Unchecked_Conversion (Address, Source_Buffer_Ptr);
-
- pragma Warnings (On);
-
- begin
- Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
-
- -- Record in the table the new source buffer and the
- -- new value of Hi.
-
- Source_File.Table (X).Source_Text := Src;
- Source_File.Table (X).Source_Last := Hi;
-
- -- Reset Last_Line to 1, because the lines do not
- -- have necessarily the same starts and lengths.
-
- Source_File.Table (X).Last_Source_Line := 1;
- end;
- end;
+ Source_File.Table (X).Last_Source_Line := 1;
end if;
end;
end if;
Index: sinput-p.adb
===================================================================
--- sinput-p.adb (revision 247177)
+++ sinput-p.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
@@ -23,14 +23,12 @@
-- --
------------------------------------------------------------------------------
-with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
with Prj.Err;
with Sinput.C;
-with System;
-
package body Sinput.P is
First : Boolean := True;
@@ -39,10 +37,10 @@
-- The flag is reset to False at the first call to Load_Project_File.
-- Calling Reset_First sets it back to True.
- procedure Free is new Ada.Unchecked_Deallocation
+ procedure Free is new Unchecked_Deallocation
(Lines_Table_Type, Lines_Table_Ptr);
- procedure Free is new Ada.Unchecked_Deallocation
+ procedure Free is new Unchecked_Deallocation
(Logical_Lines_Table_Type, Logical_Lines_Table_Ptr);
-----------------------------
@@ -50,39 +48,18 @@
-----------------------------
procedure Clear_Source_File_Table is
- use System;
-
begin
for X in 1 .. Source_File.Last loop
declare
S : Source_File_Record renames Source_File.Table (X);
- Lo : constant Source_Ptr := S.Source_First;
- Hi : constant Source_Ptr := S.Source_Last;
- subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
- -- Physical buffer allocated
-
- type Actual_Source_Ptr is access Actual_Source_Buffer;
- -- This is the pointer type for the physical buffer allocated
-
- procedure Free is new Ada.Unchecked_Deallocation
- (Actual_Source_Buffer, Actual_Source_Ptr);
-
- pragma Suppress (All_Checks);
-
- pragma Warnings (Off);
- -- The following unchecked conversion is aliased safe, since it
- -- is not used to create improperly aliased pointer values.
-
- function To_Actual_Source_Ptr is new
- Ada.Unchecked_Conversion (Address, Actual_Source_Ptr);
-
- pragma Warnings (On);
-
- Actual_Ptr : Actual_Source_Ptr :=
- To_Actual_Source_Ptr (S.Source_Text (Lo)'Address);
-
begin
- Free (Actual_Ptr);
+ if S.Instance = No_Instance_Id then
+ Free_Source_Buffer (S.Source_Text);
+ else
+ Free_Dope (S.Source_Text'Address);
+ S.Source_Text := null;
+ end if;
+
Free (S.Lines_Table);
Free (S.Logical_Lines_Table);
end;
Index: targparm.adb
===================================================================
--- targparm.adb (revision 247234)
+++ targparm.adb (working copy)
@@ -106,34 +106,34 @@
type Buffer_Ptr is access constant Source_Buffer;
Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr :=
- (AAM_Str'Access,
- ACR_Str'Access,
- ASD_Str'Access,
- BDC_Str'Access,
- BOC_Str'Access,
- CLA_Str'Access,
- CRT_Str'Access,
- D32_Str'Access,
- DEN_Str'Access,
- EXS_Str'Access,
- FEL_Str'Access,
- FEX_Str'Access,
- FFO_Str'Access,
- MOV_Str'Access,
- MRN_Str'Access,
- PAS_Str'Access,
- SAG_Str'Access,
- SAP_Str'Access,
- SCA_Str'Access,
- SCC_Str'Access,
- SCD_Str'Access,
- SCL_Str'Access,
- SCP_Str'Access,
- SLS_Str'Access,
- SNZ_Str'Access,
- SSL_Str'Access,
- UAM_Str'Access,
- ZCX_Str'Access);
+ (AAM => AAM_Str'Access,
+ ACR => ACR_Str'Access,
+ ASD => ASD_Str'Access,
+ BDC => BDC_Str'Access,
+ BOC => BOC_Str'Access,
+ CLA => CLA_Str'Access,
+ CRT => CRT_Str'Access,
+ D32 => D32_Str'Access,
+ DEN => DEN_Str'Access,
+ EXS => EXS_Str'Access,
+ FEL => FEL_Str'Access,
+ FEX => FEX_Str'Access,
+ FFO => FFO_Str'Access,
+ MOV => MOV_Str'Access,
+ MRN => MRN_Str'Access,
+ PAS => PAS_Str'Access,
+ SAG => SAG_Str'Access,
+ SAP => SAP_Str'Access,
+ SCA => SCA_Str'Access,
+ SCC => SCC_Str'Access,
+ SCD => SCD_Str'Access,
+ SCL => SCL_Str'Access,
+ SCP => SCP_Str'Access,
+ SLS => SLS_Str'Access,
+ SNZ => SNZ_Str'Access,
+ SSL => SSL_Str'Access,
+ UAM => UAM_Str'Access,
+ ZCX => ZCX_Str'Access);
-----------------------
-- Local Subprograms --
@@ -146,7 +146,7 @@
-- Get_Target_Parameters --
---------------------------
- -- Version which reads in system.ads
+ -- Version that reads in system.ads
procedure Get_Target_Parameters
(Make_Id : Make_Id_Type := null;
@@ -200,6 +200,9 @@
Set_NUA : Set_NUA_Type := null;
Set_NUP : Set_NUP_Type := null)
is
+ pragma Assert (System_Text'First = Source_First);
+ pragma Assert (System_Text'Last = Source_Last);
+
P : Source_Ptr;
-- Scans source buffer containing source of system.ads
@@ -220,6 +223,13 @@
-- with Name_Len being length, folded to lower case. On return, P points
-- just past the last character (which should be a right paren).
+ function Looking_At (S : Source_Buffer) return Boolean;
+ -- True if P points to the same text as S in System_Text
+
+ function Looking_At_Skip (S : Source_Buffer) return Boolean;
+ -- True if P points to the same text as S in System_Text,
+ -- and if True, moves P forward to skip S as a side effect.
+
------------------
-- Collect_Name --
------------------
@@ -249,15 +259,39 @@
end loop;
end Collect_Name;
+ ----------------
+ -- Looking_At --
+ ----------------
+
+ function Looking_At (S : Source_Buffer) return Boolean is
+ Last : constant Source_Ptr := P + S'Length - 1;
+ begin
+ return Last <= System_Text'Last
+ and then System_Text (P .. Last) = S;
+ end Looking_At;
+
+ ---------------------
+ -- Looking_At_Skip --
+ ---------------------
+
+ function Looking_At_Skip (S : Source_Buffer) return Boolean is
+ Result : constant Boolean := Looking_At (S);
+ begin
+ if Result then
+ P := P + S'Length;
+ end if;
+
+ return Result;
+ end Looking_At_Skip;
+
-- Start of processing for Get_Target_Parameters
begin
if Parameters_Obtained then
return;
- else
- Parameters_Obtained := True;
end if;
+ Parameters_Obtained := True;
Opt.Address_Is_Private := False;
-- Loop through source lines
@@ -271,71 +305,59 @@
-- For a special exception, see processing for pragma Pure below
P := Source_First;
- Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop
- -- Skip comments quickly
+ while not Looking_At ("end System;") loop
+ -- Skip comments
- if System_Text (P) = '-' then
+ if Looking_At ("-") then
goto Line_Loop_Continue;
-- Test for type Address is private
- elsif System_Text (P .. P + 26) = " type Address is private;" then
+ elsif Looking_At_Skip (" type Address is private;") then
Opt.Address_Is_Private := True;
- P := P + 26;
goto Line_Loop_Continue;
-- Test for pragma Profile (Ravenscar);
- elsif System_Text (P .. P + 26) =
- "pragma Profile (Ravenscar);"
- then
+ elsif Looking_At_Skip ("pragma Profile (Ravenscar);") then
Set_Profile_Restrictions (Ravenscar);
Opt.Task_Dispatching_Policy := 'F';
Opt.Locking_Policy := 'C';
- P := P + 27;
goto Line_Loop_Continue;
-- Test for pragma Profile (GNAT_Extended_Ravenscar);
- elsif System_Text (P .. P + 40) =
- "pragma Profile (GNAT_Extended_Ravenscar);"
+ elsif Looking_At_Skip
+ ("pragma Profile (GNAT_Extended_Ravenscar);")
then
Set_Profile_Restrictions (GNAT_Extended_Ravenscar);
Opt.Task_Dispatching_Policy := 'F';
Opt.Locking_Policy := 'C';
- P := P + 41;
goto Line_Loop_Continue;
-- Test for pragma Profile (GNAT_Ravenscar_EDF);
- elsif System_Text (P .. P + 35) =
- "pragma Profile (GNAT_Ravenscar_EDF);"
- then
+ elsif Looking_At_Skip ("pragma Profile (GNAT_Ravenscar_EDF);") then
Set_Profile_Restrictions (GNAT_Ravenscar_EDF);
Opt.Task_Dispatching_Policy := 'E';
Opt.Locking_Policy := 'C';
- P := P + 36;
goto Line_Loop_Continue;
-- Test for pragma Profile (Restricted);
- elsif System_Text (P .. P + 27) =
- "pragma Profile (Restricted);"
- then
+ elsif Looking_At_Skip ("pragma Profile (Restricted);") then
Set_Profile_Restrictions (Restricted);
- P := P + 28;
goto Line_Loop_Continue;
-- Test for pragma Restrictions
- elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
- P := P + 21;
+ elsif Looking_At_Skip ("pragma Restrictions (") then
PR_Start := P - 1;
-- Boolean restrictions
- Rloop : for K in All_Boolean_Restrictions loop
+ for K in All_Boolean_Restrictions loop
declare
Rname : constant String := Restriction_Id'Image (K);
@@ -354,9 +376,8 @@
end if;
end;
- <<Rloop_Continue>>
- null;
- end loop Rloop;
+ <<Rloop_Continue>> null;
+ end loop;
-- Restrictions taking integer parameter
@@ -423,15 +444,12 @@
end if;
end;
- <<Ploop_Continue>>
- null;
+ <<Ploop_Continue>> null;
end loop Ploop;
-- No_Dependence case
- if System_Text (P .. P + 16) = "No_Dependence => " then
- P := P + 17;
-
+ if Looking_At_Skip ("No_Dependence => ") then
-- Skip this processing (and simply ignore No_Dependence lines)
-- if caller did not supply the three subprograms we need to
-- process these lines.
@@ -481,10 +499,7 @@
-- No_Specification_Of_Aspect case
- elsif System_Text (P .. P + 29) = "No_Specification_Of_Aspect => "
- then
- P := P + 30;
-
+ elsif Looking_At_Skip ("No_Specification_Of_Aspect => ") then
-- Skip this processing (and simply ignore the pragma), if
-- caller did not supply the subprogram we need to process
-- such lines.
@@ -513,9 +528,7 @@
-- No_Use_Of_Attribute case
- elsif System_Text (P .. P + 22) = "No_Use_Of_Attribute => " then
- P := P + 23;
-
+ elsif Looking_At_Skip ("No_Use_Of_Attribute => ") then
-- Skip this processing (and simply ignore No_Use_Of_Attribute
-- lines) if caller did not supply the subprogram we need to
-- process such lines.
@@ -544,9 +557,7 @@
-- No_Use_Of_Pragma case
- elsif System_Text (P .. P + 19) = "No_Use_Of_Pragma => " then
- P := P + 20;
-
+ elsif Looking_At_Skip ("No_Use_Of_Pragma => ") then
-- Skip this processing (and simply ignore No_Use_Of_Pragma
-- lines) if caller did not supply the subprogram we need to
-- process such lines.
@@ -597,89 +608,72 @@
-- Test for pragma Detect_Blocking;
- elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then
- P := P + 23;
+ elsif Looking_At_Skip ("pragma Detect_Blocking;") then
Opt.Detect_Blocking := True;
goto Line_Loop_Continue;
-- Discard_Names
- elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then
- P := P + 21;
+ elsif Looking_At_Skip ("pragma Discard_Names;") then
Opt.Global_Discard_Names := True;
goto Line_Loop_Continue;
-- Locking Policy
- elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then
- P := P + 23;
+ elsif Looking_At_Skip ("pragma Locking_Policy (") then
Opt.Locking_Policy := System_Text (P);
Opt.Locking_Policy_Sloc := System_Location;
goto Line_Loop_Continue;
-- Normalize_Scalars
- elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then
- P := P + 25;
+ elsif Looking_At_Skip ("pragma Normalize_Scalars;") then
Opt.Normalize_Scalars := True;
Opt.Init_Or_Norm_Scalars := True;
goto Line_Loop_Continue;
-- Partition_Elaboration_Policy
- elsif System_Text (P .. P + 36) =
- "pragma Partition_Elaboration_Policy ("
- then
- P := P + 37;
+ elsif Looking_At_Skip ("pragma Partition_Elaboration_Policy (") then
Opt.Partition_Elaboration_Policy := System_Text (P);
Opt.Partition_Elaboration_Policy_Sloc := System_Location;
goto Line_Loop_Continue;
-- Polling (On)
- elsif System_Text (P .. P + 19) = "pragma Polling (On);" then
- P := P + 20;
+ elsif Looking_At_Skip ("pragma Polling (On);") then
Opt.Polling_Required := True;
goto Line_Loop_Continue;
-- Queuing Policy
- elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then
- P := P + 23;
+ elsif Looking_At_Skip ("pragma Queuing_Policy (") then
Opt.Queuing_Policy := System_Text (P);
Opt.Queuing_Policy_Sloc := System_Location;
goto Line_Loop_Continue;
-- Suppress_Exception_Locations
- elsif System_Text (P .. P + 35) =
- "pragma Suppress_Exception_Locations;"
- then
- P := P + 36;
+ elsif Looking_At_Skip ("pragma Suppress_Exception_Locations;") then
Opt.Exception_Locations_Suppressed := True;
goto Line_Loop_Continue;
-- Task_Dispatching Policy
- elsif System_Text (P .. P + 31) =
- "pragma Task_Dispatching_Policy ("
- then
- P := P + 32;
+ elsif Looking_At_Skip ("pragma Task_Dispatching_Policy (") then
Opt.Task_Dispatching_Policy := System_Text (P);
Opt.Task_Dispatching_Policy_Sloc := System_Location;
goto Line_Loop_Continue;
-- No other configuration pragmas are permitted
- elsif System_Text (P .. P + 6) = "pragma " then
-
+ elsif Looking_At ("pragma ") then
-- Special exception, we allow pragma Pure (System) appearing in
-- column one. This is an obsolete usage which may show up in old
-- tests with an obsolete version of system.ads, so we recognize
-- and ignore it to make life easier in handling such tests.
- if System_Text (P .. P + 20) = "pragma Pure (System);" then
- P := P + 21;
+ if Looking_At_Skip ("pragma Pure (System);") then
goto Line_Loop_Continue;
end if;
@@ -699,11 +693,9 @@
-- See if we have a Run_Time_Name
- elsif System_Text (P .. P + 38) =
- " Run_Time_Name : constant String := """
+ elsif Looking_At_Skip
+ (" Run_Time_Name : constant String := """)
then
- P := P + 39;
-
Name_Len := 0;
while System_Text (P) in 'A' .. 'Z'
or else
@@ -739,11 +731,9 @@
-- See if we have an Executable_Extension
- elsif System_Text (P .. P + 45) =
- " Executable_Extension : constant String := """
+ elsif Looking_At_Skip
+ (" Executable_Extension : constant String := """)
then
- P := P + 46;
-
Name_Len := 0;
while System_Text (P) /= '"'
and then System_Text (P) /= ASCII.LF
@@ -769,11 +759,7 @@
else
Config_Param_Loop : for K in Targparm_Tags loop
- if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) =
- Targparm_Str (K).all
- then
- P := P + 3 + Targparm_Str (K)'Length;
-
+ if Looking_At_Skip (" " & Targparm_Str (K).all) then
if Targparm_Flags (K) then
Set_Standard_Error;
Write_Line
@@ -851,14 +837,18 @@
<<Line_Loop_Continue>>
- while System_Text (P) /= CR and then System_Text (P) /= LF loop
+ while P < Source_Last
+ and then System_Text (P) /= CR
+ and then System_Text (P) /= LF
+ loop
P := P + 1;
- exit when P >= Source_Last;
end loop;
- while System_Text (P) = CR or else System_Text (P) = LF loop
+ while P < Source_Last
+ and then (System_Text (P) = CR
+ or else System_Text (P) = LF)
+ loop
P := P + 1;
- exit when P >= Source_Last;
end loop;
if P >= Source_Last then
@@ -868,7 +858,7 @@
Set_Standard_Output;
raise Unrecoverable_Error;
end if;
- end loop Line_Loop;
+ end loop;
if Fatal then
raise Unrecoverable_Error;
Index: types.ads
===================================================================
--- types.ads (revision 247235)
+++ types.ads (working copy)
@@ -196,23 +196,14 @@
-- which are one greater than the previous upper bound, rounded up to
-- a multiple of Source_Align.
- subtype Big_Source_Buffer is Text_Buffer (0 .. Text_Ptr'Last);
- -- This is a virtual type used as the designated type of the access type
- -- Source_Buffer_Ptr, see Osint.Read_Source_File for details.
+ type Source_Buffer_Ptr_Var is access all Source_Buffer;
+ type Source_Buffer_Ptr is access constant Source_Buffer;
+ -- Pointer to source buffer. Source_Buffer_Ptr_Var is used for allocation
+ -- and deallocation; Source_Buffer_Ptr is used for all other uses of source
+ -- buffers.
- type Source_Buffer_Ptr is access constant Big_Source_Buffer;
- -- Pointer to source buffer. We use virtual origin addressing for source
- -- buffers, with thin pointers. The pointer points to a virtual instance
- -- of type Big_Source_Buffer, where the actual type is in fact of type
- -- Source_Buffer. The address is adjusted so that the virtual origin
- -- addressing works correctly. See Osint.Read_Source_Buffer for further
- -- details. Again, as for Big_String_Ptr, we should never allocate using
- -- this type, but we don't give a storage size clause of zero, since we
- -- may end up doing deallocations of instances allocated manually.
-
function Null_Source_Buffer_Ptr (X : Source_Buffer_Ptr) return Boolean;
- -- True if X = null. ???This usage of "=" is wrong, because the zero-origin
- -- pointer could happen to be equal to null. We need to eliminate this.
+ -- True if X = null
function Source_Buffer_Ptr_Equal (X, Y : Source_Buffer_Ptr) return Boolean
renames "=";
@@ -220,10 +211,11 @@
-- Do not call this elsewhere.
function "=" (X, Y : Source_Buffer_Ptr) return Boolean is abstract;
- -- Make "=" abstract, to make sure no one calls it. Note that this makes
- -- "/=" abstract as well. Calls to "=" on Source_Buffer_Ptr are always
- -- wrong, because two different arrays allocated at two different addresses
- -- can have the same virtual origin.
+ -- Make "=" abstract. Note that this makes "/=" abstract as well. This is a
+ -- vestige of the zero-origin array indexing we used to use, where "=" is
+ -- always wrong (including the one in Null_Source_Buffer_Ptr). We keep this
+ -- just because we never need to compare Source_Buffer_Ptrs other than to
+ -- null.
subtype Source_Ptr is Text_Ptr;
-- Type used to represent a source location, which is a subscript of a
@@ -580,7 +572,7 @@
No_Unit : constant Unit_Number_Type := -1;
-- Special value used to signal no unit
- type Source_File_Index is new Int range -1 .. Int'Last;
+ type Source_File_Index is new Int range 0 .. Int'Last;
-- Type used to index the source file table (see package Sinput)
No_Source_File : constant Source_File_Index := 0;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2017-04-25 15:55 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2017-04-25 16:09 [Ada] Remove zero-origin array indexing for Source_Buffers Arnaud Charlet
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).