+2017-04-25 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Case_Expression): Emit error message when
+ generating C code on complex case expressions.
+
+2017-04-25 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Generate a warning instead
+ of silently ignoring pragma Ada_xxx in Latest_Ada_Only mode.
+ * directio.ads, ioexcept.ads, sequenio.ads, text_io.ads: Use
+ Ada_2012 instead of Ada_2005 to be compatible with the above
+ change.
+ * bindgen.adb: Silence new warning on pragma Ada_95.
+
+2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb (Generate_Range_Check): Revert part of previous change.
+
+2017-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Try_Container_Indexing): Handle properly a
+ container indexing operation that appears as a an actual in a
+ parameter association in a procedure call.
+
+2017-04-25 Olivier Ramonat <ramonat@adacore.com>
+
+ * prj-proc.adb, sem_util.adb, s-stposu.adb, sem_attr.adb, prj-conf.ads:
+ Fix spelling mistakes.
+
+2017-04-25 Bob Duff <duff@adacore.com>
+
+ * types.ads, osint.adb, sinput-c.adb, sinput-d.adb, sinput-l.adb,
+ * sinput-p.adb: Use regular fat pointers, with bounds checking,
+ for source buffers. Fix misc obscure bugs.
+ * sinput.ads, sinput.adb: Use regular fat pointers, with bounds
+ checking, for source buffers. Modify representation clause for
+ Source_File_Record as appropriate. Move Source_File_Index_Table
+ from spec to body, because it is not used outside the body.
+ Move Set_Source_File_Index_Table into the private part, because
+ it is used only in the body and in children. Use trickery to
+ modify the dope in the generic instantiation case. It's ugly,
+ but not as ugly as the previous method. Fix documentation.
+ Remove obsolete code.
+ * fname-sf.adb, targparm.adb: Fix misc out-of-bounds
+ indexing in source buffers.
+ * fmap.adb: Avoid conversions from one string type to another.
+ Remove a use of global name buffer.
+ * osint.ads, sfn_scan.ads, sfn_scan.adb, sinput-c.ads: Comment
+ fixes.
+
2017-04-25 Gary Dismukes <dismukes@adacore.com>
* exp_util.adb, exp_ch4.adb: Minor reformatting.
-- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None
-- of the Ada 2005 or Ada 2012 constructs are needed by the binder file.
- WBI ("pragma Ada_95;");
WBI ("pragma Warnings (Off);");
+ WBI ("pragma Ada_95;");
-- If we are operating in Restrictions (No_Exception_Handlers) mode,
-- then we need to make sure that the binder program is compiled with
-- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None
-- of the Ada 2005/2012 constructs are needed by the binder file.
- WBI ("pragma Ada_95;");
WBI ("pragma Warnings (Off);");
+ WBI ("pragma Ada_95;");
-- Output Source_File_Name pragmas which look like
Set_Etype (N, Target_Base_Type);
end Convert_And_Check_Range;
- -- Local variables
-
- Checks_On : constant Boolean :=
- not Index_Checks_Suppressed (Target_Type)
- or else
- not Range_Checks_Suppressed (Target_Type);
-
-- Start of processing for Generate_Range_Check
begin
- if not Expander_Active or not Checks_On then
- return;
- end if;
-
-- First special case, if the source type is already within the range
-- of the target type, then no check is needed (probably we should have
-- stopped Do_Range_Check from being set in the first place, but better
-- --
------------------------------------------------------------------------------
-pragma Ada_2005;
--- Explicit setting of Ada 2005 mode is required here, since we want to with a
+pragma Ada_2012;
+-- Explicit setting of Ada 2012 mode is required here, since we want to with a
-- child unit (not possible in Ada 83 mode), and Direct_IO is not considered
--- to be an internal unit that is automatically compiled in Ada 2005 mode
+-- to be an internal unit that is automatically compiled in Ada 2012 mode
-- (since a user is allowed to redeclare Direct_IO).
with Ada.Direct_IO;
-- type Ptr_Typ is access all Typ;
else
+ if Generate_C_Code then
+
+ -- We cannot ensure that correct C code will be generated if
+ -- any temporary is created down the line (to e.g. handle
+ -- checks or capture values) since we might end up with
+ -- dangling references to local variables, so better be safe
+ -- and reject the construct.
+
+ Error_Msg_N
+ ("case expression too complex, use case statement instead", N);
+ end if;
+
Target_Typ := Make_Temporary (Loc, 'P');
Append_To (Acts,
-- 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
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;
-- 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
-- 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;
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 """);
No_Mapping_File := True;
else
- BS := To_Big_String_Ptr (Src);
- SP := BS (1 .. Natural (Hi))'Unrestricted_Access;
-
loop
-- Get the unit name
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
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;
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
package body Fname.SF is
- function To_Big_String_Ptr is new Unchecked_Conversion
- (Source_Buffer_Ptr, Big_String_Ptr);
-
----------------------
-- Local Procedures --
----------------------
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;
-- --
------------------------------------------------------------------------------
-pragma Ada_2005;
--- Explicit setting of Ada 2005 mode is required here, since we want to with a
+pragma Ada_2012;
+-- Explicit setting of Ada 2012 mode is required here, since we want to with a
-- child unit (not possible in Ada 83 mode), and IO_Exceptions is not
-- considered to be an internal unit that is automatically compiled in Ada
--- 2005 mode (since a user is allowed to redeclare IO_Exceptions).
+-- 2012 mode (since a user is allowed to redeclare IO_Exceptions).
with Ada.IO_Exceptions;
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;
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;
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 --
--------------------------
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);
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));
----------------
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);
-- --
-- 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- --
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
-- 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
-- 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;
-------------------
-- 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
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-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- --
-- in another directory.
--
-- If specified, On_New_Tree_Loaded is called after each aggregated project
- -- has been processed succesfully.
+ -- has been processed successfully.
procedure Process_Project_And_Apply_Config
(Main_Project : out Prj.Project_Id;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
-- encapsulated library dependencies.
--
-- If specified, On_New_Tree_Loaded is called after each aggregated project
- -- has been processed succesfully.
+ -- has been processed successfully.
function Get_Attribute_Index
(Tree : Project_Node_Tree_Ref;
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-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- --
package body System.Storage_Pools.Subpools is
Finalize_Address_Table_In_Use : Boolean := False;
- -- This flag should be set only when a successfull allocation on a subpool
+ -- This flag should be set only when a successful allocation on a subpool
-- has been performed and the associated Finalize_Address has been added to
-- the hash table in System.Finalization_Masters.
-- --
-- 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- --
begin
Attr := N;
- -- Set the type of the attribute now to ensure the successfull
+ -- Set the type of the attribute now to ensure the successful
-- continuation of analysis even if the attribute is misplaced.
Set_Etype (Attr, P_Type);
-- --
-- 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- --
is
Pref_Typ : constant Entity_Id := Etype (Prefix);
+ function Expr_Matches_In_Formal
+ (Subp : Entity_Id;
+ Par : Node_Id) return Boolean;
+ -- Find formal corresponding to given indexed component that is an
+ -- actual in a call. Note that the enclosing subprogram call has not
+ -- beenanalyzed yet, and the parameter list is not normalized, so
+ -- that if the argument is a parameter association we must match it
+ -- by name and not by position.
+
function Constant_Indexing_OK return Boolean;
-- Constant_Indexing is legal if there is no Variable_Indexing defined
-- for the type, or else node not a target of assignment, or an actual
-- interpretations. Flag Is_Constant should be set when the context is
-- constant indexing.
+ -----------------------------
+ -- Expr_Matches_In_Formal --
+ -----------------------------
+
+ function Expr_Matches_In_Formal
+ (Subp : Entity_Id;
+ Par : Node_Id) return Boolean
+ is
+ Actual : Node_Id;
+ Formal : Node_Id;
+
+ begin
+ Formal := First_Formal (Subp);
+ Actual := First (Parameter_Associations ((Parent (Par))));
+
+ if Nkind (Par) /= N_Parameter_Association then
+
+ -- Match by position.
+
+ while Present (Actual) and then Present (Formal) loop
+ exit when Actual = Par;
+ Next (Actual);
+
+ if Present (Formal) then
+ Next_Formal (Formal);
+
+ -- Otherwise this is a parameter mismatch, the error is
+ -- reported elsewhere, or else variable indexing is implied.
+
+ else
+ return False;
+ end if;
+ end loop;
+
+ else
+ -- Match by name
+
+ while Present (Formal) loop
+ exit when Chars (Formal) = Chars (Selector_Name (Par));
+ Next_Formal (Formal);
+
+ if No (Formal) then
+ return False;
+ end if;
+ end loop;
+ end if;
+
+ return Present (Formal) and then Ekind (Formal) = E_In_Parameter;
+ end Expr_Matches_In_Formal;
+
--------------------------
-- Constant_Indexing_OK --
--------------------------
and then Is_Entity_Name (Name (Parent (Par)))
then
declare
- Actual : Node_Id;
- Formal : Entity_Id;
Proc : Entity_Id;
begin
if Is_Overloaded (Name (Parent (Par))) then
declare
Proc : constant Node_Id := Name (Parent (Par));
- A : Node_Id;
- F : Entity_Id;
I : Interp_Index;
It : Interp;
begin
Get_First_Interp (Proc, I, It);
while Present (It.Nam) loop
- F := First_Formal (It.Nam);
- A := First (Parameter_Associations (Parent (Par)));
-
- while Present (F) and then Present (A) loop
- if A = Par then
- if Ekind (F) /= E_In_Parameter then
- return False;
- else
- exit; -- interpretation is safe
- end if;
- end if;
-
- Next_Formal (F);
- Next_Actual (A);
- end loop;
+ if not Expr_Matches_In_Formal (It.Nam, Par) then
+ return False;
+ end if;
Get_Next_Interp (I, It);
end loop;
end;
+ -- All interpretations have a matching in-formal.
+
return True;
else
end if;
end if;
- Formal := First_Formal (Proc);
- Actual := First_Actual (Parent (Par));
-
- -- Find corresponding actual
-
- while Present (Actual) loop
- exit when Actual = Par;
- Next_Actual (Actual);
-
- if Present (Formal) then
- Next_Formal (Formal);
-
- -- Otherwise this is a parameter mismatch, the error is
- -- reported elsewhere.
-
- else
- return False;
- end if;
- end loop;
-
- return Ekind (Formal) = E_In_Parameter;
+ return Expr_Matches_In_Formal (Proc, Par);
end;
elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
-- Now set Ada 83 mode
- if not Latest_Ada_Only then
+ if Latest_Ada_Only then
+ Error_Pragma ("??pragma% ignored");
+ else
Ada_Version := Ada_83;
Ada_Version_Explicit := Ada_83;
Ada_Version_Pragma := N;
-- Now set Ada 95 mode
- if not Latest_Ada_Only then
+ if Latest_Ada_Only then
+ Error_Pragma ("??pragma% ignored");
+ else
Ada_Version := Ada_95;
Ada_Version_Explicit := Ada_95;
Ada_Version_Pragma := N;
-- Now set appropriate Ada mode
- if not Latest_Ada_Only then
+ if Latest_Ada_Only then
+ Error_Pragma ("??pragma% ignored");
+ else
Ada_Version := Ada_2005;
Ada_Version_Explicit := Ada_2005;
Ada_Version_Pragma := N;
procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
procedure Set_Public_Status_Of (Id : Entity_Id);
-- Set the Is_Public attribute of arbitrary entity Id by calling routine
- -- Set_Public_Status. If successfull and Id denotes a record type, set
+ -- Set_Public_Status. If successful and Id denotes a record type, set
-- the Is_Public attribute of its fields.
--------------------------
-- --
------------------------------------------------------------------------------
-pragma Ada_2005;
--- Explicit setting of Ada 2005 mode is required here, since we want to with a
+pragma Ada_2012;
+-- Explicit setting of Ada 2012 mode is required here, since we want to with a
-- child unit (not possible in Ada 83 mode), and Sequential_IO is not
-- considered to be an internal unit that is automatically compiled in Ada
--- 2005 mode (since a user is allowed to redeclare Sequential_IO).
+-- 2012 mode (since a user is allowed to redeclare Sequential_IO).
with Ada.Sequential_IO;
-- --
-- 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- --
-- 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);
-- --
-- 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- --
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.
-- 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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
+with Debug; use Debug;
with Opt; use Opt;
+with Output; use Output;
with System; use System;
with Ada.Unchecked_Conversion;
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
-- 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
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;
-- --
-- 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- --
-- 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
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
+with Debug; use Debug;
with Osint; use Osint;
with Osint.C; use Osint.C;
+with Output; use Output;
package body Sinput.D is
------------------------
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;
-- 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;
-------------------------
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;
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;
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);
Inst_Spec : Node_Id;
begin
+ Snew.Index := Xnew;
Snew.Inlined_Body := Inlined_Body;
Snew.Inherited_Pragma := Inherited_Pragma;
Snew.Template := Xold;
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.
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 ");
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;
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
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;
-- Create the new source buffer
declare
- subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
- -- Physical buffer allocated
-
- 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
+ Var_Ptr : constant Source_Buffer_Ptr_Var :=
+ new Source_Buffer (Lo .. Hi);
+ -- Allocate source buffer, allowing extra character at
+ -- end for EOF.
begin
- Actual_Ptr (Lo .. Hi - 1) :=
+ Var_Ptr (Lo .. Hi - 1) :=
Prep_Buffer (1 .. Prep_Buffer_Last);
- Actual_Ptr (Hi) := EOF;
-
- -- 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.
-
- 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
- Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
+ Var_Ptr (Hi) := EOF;
+ Src := Var_Ptr.all'Access;
+ end;
- -- Record in the table the new source buffer and the
- -- new value of Hi.
+ -- 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;
+ 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.
+ -- 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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-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;
-- 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);
-----------------------------
-----------------------------
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;
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;
package body Sinput is
- use ASCII;
- -- Make control characters visible
-
- First_Time_Around : Boolean := True;
- -- This needs a comment ???
+ use ASCII, System;
-- Routines to support conversion between types Lines_Table_Ptr,
-- Logical_Lines_Table_Ptr and System.Address.
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 --
---------------------------
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 --
-----------------------
---------------------------
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;
----------------
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);
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 --
----------------
begin
-- First we must free any old source buffer pointers
- if not First_Time_Around then
- for J in Source_File.First .. Source_File.Last loop
- declare
- S : Source_File_Record renames Source_File.Table (J);
-
- type Source_Buffer_Ptr_Var is access all Big_Source_Buffer;
-
- procedure Free_Ptr is new Unchecked_Deallocation
- (Big_Source_Buffer, Source_Buffer_Ptr_Var);
- -- This works only because we're calling malloc, which keeps
- -- track of the size on its own, ignoring the size of
- -- Big_Source_Buffer, which is the wrong size.
-
- pragma Warnings (Off);
- -- This unchecked conversion is aliasing safe, since it is not
- -- used to create improperly aliased pointer values.
-
- function To_Source_Buffer_Ptr_Var is new
- Unchecked_Conversion (Address, Source_Buffer_Ptr_Var);
-
- pragma Warnings (On);
-
- Tmp1 : Source_Buffer_Ptr_Var;
+ for J in Source_File.First .. Source_File.Last loop
+ declare
+ S : Source_File_Record renames Source_File.Table (J);
+ begin
+ if S.Instance = No_Instance_Id then
+ Free_Source_Buffer (S.Source_Text);
- begin
- if S.Instance /= No_Instance_Id then
- null;
+ if S.Lines_Table /= null then
+ Memory.Free (To_Address (S.Lines_Table));
+ S.Lines_Table := null;
+ end if;
- else
- -- Free the buffer, we use Free here, because we used malloc
- -- or realloc directly to allocate the tables. That is
- -- because we were playing the big array trick.
-
- -- We have to recreate a proper pointer to the actual array
- -- from the zero origin pointer stored in the source table.
-
- Tmp1 :=
- To_Source_Buffer_Ptr_Var
- (S.Source_Text (S.Source_First)'Address);
- Free_Ptr (Tmp1);
-
- if S.Lines_Table /= null then
- Memory.Free (To_Address (S.Lines_Table));
- S.Lines_Table := null;
- end if;
-
- if S.Logical_Lines_Table /= null then
- Memory.Free (To_Address (S.Logical_Lines_Table));
- S.Logical_Lines_Table := null;
- end if;
+ if S.Logical_Lines_Table /= null then
+ Memory.Free (To_Address (S.Logical_Lines_Table));
+ S.Logical_Lines_Table := null;
end if;
- end;
- end loop;
- end if;
+
+ else
+ Free_Dope (S.Source_Text'Address);
+ S.Source_Text := null;
+ end if;
+ end;
+ end loop;
-- Read in source file table and instance table
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));
end loop;
end if;
- -- Allocate source buffer and read in the data and then set the
- -- virtual origin to point to the logical zero'th element. This
- -- address must be computed with subscript checks turned off.
+ -- Allocate source buffer and read in the data
declare
- subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
- type Text_Buffer_Ptr is access B;
- T : Text_Buffer_Ptr;
-
- pragma Suppress (All_Checks);
-
- pragma Warnings (Off);
- -- This unchecked conversion is aliasing safe, since it is
- -- never used to create improperly aliased pointer values.
+ T : constant Source_Buffer_Ptr_Var :=
+ new Source_Buffer (S.Source_First .. S.Source_Last);
+ begin
+ Tree_Read_Data (T (S.Source_First)'Address,
+ Int (S.Source_Last) - Int (S.Source_First) + 1);
+ S.Source_Text := T.all'Access;
+ end;
- function To_Source_Buffer_Ptr is new
- Unchecked_Conversion (Address, Source_Buffer_Ptr);
+ -- For the instantiation case, we do not read in any data. Instead
+ -- we share the data for the generic template entry. Since the
+ -- template always occurs first, we can safely refer to its data.
- pragma Warnings (On);
+ else
+ declare
+ ST : Source_File_Record renames
+ Source_File.Table (S.Template);
begin
- T := new B;
+ -- The lines tables are copied from the template entry
- Tree_Read_Data (T (S.Source_First)'Address,
- Int (S.Source_Last) - Int (S.Source_First) + 1);
+ S.Lines_Table := ST.Lines_Table;
+ S.Logical_Lines_Table := ST.Logical_Lines_Table;
+
+ -- The Source_Text of the instance is the same data as that
+ -- of the template, but with different bounds.
- S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
+ declare
+ Dope : constant Dope_Ptr :=
+ new Dope_Rec'(S.Source_First, S.Source_Last);
+ begin
+ S.Source_Text := ST.Source_Text;
+ Set_Dope (S.Source_Text'Address, Dope);
+ end;
end;
end if;
end;
-- 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
with Alloc;
with Casing; use Casing;
with Namet; use Namet;
+with System;
with Table;
with Types; use Types;
-- 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
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 --
-----------------------
-- 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
-- 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
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 --
-- 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;
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 --
-- 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;
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
-- 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 --
------------------
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
-- 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);
end if;
end;
- <<Rloop_Continue>>
- null;
- end loop Rloop;
+ <<Rloop_Continue>> null;
+ end loop;
-- Restrictions taking integer parameter
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.
-- 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.
-- 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.
-- 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.
-- 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;
-- 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
-- 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
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
<<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
Set_Standard_Output;
raise Unrecoverable_Error;
end if;
- end loop Line_Loop;
+ end loop;
if Fatal then
raise Unrecoverable_Error;
-- --
------------------------------------------------------------------------------
-pragma Ada_2005;
--- Explicit setting of Ada 2005 mode is required here, since we want to with a
+pragma Ada_2012;
+-- Explicit setting of Ada 2012 mode is required here, since we want to with a
-- child unit (not possible in Ada 83 mode), and Text_IO is not considered to
--- be an internal unit that is automatically compiled in Ada 2005 mode (since
+-- be an internal unit that is automatically compiled in Ada 2012 mode (since
-- a user is allowed to redeclare Text_IO).
with Ada.Text_IO;
-- 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 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.
+ 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.
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 "=";
-- 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
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;
projects / gcc.git / commitdiff