===================================================================
@@ -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
===================================================================
@@ -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;
===================================================================
@@ -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);
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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
===================================================================
@@ -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;
-------------------
===================================================================
@@ -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
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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);
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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;
===================================================================
@@ -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
===================================================================
@@ -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;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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, by GPrep to load preprocessor
+-- definition files and input files, and by ALI.Util to compute checksums for
+-- source files.
package Sinput.C is
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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;
===================================================================
@@ -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;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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;
===================================================================
@@ -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;
===================================================================
@@ -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;