Skip to content

R
riscv-gcc-1
Commit 84a62ce8 by Arnaud Charlet
Options

[multiple changes] 

2016-10-12  Bob Duff  <duff@adacore.com>

	* xref_lib.adb: Use renamings-of-slices to ensure
	that all references to Tables are properly bounds checked (when
	checks are turned on).
	* g-dyntab.ads, g-dyntab.adb: Default-initialize the array
	components, so we don't get uninitialized pointers in case
	of Tables containing access types.  Misc cleanup of the code
	and comments.

2016-10-12  Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Analyze_Attribute, case 'Type_Key): Implement
	functionality of attribute, to provide a reasonably unique key
	for a given type and detect any changes in the semantics of the
	type or any of its subcomponents from version to version.

2016-10-12  Bob Duff  <duff@adacore.com>

	* sem_case.adb (Check_Choice_Set): Separate
	checking for duplicates out into a separate pass from checking
	full coverage, because the check for duplicates does not depend
	on predicates. Therefore, we shouldn't do it separately for the
	predicate vs. no-predicate case; we should share code. The code
	for the predicate case was wrong.

From-SVN: r241039
parent 6e832327
Showing with 278 additions and 103 deletions
gcc/ada/ChangeLog
2016-10-12 Bob Duff <duff@adacore.com>
* xref_lib.adb: Use renamings-of-slices to ensure
that all references to Tables are properly bounds checked (when
checks are turned on).
* g-dyntab.ads, g-dyntab.adb: Default-initialize the array
components, so we don't get uninitialized pointers in case
of Tables containing access types. Misc cleanup of the code
and comments.
2016-10-12 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb (Analyze_Attribute, case 'Type_Key): Implement
functionality of attribute, to provide a reasonably unique key
for a given type and detect any changes in the semantics of the
type or any of its subcomponents from version to version.
2016-10-12 Bob Duff <duff@adacore.com>
* sem_case.adb (Check_Choice_Set): Separate
checking for duplicates out into a separate pass from checking
full coverage, because the check for duplicates does not depend
on predicates. Therefore, we shouldn't do it separately for the
predicate vs. no-predicate case; we should share code. The code
for the predicate case was wrong.
2016-10-12 Jerome Lambourg <lambourg@adacore.com>
* init.c: Make sure to call finit on x86_64-vx7 to reinitialize
......
gcc/ada/sem_attr.adb
......@@ -68,6 +68,7 @@ with Stand; use Stand;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with System;
with System.CRC32; use System.CRC32;
with Stringt; use Stringt;
with Style;
with Stylesw; use Stylesw;
......@@ -6139,37 +6140,142 @@ package body Sem_Attr is
Check_E0;
Check_Type;
-- This processing belongs in Eval_Attribute ???
declare
function Type_Key return String_Id;
-- A very preliminary implementation. For now, a signature
-- consists of only the type name. This is clearly incomplete
-- (e.g., adding a new field to a record type should change the
-- type's Type_Key attribute).
Full_Name : constant String_Id :=
Fully_Qualified_Name_String (Entity (P));
Deref : Boolean;
-- To simplify the handling of mutually recursive types, follow
-- a single dereference link in a composite type.
CRC : CRC32;
-- The computed signature for the type.
procedure Compute_Type_Key (T : Entity_Id);
-- Create a CRC integer from the declaration of the type, For
-- a composite type, fold in the representation of its components
-- in recursive fashion. We use directly the source representation
-- of the types involved.
--------------
-- Type_Key --
--------------
function Type_Key return String_Id is
Full_Name : constant String_Id :=
Fully_Qualified_Name_String (Entity (P));
procedure Compute_Type_Key (T : Entity_Id) is
SFI : Source_File_Index;
Buffer : Source_Buffer_Ptr;
P_Min, P_Max : Source_Ptr;
Rep : Node_Id;
begin
-- Copy all characters in Full_Name but the trailing NUL
procedure Process_One_Declaration;
-- Update CRC with the characters of one type declaration,
-- or a representation pragma that applies to the type.
Start_String;
for J in 1 .. String_Length (Full_Name) - 1 loop
Store_String_Char (Get_String_Char (Full_Name, Pos (J)));
end loop;
-----------------------------
-- Process_One_Declaration --
-----------------------------
procedure Process_One_Declaration is
Ptr : Source_Ptr;
begin
Ptr := P_Min;
-- Scan type declaration, skipping blanks,
while Ptr <= P_Max loop
if Buffer (Ptr) /= ' ' then
System.CRC32.Update (CRC, Buffer (Ptr));
end if;
Ptr := Ptr + 1;
end loop;
end Process_One_Declaration;
begin -- Start of processing for Compute_Type_Key
if Is_Itype (T) then
return;
end if;
Sloc_Range (Enclosing_Declaration (T), P_Min, P_Max);
SFI := Get_Source_File_Index (P_Min);
Buffer := Source_Text (SFI);
Process_One_Declaration;
-- Recurse on relevant component types.
if Is_Array_Type (T) then
Compute_Type_Key (Component_Type (T));
elsif Is_Access_Type (T) then
if not Deref then
Deref := True;
Compute_Type_Key (Designated_Type (T));
end if;
Store_String_Chars ("'Type_Key");
return End_String;
end Type_Key;
elsif Is_Derived_Type (T) then
Compute_Type_Key (Etype (T));
elsif Is_Record_Type (T) then
declare
Comp : Entity_Id;
begin
Comp := First_Component (T);
while Present (Comp) loop
Compute_Type_Key (Etype (Comp));
Next_Component (Comp);
end loop;
end;
end if;
-- Fold in representation aspects for the type, which
-- appear in the same source buffer.
Rep := First_Rep_Item (T);
while Present (Rep) loop
if Comes_From_Source (Rep) then
Sloc_Range (Rep, P_Min, P_Max);
Process_One_Declaration;
end if;
Rep := Next_Rep_Item (Rep);
end loop;
end Compute_Type_Key;
begin
Rewrite (N, Make_String_Literal (Loc, Type_Key));
Start_String;
Deref := False;
-- Copy all characters in Full_Name but the trailing NUL
for J in 1 .. String_Length (Full_Name) - 1 loop
Store_String_Char (Get_String_Char (Full_Name, Pos (J)));
end loop;
-- For standard type return the name of the type. as there is
-- no explicit source declaration to use. Otherwise compute
-- CRC and convert it to string one character at a time. so as
-- not to use Image within the compiler.
if Scope (Entity (P)) /= Standard_Standard then
Initialize (CRC);
Compute_Type_Key (Entity (P));
if not Is_Frozen (Entity (P)) then
Error_Msg_N ("premature usage of Type_Key?", N);
end if;
while CRC > 0 loop
Store_String_Char (Character'Val (48 + (CRC rem 10)));
CRC := CRC / 10;
end loop;
end if;
Rewrite (N, Make_String_Literal (Loc, End_String));
end;
Analyze_And_Resolve (N, Standard_String);
......
gcc/ada/sem_case.adb
......@@ -114,10 +114,12 @@ package body Sem_Case is
Others_Present : Boolean;
Case_Node : Node_Id)
is
Predicate_Error : Boolean;
Predicate_Error : Boolean := False;
-- Flag to prevent cascaded errors when a static predicate is known to
-- be violated by one choice.
Num_Choices : constant Nat := Choice_Table'Last;
procedure Check_Against_Predicate
(Pred : in out Node_Id;
Choice : Choice_Bounds;
......@@ -130,6 +132,10 @@ package body Sem_Case is
-- choice that covered a predicate set. Error denotes whether the check
-- found an illegal intersection.
procedure Check_Duplicates;
-- Check for duplicate choices, and call Dup_Choice is there are any
-- such errors. Note that predicates are irrelevant here.
procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id);
-- Post message "duplication of choice value(s) bla bla at xx". Message
-- is posted at location C. Caller sets Error_Msg_Sloc for xx.
......@@ -236,8 +242,7 @@ package body Sem_Case is
Val : Uint) return Boolean
is
begin
return
Val = Lo or else Val = Hi or else (Lo < Val and then Val < Hi);
return Lo <= Val and then Val <= Hi;
end Inside_Range;
-- Local variables
......@@ -276,14 +281,12 @@ package body Sem_Case is
return;
end if;
-- Step 1: Detect duplicate choices
if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then
Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN);
Error := True;
-- Step 1: Ignore duplicate choices, other than to set the flag,
-- because these were already detected by Check_Duplicates.
elsif Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) then
Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN);
if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo)
or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi)
then
Error := True;
-- Step 2: Detect full coverage
......@@ -447,6 +450,59 @@ package body Sem_Case is
end if;
end Check_Against_Predicate;
----------------------
-- Check_Duplicates --
----------------------
procedure Check_Duplicates is
Prev_Hi : Uint := Expr_Value (Choice_Table (1).Hi);
begin
for Outer_Index in 2 .. Num_Choices loop
declare
Choice_Lo : constant Uint :=
Expr_Value (Choice_Table (Outer_Index).Lo);
Choice_Hi : constant Uint :=
Expr_Value (Choice_Table (Outer_Index).Hi);
begin
if Choice_Lo <= Prev_Hi then
-- Choices overlap; this is an error
declare
Choice : constant Node_Id :=
Choice_Table (Outer_Index).Node;
Prev_Choice : Node_Id;
begin
-- Find first previous choice that overlaps
for Inner_Index in 1 .. Outer_Index - 1 loop
if Choice_Lo <=
Expr_Value (Choice_Table (Inner_Index).Hi)
then
Prev_Choice := Choice_Table (Inner_Index).Node;
exit;
end if;
end loop;
if Sloc (Prev_Choice) <= Sloc (Choice) then
Error_Msg_Sloc := Sloc (Prev_Choice);
Dup_Choice
(Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
else
Error_Msg_Sloc := Sloc (Choice);
Dup_Choice
(Choice_Lo, UI_Min (Choice_Hi, Prev_Hi),
Prev_Choice);
end if;
end;
end if;
if Choice_Hi > Prev_Hi then
Prev_Hi := Choice_Hi;
end if;
end;
end loop;
end Check_Duplicates;
----------------
-- Dup_Choice --
----------------
......@@ -709,17 +765,13 @@ package body Sem_Case is
Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
Num_Choices : constant Nat := Choice_Table'Last;
Has_Predicate : constant Boolean :=
Is_OK_Static_Subtype (Bounds_Type)
and then Has_Static_Predicate (Bounds_Type);
Choice : Node_Id;
Choice_Hi : Uint;
Choice_Lo : Uint;
Error : Boolean;
Pred : Node_Id;
Prev_Choice : Node_Id;
Prev_Lo : Uint;
Prev_Hi : Uint;
......@@ -735,8 +787,6 @@ package body Sem_Case is
return;
end if;
Predicate_Error := False;
-- Choice_Table must start at 0 which is an unused location used by the
-- sorting algorithm. However the first valid position for a discrete
-- choice is 1.
......@@ -756,16 +806,22 @@ package body Sem_Case is
Sorting.Sort (Positive (Choice_Table'Last));
-- The type covered by the list of choices is actually a static subtype
-- subject to a static predicate. The predicate defines subsets of legal
-- values and requires finer grained analysis.
-- First check for duplicates. This involved the choices; predicates, if
-- any, are irrelevant.
Check_Duplicates;
-- Then check for overlaps
-- If the subtype has a static predicate, the predicate defines subsets
-- of legal values and requires finer grained analysis.
-- Note that in GNAT the predicate is considered static if the predicate
-- expression is static, independently of whether the aspect mentions
-- Static explicitly.
if Has_Predicate then
Pred := First (Static_Discrete_Predicate (Bounds_Type));
Pred := First (Static_Discrete_Predicate (Bounds_Type));
-- Make initial value smaller than 'First of type, so that first
-- range comparison succeeds. This applies both to integer types
......@@ -774,28 +830,30 @@ package body Sem_Case is
Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1;
Prev_Hi := Prev_Lo;
Error := False;
for Index in 1 .. Num_Choices loop
Check_Against_Predicate
(Pred => Pred,
Choice => Choice_Table (Index),
Prev_Lo => Prev_Lo,
Prev_Hi => Prev_Hi,
Error => Error);
-- The analysis detected an illegal intersection between a choice
-- and a static predicate set. Do not examine other choices unless
-- all errors are requested.
if Error then
Predicate_Error := True;
if not All_Errors_Mode then
return;
declare
Error : Boolean := False;
begin
for Index in 1 .. Num_Choices loop
Check_Against_Predicate
(Pred => Pred,
Choice => Choice_Table (Index),
Prev_Lo => Prev_Lo,
Prev_Hi => Prev_Hi,
Error => Error);
-- The analysis detected an illegal intersection between a
-- choice and a static predicate set. Do not examine other
-- choices unless all errors are requested.
if Error then
Predicate_Error := True;
if not All_Errors_Mode then
return;
end if;
end if;
end if;
end loop;
end loop;
end;
if Predicate_Error then
return;
......@@ -826,35 +884,11 @@ package body Sem_Case is
end if;
end if;
for Outer_Index in 2 .. Num_Choices loop
Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo);
Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi);
if Choice_Lo <= Prev_Hi then
Choice := Choice_Table (Outer_Index).Node;
-- Find first previous choice that overlaps
for Inner_Index in 1 .. Outer_Index - 1 loop
if Choice_Lo <=
Expr_Value (Choice_Table (Inner_Index).Hi)
then
Prev_Choice := Choice_Table (Inner_Index).Node;
exit;
end if;
end loop;
if Sloc (Prev_Choice) <= Sloc (Choice) then
Error_Msg_Sloc := Sloc (Prev_Choice);
Dup_Choice
(Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
else
Error_Msg_Sloc := Sloc (Choice);
Dup_Choice
(Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice);
end if;
for Index in 2 .. Num_Choices loop
Choice_Lo := Expr_Value (Choice_Table (Index).Lo);
Choice_Hi := Expr_Value (Choice_Table (Index).Hi);
elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then
if Choice_Lo > Prev_Hi + 1 and then not Others_Present then
Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
end if;
......
gcc/ada/xref_lib.adb
......@@ -401,8 +401,9 @@ package body Xref_Lib is
(File : ALI_File;
Num : Positive) return File_Reference
is
Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
begin
return File.Dep.Table (Num);
return Table (Num);
end File_Name;
--------------------
......@@ -642,10 +643,15 @@ package body Xref_Lib is
Token := Gnatchop_Name + 1;
end if;
File.Dep.Table (Num_Dependencies) := Add_To_Xref_File
(Ali (File_Start .. File_End),
Gnatchop_File => Ali (Token .. Ptr - 1),
Gnatchop_Offset => Gnatchop_Offset);
declare
Table : Table_Type renames
File.Dep.Table (1 .. Last (File.Dep));
begin
Table (Num_Dependencies) := Add_To_Xref_File
(Ali (File_Start .. File_End),
Gnatchop_File => Ali (Token .. Ptr - 1),
Gnatchop_Offset => Gnatchop_Offset);
end;
elsif W_Lines and then Ali (Ptr) = 'W' then
......@@ -854,6 +860,8 @@ package body Xref_Lib is
Ptr := Ptr + 1;
end Skip_To_Matching_Closing_Bracket;
Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
-- Start of processing for Parse_Identifier_Info
begin
......@@ -976,9 +984,9 @@ package body Xref_Lib is
-- We don't have a unit number specified, so we set P_Eun to
-- the current unit.
for K in Dependencies_Tables.First .. Last (File.Dep) loop
for K in Table'Range loop
P_Eun := K;
exit when File.Dep.Table (K) = File_Ref;
exit when Table (K) = File_Ref;
end loop;
end if;
......@@ -1011,7 +1019,7 @@ package body Xref_Lib is
Symbol,
P_Line,
P_Column,
File.Dep.Table (P_Eun));
Table (P_Eun));
end if;
end;
end if;
......@@ -1029,7 +1037,7 @@ package body Xref_Lib is
Add_Entity
(Pattern,
Get_Symbol_Name (P_Eun, P_Line, P_Column)
& ':' & Get_Gnatchop_File (File.Dep.Table (P_Eun))
& ':' & Get_Gnatchop_File (Table (P_Eun))
& ':' & Get_Line (Get_Parent (Decl_Ref))
& ':' & Get_Column (Get_Parent (Decl_Ref)),
False);
......@@ -1080,11 +1088,10 @@ package body Xref_Lib is
if Wide_Search then
declare
File_Ref : File_Reference;
pragma Unreferenced (File_Ref);
File_Name : constant String := Get_Gnatchop_File (File.X_File);
Ignored : File_Reference;
begin
File_Ref := Add_To_Xref_File (ALI_File_Name (File_Name), False);
Ignored := Add_To_Xref_File (ALI_File_Name (File_Name), False);
end;
end if;
......@@ -1252,6 +1259,8 @@ package body Xref_Lib is
Ptr : Positive renames File.Current_Line;
File_Nr : Natural;
Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
begin
while Ali (Ptr) = 'X' loop
......@@ -1267,8 +1276,8 @@ package body Xref_Lib is
-- If the referenced file is unknown, we simply ignore it
if File_Nr in Dependencies_Tables.First .. Last (File.Dep) then
File.X_File := File.Dep.Table (File_Nr);
if File_Nr in Table'Range then
File.X_File := Table (File_Nr);
else
File.X_File := Empty_File;
end if;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment