diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 74 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 42 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/g-table.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/inline.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/lib-xref.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/namet.h | 4 | ||||
| -rw-r--r-- | gcc/ada/par_sco.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/s-fatgen.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/scos.ads | 20 | ||||
| -rw-r--r-- | gcc/ada/scos.h | 28 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/spark_xrefs.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/table.adb | 369 | ||||
| -rw-r--r-- | gcc/ada/table.ads | 248 | ||||
| -rw-r--r-- | gcc/ada/treepr.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/uintp.h | 8 |
21 files changed, 827 insertions, 133 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d91c4b3..5c0b3d7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,77 @@ +2017-09-06 Yannick Moy <moy@adacore.com> + + * treepr.adb (Print_Entity_Info): Do not print empty Elist. + +2017-09-06 Yannick Moy <moy@adacore.com> + + * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Do not consider calls + to subprograms in other units as possibly inlined. + +2017-09-06 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Freeze_Entity): For a derived type that has no + explicit delayed aspects but may inherit delayed aspects from its + parent type, analyze aspect at freeze point for proper capture + of an inherited aspect. + +2017-09-06 Arnaud Charlet <charlet@adacore.com> + + * lib-xref.adb (Get_Through_Renamings): Get through subprogram + renamings; also, avoid repeated calls to Renamed_Object when getting + through object renamings. + +2017-09-06 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Array_Type_Declaration): Handle properly an + array type declaration in a private part, when an index is a + subtype indication of a discrete type with a private partial view. + +2017-09-06 Javier Miranda <miranda@adacore.com> + + * exp_ch4.adb (Expand_Modular_Op): Force generating + temporary to improve the generated code. + +2017-09-06 Tristan Gingold <gingold@adacore.com> + + * s-fatgen.adb: Minor typo fix in comment. + +2017-09-06 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Make_Field_Assign): If the type + of the right-hand side has stored constraint, use its values + (except for those that are renamings of parent discriminants) + to produce additional assignments for the discriminants of the + left-hand side, which are invisible in the righ-hand side and + not retrievable as selected components. + +2017-09-06 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Needs_One_Formal): The first formal of such a + function must be a controlling formal, so that Obj.F (X, Y) + can have the interpretation F(Obj)(X, Y). + * sem_util.ads: Clarify documentation. + +2017-09-06 Eric Botcazou <ebotcazou@adacore.com> + + * table.ads, table.adb: Restore original implementation. + * namet.h (Names_Ptr): Adjust back. + (Name_Chars_Ptr): Likewise. + * uintp.h (Uints_Ptr): Likewise. + (Udigits_Ptr): Likewise. + * g-table.ads: Remove pragma Compiler_Unit_Warning. + * par_sco.adb: Do not with GNAT.Table and use Table consistently. + * scos.ads: Replace GNAT.Table with Table and adjust instantiations. + * spark_xrefs.ads: Likewise. + * scos.h: Undo latest changes. + +2017-09-06 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Analyze_Subprogram_Instantiation): Propagate + No_Return flag to instance if pragma applies to generic unit. This + must be done explicitly because the pragma does not appear + directly in the generic declaration (unlike the corresponding + aspect specification). + 2017-09-06 Eric Botcazou <ebotcazou@adacore.com> * sem_ch7.adb (Has_Referencer): Move up and expand comment diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7f64cde..9e18ec7 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4069,6 +4069,31 @@ package body Exp_Ch4 is Set_Right_Opnd (Op_Expr, Unchecked_Convert_To (Standard_Integer, New_Copy_Tree (Right_Opnd (N)))); + + -- Link this node to the tree to analyze it + + -- If the parent node is an expression with actions we link it + -- to N since otherwise Force_Evaluation cannot identify if this + -- node comes from the Expression and rejects generating the + -- temporary. + + if Nkind (Parent (N)) = N_Expression_With_Actions then + Set_Parent (Op_Expr, N); + + -- Common case + + else + Set_Parent (Op_Expr, Parent (N)); + end if; + + Analyze (Op_Expr); + + -- Force generating a temporary because in the expansion of this + -- expression we may generate code that performs this computation + -- several times. + + Force_Evaluation (Op_Expr, Mode => Strict); + Set_Left_Opnd (Mod_Expr, Op_Expr); end if; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 59af6ab..4a89255 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1590,6 +1590,48 @@ package body Exp_Ch5 is Next_Discriminant (F); end; end loop; + + -- If the derived type has a stored constraint, assign the value + -- of the corresponding discriminants explicitly, skipping those + -- that are renamed discriminants. We cannot just retrieve them + -- from the Rhs by selected component because they are invisible + -- in the type of the right-hand side. + + if Stored_Constraint (R_Typ) /= No_Elist then + declare + Discr_Val : Elmt_Id; + Assign : Node_Id; + + begin + Discr_Val := First_Elmt (Stored_Constraint (R_Typ)); + F := First_Entity (R_Typ); + while Present (F) loop + if Ekind (F) = E_Discriminant + and then Is_Completely_Hidden (F) + and then Present (Corresponding_Record_Component (F)) + and then (not Is_Entity_Name (Node (Discr_Val)) + or else Ekind (Entity (Node (Discr_Val))) + /= E_Discriminant) + then + Assign := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Lhs), + Selector_Name => + New_Occurrence_Of + (Corresponding_Record_Component (F), Loc)), + Expression => New_Copy (Node ((Discr_Val)))); + + Set_Assignment_OK (Name (Assign)); + Insert_Action (N, Assign); + Next_Elmt (Discr_Val); + end if; + + Next_Entity (F); + end loop; + end; + end if; end if; -- We know the underlying type is a record, but its current view diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 578563a..4d8aa65 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -5266,8 +5266,12 @@ package body Freeze is -- pragma or attribute definition clause in the tree at this point. We -- also analyze the aspect specification node at the freeze point when -- the aspect doesn't correspond to pragma/attribute definition clause. + -- In addition, a derived type may have inherited aspects that were + -- delayed in the parent, so these must also be captured now. - if Has_Delayed_Aspects (E) then + if Has_Delayed_Aspects (E) + or else May_Inherit_Delayed_Rep_Aspects (E) + then Analyze_Aspects_At_Freeze_Point (E); end if; diff --git a/gcc/ada/g-table.ads b/gcc/ada/g-table.ads index ab53813..ccda39b 100644 --- a/gcc/ada/g-table.ads +++ b/gcc/ada/g-table.ads @@ -41,8 +41,6 @@ -- GNAT.Table -- Table (the compiler unit) -pragma Compiler_Unit_Warning; - with GNAT.Dynamic_Tables; generic diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 9f2539a..007d59c 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1349,6 +1349,15 @@ package body Inline is elsif In_Package_Visible_Spec (Id) then return False; + -- Do not inline subprograms declared in other units. This is important + -- in particular for subprograms defined in the private part of a + -- package spec, when analyzing one of its child packages, as otherwise + -- we issue spurious messages about the impossibility to inline such + -- calls. + + elsif not In_Extended_Main_Code_Unit (Id) then + return False; + -- Do not inline subprograms marked No_Return, possibly used for -- signaling errors, which GNATprove handles specially. diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index bcb1b6c..d40f0d4 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -413,17 +413,57 @@ package body Lib.Xref is --------------------------- function Get_Through_Renamings (E : Entity_Id) return Entity_Id is - Result : Entity_Id := E; - begin - while Present (Result) - and then Is_Object (Result) - and then Present (Renamed_Object (Result)) - loop - Result := Get_Enclosing_Object (Renamed_Object (Result)); - end loop; + case Ekind (E) is + -- For subprograms we just need to check once if they are have a + -- Renamed_Entity, because Renamed_Entity is set transitively. + + when Subprogram_Kind => + declare + Renamed : constant Entity_Id := Renamed_Entity (E); + + begin + if Present (Renamed) then + return Renamed; + else + return E; + end if; + end; + + -- For objects we need to repeatedly call Renamed_Object, because + -- it is not transitive. + + when Object_Kind => + declare + Obj : Entity_Id := E; + + begin + loop + pragma Assert (Present (Obj)); + + declare + Renamed : constant Entity_Id := Renamed_Object (Obj); + begin + if Present (Renamed) then + Obj := Get_Enclosing_Object (Renamed); + + -- The renamed expression denotes a non-object, + -- e.g. function call, slicing of a function call, + -- pointer dereference, etc. + if No (Obj) then + return Empty; + end if; + else + return Obj; + end if; + end; + end loop; + end; + + when others => + return E; - return Result; + end case; end Get_Through_Renamings; --------------- diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h index 84255a8..35068d3 100644 --- a/gcc/ada/namet.h +++ b/gcc/ada/namet.h @@ -45,11 +45,11 @@ struct Name_Entry }; /* Pointer to names table vector. */ -#define Names_Ptr namet__name_entries__tab__the_instance +#define Names_Ptr namet__name_entries__table extern struct Name_Entry *Names_Ptr; /* Pointer to name characters table. */ -#define Name_Chars_Ptr namet__name_chars__tab__the_instance +#define Name_Chars_Ptr namet__name_chars__table extern char *Name_Chars_Ptr; /* This is Hostparm.Max_Line_Length. */ diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index b3abb6d..d44b656 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -44,7 +44,6 @@ with Table; with GNAT.HTable; use GNAT.HTable; with GNAT.Heap_Sort_G; -with GNAT.Table; package body Par_SCO is @@ -76,12 +75,13 @@ package body Par_SCO is -- running some steps multiple times (the second pass has to be started -- from multiple places). - package SCO_Raw_Table is new GNAT.Table + package SCO_Raw_Table is new Table.Table (Table_Component_Type => SCO_Table_Entry, Table_Index_Type => Nat, Table_Low_Bound => 1, Table_Initial => 500, - Table_Increment => 300); + Table_Increment => 300, + Table_Name => "Raw_Table"); ----------------------- -- Unit Number Table -- diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb index c2185e0..fdb34f2 100644 --- a/gcc/ada/s-fatgen.adb +++ b/gcc/ada/s-fatgen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -726,11 +726,11 @@ package body System.Fat_Gen is -- This works provided that the intermediate result (RM1 + N) does not -- have extra precision (which is why we call Machine). When we compute -- RM1 + N, the exponent of N will be normalized and the mantissa shifted - -- shifted appropriately so the lower order bits, which cannot contribute - -- to the integer part of N, fall off on the right. When we subtract RM1 - -- again, the significant bits of N are shifted to the left, and what we - -- have is an integer, because only the first e bits are different from - -- zero (assuming binary radix here). + -- appropriately so the lower order bits, which cannot contribute to the + -- integer part of N, fall off on the right. When we subtract RM1 again, + -- the significant bits of N are shifted to the left, and what we have is + -- an integer, because only the first e bits are different from zero + -- (assuming binary radix here). function Truncation (X : T) return T is Result : T; diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 412a45b..e99ace6 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-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- -- @@ -29,10 +29,9 @@ -- is used in the ALI file. with Namet; use Namet; +with Table; with Types; use Types; -with GNAT.Table; - package SCOs is -- SCO information can exist in one of two forms. In the ALI file, it is @@ -383,12 +382,13 @@ package SCOs is -- For the SCO for a pragma/aspect, gives the pragma/apsect name end record; - package SCO_Table is new GNAT.Table ( + package SCO_Table is new Table.Table ( Table_Component_Type => SCO_Table_Entry, Table_Index_Type => Nat, Table_Low_Bound => 1, Table_Initial => 500, - Table_Increment => 300); + Table_Increment => 300, + Table_Name => "Table"); Is_Decision : constant array (Character) of Boolean := ('E' | 'G' | 'I' | 'P' | 'a' | 'A' | 'W' | 'X' => True, @@ -530,12 +530,13 @@ package SCOs is end record; - package SCO_Unit_Table is new GNAT.Table ( + package SCO_Unit_Table is new Table.Table ( Table_Component_Type => SCO_Unit_Table_Entry, Table_Index_Type => SCO_Unit_Index, Table_Low_Bound => 0, -- see note above on sorting Table_Initial => 20, - Table_Increment => 200); + Table_Increment => 200, + Table_Name => "Unit_Table"); ----------------------- -- Generic instances -- @@ -551,12 +552,13 @@ package SCOs is Enclosing_Instance : SCO_Instance_Index; end record; - package SCO_Instance_Table is new GNAT.Table ( + package SCO_Instance_Table is new Table.Table ( Table_Component_Type => SCO_Instance_Table_Entry, Table_Index_Type => SCO_Instance_Index, Table_Low_Bound => 1, Table_Initial => 20, - Table_Increment => 200); + Table_Increment => 200, + Table_Name => "Instance_Table"); ----------------- -- Subprograms -- diff --git a/gcc/ada/scos.h b/gcc/ada/scos.h index 4fb396c..bda373b 100644 --- a/gcc/ada/scos.h +++ b/gcc/ada/scos.h @@ -45,16 +45,14 @@ struct SCO_Unit_Table_Entry typedef struct SCO_Unit_Table_Entry *SCO_Unit_Table_Type; -/* The following depends on the fact that The_Instance.Table - is the first component. */ -extern SCO_Unit_Table_Type scos__sco_unit_table__the_instance; -#define SCO_Unit_Table scos__sco_unit_table__the_instance +extern SCO_Unit_Table_Type scos__sco_unit_table__table; +#define SCO_Unit_Table scos__sco_unit_table__table -extern Int scos__sco_unit_table__first(void); -#define SCO_Unit_Table_First scos__sco_unit_table__first +extern Int scos__sco_unit_table__min; +#define SCO_Unit_Table_Min scos__sco_unit_table__min -extern Int scos__sco_unit_table__last(void); -#define SCO_Unit_Table_Last scos__sco_unit_table__last +extern Int scos__sco_unit_table__last_val; +#define SCO_Unit_Table_Last_Val scos__sco_unit_table__last_val /* SCOs table: */ @@ -76,16 +74,14 @@ struct SCO_Table_Entry typedef struct SCO_Table_Entry *SCO_Table_Type; -/* The following depends on the fact that The_Instance.Table - is the first component. */ -extern SCO_Table_Type scos__sco_table__the_instance; -#define SCO_Table scos__sco_table__the_instance +extern SCO_Table_Type scos__sco_table__table; +#define SCO_Table scos__sco_table__table -extern Int scos__sco_table__first(void); -#define SCO_Table_First scos__sco_table__first +extern Int scos__sco_table__min; +#define SCO_Table_Min scos__sco_table__min -extern Int scos__sco_table__last(void); -#define SCO_Table_Last scos__sco_table__last +extern Int scos__sco_table__last_val; +#define SCO_Table_Last_Val scos__sco_table__last_val #ifdef __cplusplus } diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 2b1e1ba..acc293d 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5382,6 +5382,15 @@ package body Sem_Ch12 is Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit)); Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit)); + -- Propagate No_Return if pragma applied to generic unit. This must + -- be done explicitly because pragma does not appear in generic + -- declaration (unlike the aspect case). + + if No_Return (Gen_Unit) then + Set_No_Return (Act_Decl_Id); + Set_No_Return (Anon_Id); + end if; + Set_Has_Pragma_Inline_Always (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); Set_Has_Pragma_Inline_Always diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 7929f02..b5fb5f9 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6000,8 +6000,8 @@ package body Sem_Ch3 is Analyze (Decl); Set_Etype (Index, New_E); - -- If the index is a range the Entity attribute is not - -- available. Example: + -- If the index is a range or a subtype indication it carries + -- no entity. Example: -- package Pkg is -- type T is private; @@ -6010,7 +6010,9 @@ package body Sem_Ch3 is -- Table : array (T(1) .. T(10)) of Boolean; -- end Pkg; - if Nkind (Index) /= N_Range then + -- Otherwise the type of the reference is its entity. + + if Is_Entity_Name (Index) then Set_Entity (Index, New_E); end if; end; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a0fcc41..dde75ce 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -17050,6 +17050,7 @@ package body Sem_Util is if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) and then No (Default_Value (First_Formal (E))) + and then Is_Controlling_Formal (First_Formal (E)) then Formal := Next_Formal (First_Formal (E)); while Present (Formal) loop diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 8f0520a..8eb71d0 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2012,9 +2012,10 @@ package Sem_Util is -- entity E. If no such instance exits, return Empty. function Needs_One_Actual (E : Entity_Id) return Boolean; - -- Returns True if a function has defaults for all but its first - -- formal. Used in Ada 2005 mode to solve the syntactic ambiguity that - -- results from an indexing of a function call written in prefix form. + -- Returns True if a function has defaults for all but its first formal, + -- which is a controlling formal. Used in Ada 2005 mode to solve the + -- syntactic ambiguity that results from an indexing of a function call + -- that returns an array, so that Obj.F (X, Y) may mean F (Ob) (X, Y). function New_Copy_List_Tree (List : List_Id) return List_Id; -- Copy recursively an analyzed list of nodes. Uses New_Copy_Tree defined diff --git a/gcc/ada/spark_xrefs.ads b/gcc/ada/spark_xrefs.ads index 52c0ef6..fd5b76d 100644 --- a/gcc/ada/spark_xrefs.ads +++ b/gcc/ada/spark_xrefs.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -29,8 +29,8 @@ -- file, and by Get_SPARK_Xrefs/Put_SPARK_Xrefs to read/write the textual -- representation that is stored in the ALI file. +with Table; with Types; use Types; -with GNAT.Table; package SPARK_Xrefs is @@ -258,12 +258,13 @@ package SPARK_Xrefs is -- Column number for the reference end record; - package SPARK_Xref_Table is new GNAT.Table ( + package SPARK_Xref_Table is new Table.Table ( Table_Component_Type => SPARK_Xref_Record, Table_Index_Type => Xref_Index, Table_Low_Bound => 1, Table_Initial => 2000, - Table_Increment => 300); + Table_Increment => 300, + Table_Name => "Xref_Table"); ----------------- -- Scope Table -- @@ -323,12 +324,13 @@ package SPARK_Xrefs is -- Entity (subprogram or package) for the scope end record; - package SPARK_Scope_Table is new GNAT.Table ( + package SPARK_Scope_Table is new Table.Table ( Table_Component_Type => SPARK_Scope_Record, Table_Index_Type => Scope_Index, Table_Low_Bound => 1, Table_Initial => 200, - Table_Increment => 300); + Table_Increment => 300, + Table_Name => "Scope_Table"); ---------------- -- File Table -- @@ -360,12 +362,13 @@ package SPARK_Xrefs is -- Ending index in Scope table for this unit end record; - package SPARK_File_Table is new GNAT.Table ( + package SPARK_File_Table is new Table.Table ( Table_Component_Type => SPARK_File_Record, Table_Index_Type => File_Index, Table_Low_Bound => 1, Table_Initial => 20, - Table_Increment => 200); + Table_Increment => 200, + Table_Name => "File_Table"); --------------- -- Constants -- diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb index 5d4522b..ed6f1f7 100644 --- a/gcc/ada/table.adb +++ b/gcc/ada/table.adb @@ -29,6 +29,9 @@ -- -- ------------------------------------------------------------------------------ +with Debug; use Debug; +with Opt; use Opt; +with Output; use Output; with System; use System; with Tree_IO; use Tree_IO; @@ -36,20 +39,370 @@ with System.Memory; use System.Memory; with Unchecked_Conversion; +pragma Elaborate_All (Output); + package body Table is package body Table is + Min : constant Int := Int (Table_Low_Bound); + -- Subscript of the minimum entry in the currently allocated table + + Length : Int := 0; + -- Number of entries in currently allocated table. The value of zero + -- ensures that we initially allocate the table. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Reallocate; + -- 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. + function Tree_Get_Table_Address return Address; -- Return Null_Address if the table length is zero, -- Table (First)'Address if not. + pragma Warnings (Off); + -- Turn off warnings. The following unchecked conversions are only used + -- internally in this package, and cannot never result in any instances + -- of improperly aliased pointers for the client of the package. + + function To_Address is new Unchecked_Conversion (Table_Ptr, Address); + function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr); + + pragma Warnings (On); + + ------------ + -- Append -- + ------------ + + procedure Append (New_Val : Table_Component_Type) is + begin + Set_Item (Table_Index_Type (Last_Val + 1), New_Val); + end Append; + + ---------------- + -- Append_All -- + ---------------- + + procedure Append_All (New_Vals : Table_Type) is + begin + for J in New_Vals'Range loop + Append (New_Vals (J)); + end loop; + end Append_All; + + -------------------- + -- Decrement_Last -- + -------------------- + + procedure Decrement_Last is + begin + Last_Val := Last_Val - 1; + end Decrement_Last; + + ---------- + -- Free -- + ---------- + + procedure Free is + begin + Free (To_Address (Table)); + Table := null; + Length := 0; + end Free; + + -------------------- + -- Increment_Last -- + -------------------- + + procedure Increment_Last is + begin + Last_Val := Last_Val + 1; + + if Last_Val > Max then + Reallocate; + end if; + end Increment_Last; + + ---------- + -- Init -- + ---------- + + procedure Init is + Old_Length : constant Int := Length; + + begin + Locked := False; + Last_Val := Min - 1; + Max := Min + (Table_Initial * Table_Factor) - 1; + Length := 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 = 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; + end if; + end Init; + + ---------- + -- Last -- + ---------- + + function Last return Table_Index_Type is + begin + return Table_Index_Type (Last_Val); + end Last; + + ---------------- + -- Reallocate -- + ---------------- + + procedure Reallocate is + New_Size : Memory.size_t; + New_Length : Long_Long_Integer; + + begin + if Max < Last_Val then + pragma Assert (not Locked); + + -- Make sure that we have at least the initial allocation. This + -- is needed in cases where a zero length table is written out. + + Length := Int'Max (Length, Table_Initial); + + -- 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 Max < Last_Val loop + New_Length := + Long_Long_Integer (Length) * + (100 + Long_Long_Integer (Table_Increment)) / 100; + Length := Int'Max (Int (New_Length), Length + 10); + Max := Min + Length - 1; + end loop; + + if Debug_Flag_D then + Write_Str ("--> Allocating new "); + Write_Str (Table_Name); + Write_Str (" table, size = "); + Write_Int (Max - Min + 1); + Write_Eol; + end if; + end if; + + -- Do the intermediate calculation in size_t to avoid signed overflow + + New_Size := + Memory.size_t (Max - Min + 1) * + (Table_Type'Component_Size / Storage_Unit); + + if Table = null then + Table := To_Pointer (Alloc (New_Size)); + + elsif New_Size > 0 then + Table := + To_Pointer (Realloc (Ptr => To_Address (Table), + Size => New_Size)); + end if; + + if Length /= 0 and then Table = null then + Set_Standard_Error; + Write_Str ("available memory exhausted"); + Write_Eol; + Set_Standard_Output; + raise Unrecoverable_Error; + end if; + end Reallocate; + + ------------- + -- Release -- + ------------- + + procedure Release is + Extra_Length : Int; + Size : Memory.size_t; + + begin + Length := Last_Val - Int (Table_Low_Bound) + 1; + Size := Memory.size_t (Length) * + (Table_Type'Component_Size / Storage_Unit); + + -- If the size of the table exceeds the release threshold then leave + -- space to store as many extra elements as 0.1% of the table length. + + if Release_Threshold > 0 + and then Size > Memory.size_t (Release_Threshold) + then + Extra_Length := Length / 1000; + Length := Length + Extra_Length; + Max := Int (Table_Low_Bound) + Length - 1; + + if Debug_Flag_D then + Write_Str ("--> Release_Threshold reached (length="); + Write_Int (Int (Size)); + Write_Str ("): leaving room space for "); + Write_Int (Extra_Length); + Write_Str (" components"); + Write_Eol; + end if; + else + Max := Last_Val; + end if; + + Reallocate; + end Release; + + ------------- + -- Restore -- + ------------- + + procedure Restore (T : Saved_Table) is + begin + Free (To_Address (Table)); + Last_Val := T.Last_Val; + Max := T.Max; + Table := T.Table; + Length := Max - Min + 1; + end Restore; + + ---------- + -- Save -- + ---------- + + function Save return Saved_Table is + Res : Saved_Table; + + begin + Res.Last_Val := Last_Val; + Res.Max := Max; + Res.Table := Table; + + Table := null; + Length := 0; + Init; + return Res; + end Save; + + -------------- + -- Set_Item -- + -------------- + + procedure Set_Item + (Index : 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 (Table'First .. Table_Index_Type (Max + 1)); + -- A constrained table subtype one element larger than the currently + -- allocated table. + + Allocated_Table_Address : constant System.Address := + 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 of computing 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 := Int (Index) > Max; + -- True if this operation requires storage reallocation (which may + -- involve moving table contents around). + + 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 (Max + 1))'Address + then + -- If so, save a copy on the stack because Increment_Last will + -- reallocate storage and might deallocate the current table. + + declare + Item_Copy : constant Table_Component_Type := Item; + begin + Set_Last (Index); + 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 Int (Index) > Last_Val then + Set_Last (Index); + end if; + + Table (Index) := Item; + end if; + end Set_Item; + + -------------- + -- Set_Last -- + -------------- + + procedure Set_Last (New_Val : Table_Index_Type) is + begin + if Int (New_Val) < Last_Val then + Last_Val := Int (New_Val); + + else + Last_Val := Int (New_Val); + + if Last_Val > Max then + Reallocate; + end if; + end if; + end Set_Last; + ---------------------------- -- Tree_Get_Table_Address -- ---------------------------- function Tree_Get_Table_Address return Address is begin - if Is_Empty then + if Length = 0 then return Null_Address; else return Table (First)'Address; @@ -65,15 +418,15 @@ package body Table is -- does an implicit Release. procedure Tree_Read is - Last : Int; begin - Init; - Tree_Read_Int (Last); - Set_Last (Table_Last_Type (Last)); + Tree_Read_Int (Max); + Last_Val := Max; + Length := Max - Min + 1; + Reallocate; Tree_Read_Data (Tree_Get_Table_Address, - (Last - Int (First) + 1) * + (Last_Val - Int (First) + 1) * -- Note the importance of parenthesizing the following division -- to avoid the possibility of intermediate overflow. @@ -93,9 +446,11 @@ package body Table is Tree_Write_Int (Int (Last)); Tree_Write_Data (Tree_Get_Table_Address, - (Int (Last - First) + 1) * + (Last_Val - Int (First) + 1) * (Table_Type'Component_Size / Storage_Unit)); end Tree_Write; + begin + Init; end Table; end Table; diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads index 8782f11..dcfc6fb 100644 --- a/gcc/ada/table.ads +++ b/gcc/ada/table.ads @@ -29,20 +29,19 @@ -- -- ------------------------------------------------------------------------------ --- This package is a wrapper for GNAT.Table, for use in the compiler front --- end. It adds the Tree_Write/Tree_Read functionality; everything else is --- just a renaming of GNAT.Table. See GNAT.Table (g-table.ads) and --- GNAT.Dynamic_Tables (g-dyntab.ads) for documentation. - --- Note that these three interfaces should remain synchronized to keep as much --- coherency as possible among these related units: --- --- GNAT.Dynamic_Tables --- GNAT.Table --- Table (the compiler unit) +-- This package provides an implementation of dynamically resizable one +-- dimensional arrays. The idea is to mimic the normal Ada semantics for +-- arrays as closely as possible with the one additional capability of +-- dynamically modifying the value of the Last attribute. + +-- This package uses a very efficient memory management scheme and any +-- change must be carefully evaluated on compilation of real software. + +-- Note that this interface should remain synchronized with those in +-- GNAT.Table and GNAT.Dynamic_Tables to keep coherency between these +-- three related units. with Types; use Types; -with GNAT.Table; package Table is pragma Elaborate_Body; @@ -51,66 +50,199 @@ package Table is type Table_Component_Type is private; type Table_Index_Type is range <>; - Table_Low_Bound : Table_Index_Type := Table_Index_Type'First; - Table_Initial : Pos := 8; - Table_Increment : Nat := 100; - Table_Name : String; -- for debugging printouts + Table_Low_Bound : Table_Index_Type; + Table_Initial : Pos; + Table_Increment : Nat; + Table_Name : String; Release_Threshold : Nat := 0; package Table is - package Tab is new GNAT.Table - (Table_Component_Type, - Table_Index_Type, - Table_Low_Bound, - Positive (Table_Initial), - Natural (Table_Increment), - Table_Name, - Natural (Release_Threshold)); - - subtype Valid_Table_Index_Type is Tab.Valid_Table_Index_Type; - subtype Table_Last_Type is Tab.Table_Last_Type; - subtype Table_Type is Tab.Table_Type; - - subtype Table_Ptr is Tab.Table_Ptr; - - Table : Table_Ptr renames Tab.Table; - - Locked : Boolean renames Tab.Locked; - - function Is_Empty return Boolean renames Tab.Is_Empty; - - procedure Init renames Tab.Init; - - function First return Table_Index_Type renames Tab.First; - function Last return Table_Last_Type renames Tab.Last; + -- 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 : array (Table_Index_Type range 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. + + -- 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. + + -- The Table_Initial values controls the allocation of the table when + -- it is first allocated, either by default, or by an explicit Init + -- call. The value used is Opt.Table_Factor * Table_Initial. + + -- The Table_Increment value controls the amount of increase, if the + -- table has to be increased in size. The value given is a percentage + -- value (e.g. 100 = increase table size by 100%, i.e. double it). + + -- The Table_Name parameter is simply use in debug output messages it + -- has no other usage, and is not referenced in non-debugging mode. + + -- The Last and Set_Last subprograms provide control over the current + -- logical allocation. They are quite efficient, so they can be used + -- freely (expensive reallocation occurs only at major granularity + -- chunks controlled by the allocation parameters). + + -- Note: We do not make the table components aliased, since this would + -- restrict the use of table for discriminated types. If it is necessary + -- to take the access of a table element, use Unrestricted_Access. + + -- WARNING: On HPPA, the virtual addressing approach used in this unit + -- is incompatible with the indexing instructions on the HPPA. So when + -- using this unit, compile your application with -mdisable-indexing. + + -- WARNING: If the table is reallocated, then the address of all its + -- components will change. So do not capture the address of an element + -- and then use the address later after the table may be reallocated. + -- One tricky case of this is passing an element of the table to a + -- subprogram by reference where the table gets reallocated during + -- the execution of the subprogram. The best rule to follow is never + -- to pass a table element as a parameter except for the case of IN + -- mode parameters with scalar values. + + type Table_Type is + array (Table_Index_Type range <>) of Table_Component_Type; + + subtype Big_Table_Type is + Table_Type (Table_Low_Bound .. 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. + + 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 + + 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. + + 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. This + -- feature is used to control table expansion during Gigi processing. + -- Gigi assumes that tables other than the Uint and Ureal tables do + -- not move during processing, which means that they cannot be expanded. + -- The Locked flag is used to enforce this restriction. + + procedure Init; + -- This procedure allocates a new table of size Initial (freeing any + -- previously allocated larger table). It is not necessary to call + -- Init when a table is first instantiated (since the instantiation does + -- the same initialization steps). However, it is harmless to do so, and + -- Init is convenient in reestablishing a table for new use. + + function Last return Table_Index_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. + + procedure Release; + -- Storage is allocated in chunks according to the values given in the + -- Initial and Increment parameters. If Release_Threshold is 0 or the + -- length of the table does not exceed this threshold then a call to + -- Release releases all storage that is allocated, but is not logically + -- part of the current array value; otherwise the call to Release leaves + -- the current array value plus 0.1% of the current table length free + -- elements located at the end of the table (this parameter facilitates + -- reopening large tables and adding a few elements without allocating a + -- chunk of memory). In both cases current array values are not affected + -- by this call. + + procedure Free; + -- Free all allocated memory for the table. A call to init is required + -- before any use of this table after calling Free. + + First : constant Table_Index_Type := Table_Low_Bound; + -- Export First as synonym for Low_Bound (parallel with use of Last) + + procedure Set_Last (New_Val : Table_Index_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. + + procedure Increment_Last; + pragma Inline (Increment_Last); + -- Adds 1 to Last (same as Set_Last (Last + 1) + + procedure Decrement_Last; + pragma Inline (Decrement_Last); + -- Subtracts 1 from Last (same as Set_Last (Last - 1) + + procedure Append (New_Val : Table_Component_Type); + pragma Inline (Append); + -- Equivalent to: + -- x.Increment_Last; + -- x.Table (x.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 (New_Vals : Table_Type); + -- Appends all components of New_Vals - procedure Release renames Tab.Release; - - procedure Free renames Tab.Free; - - procedure Set_Last (New_Val : Table_Last_Type) renames Tab.Set_Last; - - procedure Increment_Last renames Tab.Increment_Last; - procedure Decrement_Last renames Tab.Decrement_Last; + procedure Set_Item + (Index : 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. - procedure Append (New_Val : Table_Component_Type) renames Tab.Append; - procedure Append_All (New_Vals : Table_Type) renames Tab.Append_All; + type Saved_Table is private; + -- Type used for Save/Restore subprograms - procedure Set_Item - (Index : Valid_Table_Index_Type; - Item : Table_Component_Type) renames Tab.Set_Item; + function Save return Saved_Table; + -- Resets table to empty, but saves old contents of table in returned + -- value, for possible later restoration by a call to Restore. - subtype Saved_Table is Tab.Saved_Table; - function Save return Saved_Table renames Tab.Save; - procedure Restore (T : in out Saved_Table) renames Tab.Restore; + procedure Restore (T : Saved_Table); + -- Given a Saved_Table value returned by a prior call to Save, restores + -- the table to the state it was in at the time of the Save call. procedure Tree_Write; -- Writes out contents of table using Tree_IO procedure Tree_Read; -- Initializes table by reading contents previously written with the - -- Tree_Write call, also using Tree_IO. + -- Tree_Write call (also using Tree_IO). + + private + + Last_Val : Int; + -- Current value of Last. Note that we declare this in the private part + -- because we don't want the client to modify Last except through one of + -- the official interfaces (since a modification to Last may require a + -- reallocation of the table). + + Max : Int; + -- Subscript of the maximum entry in the currently allocated table + + type Saved_Table is record + Last_Val : Int; + Max : Int; + Table : Table_Ptr; + end record; end Table; end Table; diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 7c1f1b7..6f25a7b 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -423,12 +423,13 @@ package body Treepr is procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String) is function Field_Present (U : Union_Id) return Boolean; -- Returns False unless the value U represents a missing value - -- (Empty, No_Uint, No_Ureal or No_String) + -- (Empty, No_Elist, No_Uint, No_Ureal or No_String) function Field_Present (U : Union_Id) return Boolean is begin return U /= Union_Id (Empty) and then + U /= Union_Id (No_Elist) and then U /= To_Union (No_Uint) and then U /= To_Union (No_Ureal) and then U /= Union_Id (No_String); diff --git a/gcc/ada/uintp.h b/gcc/ada/uintp.h index 5263b1b..ec374b3 100644 --- a/gcc/ada/uintp.h +++ b/gcc/ada/uintp.h @@ -101,11 +101,11 @@ extern Boolean UI_Lt (Uint, Uint); the integer value itself. The origin of the Uints_Ptr table is adjusted so that a Uint value of Uint_Bias indexes the first element. */ -#define Uints_Ptr (uintp__uints__tab__the_instance - Uint_Table_Start) -extern struct Uint_Entry *uintp__uints__tab__the_instance; +#define Uints_Ptr (uintp__uints__table - Uint_Table_Start) +extern struct Uint_Entry *uintp__uints__table; -#define Udigits_Ptr uintp__udigits__tab__the_instance -extern int *uintp__udigits__tab__the_instance; +#define Udigits_Ptr uintp__udigits__table +extern int *uintp__udigits__table; #ifdef __cplusplus } |