From 84a62ce88b6b105f923130d6c55f8a01b38a43a2 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 12 Oct 2016 14:55:47 +0200 Subject: [multiple changes] 2016-10-12 Bob Duff * 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 * 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 * 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 --- gcc/ada/ChangeLog | 26 ++++ gcc/ada/g-dyntab.adb | 372 +++++++++++++++++++++++++-------------------------- gcc/ada/g-dyntab.ads | 172 ++++++++++++++---------- gcc/ada/sem_attr.adb | 146 +++++++++++++++++--- gcc/ada/sem_case.adb | 172 ++++++++++++++---------- gcc/ada/xref_lib.adb | 37 +++-- 6 files changed, 563 insertions(+), 362 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fd49a21..101ea652 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2016-10-12 Bob Duff + + * 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 + + * 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 + + * 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 * init.c: Make sure to call finit on x86_64-vx7 to reinitialize diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb index e5e41c9..a74697d 100644 --- a/gcc/ada/g-dyntab.adb +++ b/gcc/ada/g-dyntab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2014, AdaCore -- +-- Copyright (C) 2000-2016, AdaCore -- -- -- -- 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- -- @@ -32,33 +32,23 @@ pragma Compiler_Unit_Warning; with GNAT.Heap_Sort_G; -with System; use System; -with System.Memory; use System.Memory; -with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; package body GNAT.Dynamic_Tables is - Min : constant Integer := Integer (Table_Low_Bound); - -- Subscript of the minimum entry in the currently allocated table + Empty : constant Table_Ptr := + Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access); ----------------------- -- Local Subprograms -- ----------------------- - procedure Reallocate (T : in out Instance); - -- Reallocate the existing table according to the current value stored - -- in Max. Works correctly to do an initial allocation if the table - -- is currently null. - - pragma Warnings (Off); - -- These unchecked conversions are in fact safe, since they never - -- generate improperly aliased pointer values. - - function To_Address is new Ada.Unchecked_Conversion (Table_Ptr, Address); - function To_Pointer is new Ada.Unchecked_Conversion (Address, Table_Ptr); - - pragma Warnings (On); + procedure Grow (T : in out Instance; New_Last : Table_Count_Type); + -- This is called when we are about to set the value of Last to a value + -- that is larger than Last_Allocated. This reallocates the table to the + -- larger size, as indicated by New_Last. At the time this is called, + -- T.P.Last is still the old value. -------------- -- Allocate -- @@ -66,11 +56,9 @@ package body GNAT.Dynamic_Tables is procedure Allocate (T : in out Instance; Num : Integer := 1) is begin - T.P.Last_Val := T.P.Last_Val + Num; + -- Note that Num can be negative - if T.P.Last_Val > T.P.Max then - Reallocate (T); - end if; + Set_Last (T, T.P.Last + Table_Index_Type'Base (Num)); end Allocate; ------------ @@ -79,7 +67,7 @@ package body GNAT.Dynamic_Tables is procedure Append (T : in out Instance; New_Val : Table_Component_Type) is begin - Set_Item (T, Table_Index_Type (T.P.Last_Val + 1), New_Val); + Set_Item (T, T.P.Last + 1, New_Val); end Append; ---------------- @@ -99,9 +87,18 @@ package body GNAT.Dynamic_Tables is procedure Decrement_Last (T : in out Instance) is begin - T.P.Last_Val := T.P.Last_Val - 1; + Allocate (T, -1); end Decrement_Last; + ----------- + -- First -- + ----------- + + function First return Table_Index_Type is + begin + return Table_Low_Bound; + end First; + -------------- -- For_Each -- -------------- @@ -109,7 +106,7 @@ package body GNAT.Dynamic_Tables is procedure For_Each (Table : Instance) is Quit : Boolean := False; begin - for Index in Table_Low_Bound .. Table_Index_Type (Table.P.Last_Val) loop + for Index in Table_Low_Bound .. Table.P.Last loop Action (Index, Table.Table (Index), Quit); exit when Quit; end loop; @@ -120,23 +117,119 @@ package body GNAT.Dynamic_Tables is ---------- procedure Free (T : in out Instance) is + subtype Alloc_Type is Table_Type (First .. T.P.Last_Allocated); + type Alloc_Ptr is access all Alloc_Type; + + procedure Free is new Ada.Unchecked_Deallocation (Alloc_Type, Alloc_Ptr); + function To_Alloc_Ptr is + new Ada.Unchecked_Conversion (Table_Ptr, Alloc_Ptr); + + Temp : Alloc_Ptr := To_Alloc_Ptr (T.Table); + begin - Free (To_Address (T.Table)); - T.Table := null; - T.P.Length := 0; + if T.Table = Empty then + pragma Assert (T.P.Last_Allocated = First - 1); + pragma Assert (T.P.Last = First - 1); + null; + else + Free (Temp); + T.Table := Empty; + T.P.Last_Allocated := First - 1; + T.P.Last := First - 1; + end if; end Free; + ---------- + -- Grow -- + ---------- + + procedure Grow (T : in out Instance; New_Last : Table_Count_Type) is + + -- Note: Type Alloc_Ptr below needs to be declared locally so we know + -- the bounds. That means that the collection is local, so is finalized + -- when leaving Grow. That's why this package doesn't support controlled + -- types; the table elements would be finalized prematurely. An Ada + -- implementation would also be within its rights to reclaim the + -- storage. Fortunately, GNAT doesn't do that. + + pragma Assert (not T.Locked); + pragma Assert (New_Last > T.P.Last_Allocated); + + subtype Table_Length_Type is Table_Index_Type'Base + range 0 .. Table_Index_Type'Base'Last; + + Old_Last_Allocated : constant Table_Count_Type := T.P.Last_Allocated; + Old_Allocated_Length : constant Table_Length_Type := + Old_Last_Allocated - First + 1; + + New_Length : constant Table_Length_Type := New_Last - First + 1; + New_Allocated_Length : Table_Length_Type; + + begin + if T.Table = Empty then + New_Allocated_Length := Table_Length_Type (Table_Initial); + else + New_Allocated_Length := + Table_Length_Type + (Long_Long_Integer (Old_Allocated_Length) * + (100 + Long_Long_Integer (Table_Increment)) / 100); + end if; + + -- Make sure it really did grow + + if New_Allocated_Length <= Old_Allocated_Length then + New_Allocated_Length := Old_Allocated_Length + 10; + end if; + + if New_Allocated_Length <= New_Length then + New_Allocated_Length := New_Length + 10; + end if; + + pragma Assert (New_Allocated_Length > Old_Allocated_Length); + pragma Assert (New_Allocated_Length > New_Length); + + T.P.Last_Allocated := First + New_Allocated_Length - 1; + + declare + subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated); + type Old_Alloc_Ptr is access all Old_Alloc_Type; + + procedure Free is + new Ada.Unchecked_Deallocation (Old_Alloc_Type, Old_Alloc_Ptr); + function To_Old_Alloc_Ptr is + new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr); + + subtype Alloc_Type is + Table_Type (First .. First + New_Allocated_Length - 1); + type Alloc_Ptr is access all Alloc_Type; + + function To_Table_Ptr is + new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr); + + Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table); + New_Table : constant Alloc_Ptr := new Alloc_Type; + + begin + if T.Table /= Empty then + New_Table (First .. T.P.Last) := Old_Table (First .. T.P.Last); + Free (Old_Table); + end if; + + T.Table := To_Table_Ptr (New_Table); + end; + + pragma Assert (New_Last <= T.P.Last_Allocated); + pragma Assert (T.Table /= null); + pragma Assert (T.Table /= Empty); + end Grow; + -------------------- -- Increment_Last -- -------------------- procedure Increment_Last (T : in out Instance) is begin - T.P.Last_Val := T.P.Last_Val + 1; - - if T.P.Last_Val > T.P.Max then - Reallocate (T); - end if; + Allocate (T, 1); end Increment_Last; ---------- @@ -144,100 +237,57 @@ package body GNAT.Dynamic_Tables is ---------- procedure Init (T : in out Instance) is - Old_Length : constant Integer := T.P.Length; - begin - T.P.Last_Val := Min - 1; - T.P.Max := Min + Table_Initial - 1; - T.P.Length := T.P.Max - Min + 1; - - -- If table is same size as before (happens when table is never - -- expanded which is a common case), then simply reuse it. Note - -- that this also means that an explicit Init call right after - -- the implicit one in the package body is harmless. - - if Old_Length = T.P.Length then - return; - - -- Otherwise we can use Reallocate to get a table of the right size. - -- Note that Reallocate works fine to allocate a table of the right - -- initial size when it is first allocated. - - else - Reallocate (T); - end if; + Free (T); end Init; ---------- -- Last -- ---------- - function Last (T : Instance) return Table_Index_Type is + function Last (T : Instance) return Table_Count_Type is begin - return Table_Index_Type (T.P.Last_Val); + return T.P.Last; end Last; - ---------------- - -- Reallocate -- - ---------------- - - procedure Reallocate (T : in out Instance) is - New_Length : Integer; - New_Size : size_t; + ------------- + -- Release -- + ------------- + procedure Release (T : in out Instance) is + pragma Assert (not T.Locked); + Old_Last_Allocated : constant Table_Count_Type := T.P.Last_Allocated; begin - if T.P.Max < T.P.Last_Val then - - -- Now increment table length until it is sufficiently large. Use - -- the increment value or 10, which ever is larger (the reason - -- for the use of 10 here is to ensure that the table does really - -- increase in size (which would not be the case for a table of - -- length 10 increased by 3% for instance). Do the intermediate - -- calculation in Long_Long_Integer to avoid overflow. - - while T.P.Max < T.P.Last_Val loop - New_Length := - Integer - (Long_Long_Integer (T.P.Length) * - (100 + Long_Long_Integer (Table_Increment)) / 100); - - if New_Length > T.P.Length then - T.P.Length := New_Length; - else - T.P.Length := T.P.Length + 10; - end if; - - T.P.Max := Min + T.P.Length - 1; - end loop; - end if; + if T.P.Last /= T.P.Last_Allocated then + pragma Assert (T.P.Last < T.P.Last_Allocated); + pragma Assert (T.Table /= Empty); - New_Size := - size_t ((T.P.Max - Min + 1) * - (Table_Type'Component_Size / Storage_Unit)); + declare + subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated); + type Old_Alloc_Ptr is access all Old_Alloc_Type; - if T.Table = null then - T.Table := To_Pointer (Alloc (New_Size)); + procedure Free is + new Ada.Unchecked_Deallocation (Old_Alloc_Type, Old_Alloc_Ptr); + function To_Old_Alloc_Ptr is + new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr); - elsif New_Size > 0 then - T.Table := - To_Pointer (Realloc (Ptr => To_Address (T.Table), - Size => New_Size)); - end if; + subtype Alloc_Type is + Table_Type (First .. First + T.P.Last - 1); + type Alloc_Ptr is access all Alloc_Type; - if T.P.Length /= 0 and then T.Table = null then - raise Storage_Error; - end if; - end Reallocate; + function To_Table_Ptr is + new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr); - ------------- - -- Release -- - ------------- + Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table); + New_Table : constant Alloc_Ptr := new Alloc_Type'(Old_Table.all); + begin + T.P.Last_Allocated := T.P.Last; + Free (Old_Table); + T.Table := To_Table_Ptr (New_Table); + end; + end if; - procedure Release (T : in out Instance) is - begin - T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1; - T.P.Max := T.P.Last_Val; - Reallocate (T); + pragma Assert (T.P.Last = T.P.Last_Allocated); end Release; -------------- @@ -245,60 +295,18 @@ package body GNAT.Dynamic_Tables is -------------- procedure Set_Item - (T : in out Instance; - Index : Table_Index_Type; - Item : Table_Component_Type) + (T : in out Instance; + Index : Valid_Table_Index_Type; + Item : Table_Component_Type) is - -- If Item is a value within the current allocation, and we are going to - -- reallocate, then we must preserve an intermediate copy here before - -- calling Increment_Last. Otherwise, if Table_Component_Type is passed - -- by reference, we are going to end up copying from storage that might - -- have been deallocated from Increment_Last calling Reallocate. - - subtype Allocated_Table_T is - Table_Type (T.Table'First .. Table_Index_Type (T.P.Max + 1)); - -- A constrained table subtype one element larger than the currently - -- allocated table. - - Allocated_Table_Address : constant System.Address := - T.Table.all'Address; - -- Used for address clause below (we can't use non-static expression - -- Table.all'Address directly in the clause because some older versions - -- of the compiler do not allow it). - - Allocated_Table : Allocated_Table_T; - pragma Import (Ada, Allocated_Table); - pragma Suppress (Range_Check, On => Allocated_Table); - for Allocated_Table'Address use Allocated_Table_Address; - -- Allocated_Table represents the currently allocated array, plus one - -- element (the supplementary element is used to have a convenient way - -- to the address just past the end of the current allocation). Range - -- checks are suppressed because this unit uses direct calls to - -- System.Memory for allocation, and this can yield misaligned storage - -- (and we cannot rely on the bootstrap compiler supporting specifically - -- disabling alignment checks, so we need to suppress all range checks). - -- It is safe to suppress this check here because we know that a - -- (possibly misaligned) object of that type does actually exist at that - -- address. - -- ??? We should really improve the allocation circuitry here to - -- guarantee proper alignment. - - Need_Realloc : constant Boolean := Integer (Index) > T.P.Max; - -- True if this operation requires storage reallocation (which may - -- involve moving table contents around). - + Item_Copy : constant Table_Component_Type := Item; begin - -- If we're going to reallocate, check whether Item references an - -- element of the currently allocated table. - - if Need_Realloc - and then Allocated_Table'Address <= Item'Address - and then Item'Address < - Allocated_Table (Table_Index_Type (T.P.Max + 1))'Address - then - -- If so, save a copy on the stack because Increment_Last will - -- reallocate storage and might deallocate the current table. + -- If Set_Last is going to reallocate the table, we make a copy of Item, + -- in case the call was "Set_Item (T, X, T.Table (Y));", and Item is + -- passed by reference. Without the copy, we would deallocate the array + -- containing Item, leaving a dangling pointer. + if Index > T.P.Last_Allocated then declare Item_Copy : constant Table_Component_Type := Item; begin @@ -306,34 +314,28 @@ package body GNAT.Dynamic_Tables is T.Table (Index) := Item_Copy; end; - else - -- Here we know that either we won't reallocate (case of Index < Max) - -- or that Item is not in the currently allocated table. - - if Integer (Index) > T.P.Last_Val then - Set_Last (T, Index); - end if; + return; + end if; - T.Table (Index) := Item; + if Index > T.P.Last then + Set_Last (T, Index); end if; + + T.Table (Index) := Item_Copy; end Set_Item; -------------- -- Set_Last -- -------------- - procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is + procedure Set_Last (T : in out Instance; New_Val : Table_Count_Type) is + pragma Assert (not T.Locked); begin - if Integer (New_Val) < T.P.Last_Val then - T.P.Last_Val := Integer (New_Val); - - else - T.P.Last_Val := Integer (New_Val); - - if T.P.Last_Val > T.P.Max then - Reallocate (T); - end if; + if New_Val > T.P.Last_Allocated then + Grow (T, New_Val); end if; + + T.P.Last := New_Val; end Set_Last; ---------------- @@ -341,13 +343,12 @@ package body GNAT.Dynamic_Tables is ---------------- procedure Sort_Table (Table : in out Instance) is - Temp : Table_Component_Type; -- A temporary position to simulate index 0 -- Local subprograms - function Index_Of (Idx : Natural) return Table_Index_Type; + function Index_Of (Idx : Natural) return Table_Index_Type'Base; -- Return index of Idx'th element of table function Lower_Than (Op1, Op2 : Natural) return Boolean; @@ -362,11 +363,11 @@ package body GNAT.Dynamic_Tables is -- Index_Of -- -------------- - function Index_Of (Idx : Natural) return Table_Index_Type is + function Index_Of (Idx : Natural) return Table_Index_Type'Base is J : constant Integer'Base := - Table_Index_Type'Pos (First) + Idx - 1; + Table_Index_Type'Base'Pos (First) + Idx - 1; begin - return Table_Index_Type'Val (J); + return Table_Index_Type'Base'Val (J); end Index_Of; ---------- @@ -401,8 +402,7 @@ package body GNAT.Dynamic_Tables is else return - Lt (Table.Table (Index_Of (Op1)), - Table.Table (Index_Of (Op2))); + Lt (Table.Table (Index_Of (Op1)), Table.Table (Index_Of (Op2))); end if; end Lower_Than; diff --git a/gcc/ada/g-dyntab.ads b/gcc/ada/g-dyntab.ads index 59d9932..eb71815 100644 --- a/gcc/ada/g-dyntab.ads +++ b/gcc/ada/g-dyntab.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2015, AdaCore -- +-- Copyright (C) 2000-2016, AdaCore -- -- -- -- 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- -- @@ -41,40 +41,49 @@ -- instances of the table, while an instantiation of GNAT.Table creates a -- single instance of the table type. --- Note that this interface should remain synchronized with those in --- GNAT.Table and the GNAT compiler source unit Table to keep as much --- coherency as possible between these three related units. +-- Note that these three interfaces should remain synchronized to keep as much +-- coherency as possible among these three related units: +-- +-- GNAT.Dynamic_Tables +-- GNAT.Table +-- Table (the compiler unit) pragma Compiler_Unit_Warning; +with Ada.Unchecked_Conversion; + generic type Table_Component_Type is private; type Table_Index_Type is range <>; Table_Low_Bound : Table_Index_Type; - Table_Initial : Positive; - Table_Increment : Natural; + Table_Initial : Positive := 8; + Table_Increment : Natural := 100; package GNAT.Dynamic_Tables is - -- Table_Component_Type and Table_Index_Type specify the type of the - -- array, Table_Low_Bound is the lower bound. Table_Index_Type must be an - -- integer type. The effect is roughly to declare: + -- Table_Component_Type and Table_Index_Type specify the type of the array, + -- Table_Low_Bound is the lower bound. The effect is roughly to declare: -- Table : array (Table_Low_Bound .. <>) of Table_Component_Type; - -- Note: since the upper bound can be one less than the lower - -- bound for an empty array, the table index type must be able - -- to cover this range, e.g. if the lower bound is 1, then the - -- Table_Index_Type should be Natural rather than Positive. + -- The lower bound of Table_Index_Type is ignored. + + pragma Assert (Table_Low_Bound /= Table_Index_Type'Base'First); + + function First return Table_Index_Type; + pragma Inline (First); + -- Export First as synonym for Table_Low_Bound (parallel with use of Last) - -- Table_Component_Type may be any Ada type, except that controlled - -- types are not supported. Note however that default initialization - -- will NOT occur for array components. + subtype Valid_Table_Index_Type is Table_Index_Type'Base + range Table_Low_Bound .. Table_Index_Type'Base'Last; + subtype Table_Count_Type is Table_Index_Type'Base + range Table_Low_Bound - 1 .. Table_Index_Type'Base'Last; - -- The Table_Initial values controls the allocation of the table when - -- it is first allocated, either by default, or by an explicit Init - -- call. + -- Table_Component_Type must not be a type with controlled parts. + + -- The Table_Initial value controls the allocation of the table when + -- it is first allocated. -- The Table_Increment value controls the amount of increase, if the -- table has to be increased in size. The value given is a percentage @@ -90,97 +99,114 @@ package GNAT.Dynamic_Tables is -- to take the access of a table element, use Unrestricted_Access. type Table_Type is - array (Table_Index_Type range <>) of Table_Component_Type; + array (Valid_Table_Index_Type range <>) of Table_Component_Type; subtype Big_Table_Type is - Table_Type (Table_Low_Bound .. Table_Index_Type'Last); + Table_Type (Table_Low_Bound .. Valid_Table_Index_Type'Last); -- We work with pointers to a bogus array type that is constrained with -- the maximum possible range bound. This means that the pointer is a thin -- pointer, which is more efficient. Since subscript checks in any case -- must be on the logical, rather than physical bounds, safety is not - -- compromised by this approach. These types should not be used by the - -- client. + -- compromised by this approach. + + -- To get subscript checking, rename a slice of the Table, like this: + + -- Table : Table_Type renames T.Table (First .. Last (T)); + + -- and the refer to components of Table. type Table_Ptr is access all Big_Table_Type; for Table_Ptr'Storage_Size use 0; - -- The table is actually represented as a pointer to allow reallocation. - -- This type should not be used by the client. + -- The table is actually represented as a pointer to allow reallocation type Table_Private is private; -- Table private data that is not exported in Instance + -- Private use only: + subtype Empty_Table_Array_Type is + Table_Type (Table_Low_Bound .. Table_Low_Bound - 1); + type Empty_Table_Array_Ptr is access all Empty_Table_Array_Type; + Empty_Table_Array : aliased Empty_Table_Array_Type; + function Empty_Table_Array_Ptr_To_Table_Ptr is + new Ada.Unchecked_Conversion (Empty_Table_Array_Ptr, Table_Ptr); + -- End private use only. The above are used to initialize Table to point to + -- an empty array. + type Instance is record - Table : aliased Table_Ptr := null; - -- The table itself. The lower bound is the value of Low_Bound. - -- Logically the upper bound is the current value of Last (although - -- the actual size of the allocated table may be larger than this). - -- The program may only access and modify Table entries in the - -- range First .. Last. + Table : aliased Table_Ptr := + Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access); + -- The table itself. The lower bound is the value of First. Logically + -- the upper bound is the current value of Last (although the actual + -- size of the allocated table may be larger than this). The program may + -- only access and modify Table entries in the range First .. Last. + -- + -- It's a good idea to access this via a renaming of a slice, in order + -- to ensure bounds checking, as in: + -- + -- Tab : Table_Type renames X.Table (First .. X.Last); + + Locked : Boolean := False; + -- Table expansion is permitted only if this switch is set to False. A + -- client may set Locked to True, in which case any attempt to expand + -- the table will cause an assertion failure. Note that while a table + -- is locked, its address in memory remains fixed and unchanging. P : Table_Private; end record; procedure Init (T : in out Instance); - -- This procedure allocates a new table of size Initial (freeing any - -- previously allocated larger table). Init must be called before using - -- the table. Init is convenient in reestablishing a table for new use. + -- Reinitializes the table to empty. There is no need to call this before + -- using a table; tables default to empty. - function Last (T : Instance) return Table_Index_Type; + function Last (T : Instance) return Table_Count_Type; pragma Inline (Last); - -- Returns the current value of the last used entry in the table, - -- which can then be used as a subscript for Table. Note that the - -- only way to modify Last is to call the Set_Last procedure. Last - -- must always be used to determine the logically last entry. + -- Returns the current value of the last used entry in the table, which can + -- then be used as a subscript for Table. procedure Release (T : in out Instance); -- Storage is allocated in chunks according to the values given in the - -- Initial and Increment parameters. A call to Release releases all - -- storage that is allocated, but is not logically part of the current + -- Table_Initial and Table_Increment parameters. A call to Release releases + -- all storage that is allocated, but is not logically part of the current -- array value. Current array values are not affected by this call. procedure Free (T : in out Instance); - -- Free all allocated memory for the table. A call to init is required - -- before any use of this table after calling Free. + -- Same as Init - First : constant Table_Index_Type := Table_Low_Bound; - -- Export First as synonym for Low_Bound (parallel with use of Last) - - procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type); + procedure Set_Last (T : in out Instance; New_Val : Table_Count_Type); pragma Inline (Set_Last); - -- This procedure sets Last to the indicated value. If necessary the - -- table is reallocated to accommodate the new value (i.e. on return - -- the allocated table has an upper bound of at least Last). If - -- Set_Last reduces the size of the table, then logically entries are - -- removed from the table. If Set_Last increases the size of the - -- table, then new entries are logically added to the table. + -- This procedure sets Last to the indicated value. If necessary the table + -- is reallocated to accommodate the new value (i.e. on return the + -- allocated table has an upper bound of at least Last). If Set_Last + -- reduces the size of the table, then logically entries are removed from + -- the table. If Set_Last increases the size of the table, then new entries + -- are logically added to the table. procedure Increment_Last (T : in out Instance); pragma Inline (Increment_Last); - -- Adds 1 to Last (same as Set_Last (Last + 1) + -- Adds 1 to Last (same as Set_Last (Last + 1)) procedure Decrement_Last (T : in out Instance); pragma Inline (Decrement_Last); - -- Subtracts 1 from Last (same as Set_Last (Last - 1) + -- Subtracts 1 from Last (same as Set_Last (Last - 1)) procedure Append (T : in out Instance; New_Val : Table_Component_Type); pragma Inline (Append); + -- Appends New_Val onto the end of the table -- Equivalent to: -- Increment_Last (T); -- T.Table (T.Last) := New_Val; - -- i.e. the table size is increased by one, and the given new item - -- stored in the newly created table element. procedure Append_All (T : in out Instance; New_Vals : Table_Type); -- Appends all components of New_Vals procedure Set_Item (T : in out Instance; - Index : Table_Index_Type; + Index : Valid_Table_Index_Type; Item : Table_Component_Type); pragma Inline (Set_Item); - -- Put Item in the table at position Index. The table is expanded if - -- current table length is less than Index and in that case Last is set to - -- Index. Item will replace any value already present in the table at this - -- position. + -- Put Item in the table at position Index. If Index points to an existing + -- item (i.e. it is in the range First .. Last (T)), the item is replaced. + -- Otherwise (i.e. Index > Last (T), the table is expanded, and Last is set + -- to Index. procedure Allocate (T : in out Instance; Num : Integer := 1); pragma Inline (Allocate); @@ -188,17 +214,17 @@ package GNAT.Dynamic_Tables is generic with procedure Action - (Index : Table_Index_Type; + (Index : Valid_Table_Index_Type; Item : Table_Component_Type; Quit : in out Boolean) is <>; procedure For_Each (Table : Instance); - -- Calls procedure Action for each component of the table Table, or until - -- one of these calls set Quit to True. + -- Calls procedure Action for each component of the table, or until one of + -- these calls set Quit to True. generic with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean; procedure Sort_Table (Table : in out Instance); - -- This procedure sorts the components of table Table into ascending + -- This procedure sorts the components of the table into ascending -- order making calls to Lt to do required comparisons, and using -- assignments to move components around. The Lt function returns True -- if Comp1 is less than Comp2 (in the sense of the desired sort), and @@ -208,16 +234,16 @@ package GNAT.Dynamic_Tables is -- in the table is not preserved). private + type Table_Private is record - Max : Integer; - -- Subscript of the maximum entry in the currently allocated table + Last_Allocated : Table_Count_Type := Table_Low_Bound - 1; + -- Subscript of the maximum entry in the currently allocated table. + -- Initial value ensures that we initially allocate the table. - Length : Integer := 0; - -- Number of entries in currently allocated table. The value of zero - -- ensures that we initially allocate the table. + Last : Table_Count_Type := Table_Low_Bound - 1; + -- Current value of Last function - Last_Val : Integer; - -- Current value of Last + -- Invariant: Last <= Last_Allocated end record; end GNAT.Dynamic_Tables; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index cd7691f..4e00e17 100644 --- a/gcc/ada/sem_attr.adb +++ b/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); diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 8df46f06..7415b0c 100644 --- a/gcc/ada/sem_case.adb +++ b/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; diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index 3f882b0..c43c575 100644 --- a/gcc/ada/xref_lib.adb +++ b/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; -- cgit v1.1