OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Speed up enumeration'Value with perfect hash function

Browse Source 
gcc/ada/

	* Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-imagen, s-imen16,
	s-imen32, s-imenu8, s-pehage, s-valuen, s-vaen16, s-vaen32 and
	s-vaenu8.  Remove s-imenne, s-imgenu and s-valenu.
	* debug.adb (d_h): Document new usage.
	* einfo.ads (Lit_Hash): New attribute for enumeration types.
	(Set_Lit_Hash): Declare.
	* einfo.adb (Lit_Hash): New function.
	(Set_Lit_Hash): New procedure.
	(Write_Field21_Name): Print Lit_Hash for Enumeration_Kind.
	* exp_imgv.ads (Build_Enumeration_Image_Tables): Fix description
	and document the hash function and its tables.
	* exp_imgv.adb: Add with/use clauses for Debug.  Add with clause
	for System.Perfect_Hash_Generators.
	(Append_Table_To): New helper routine.
	(Build_Enumeration_Image_Tables): Call it to build the tables.
	In the main unit, register the literals with the hash generator.
	If they are sufficiently many and -gnatd_h is not passed, generate
	a perfect hash function and its tables; otherwise, generate a dummy
	hash function.  For the other units, generate only the declaration.
	In all cases, set Lit_Hash to the entity of the function, if any.
	(Expand_Value_Attribute): Pass the 'Unrestricted_Access of Lit_Hash,
	if any, as third argument to the Value_Enumeration_NN function.
	* gnat1drv.adb (Adjust_Global_Switches): force simpler implementation
	of 'Value in CodePeer_Mode.
	* lib.ads (Synchronize_Serial_Number): Add SN parameter.
	* lib.adb (Synchronize_Serial_Number): Assert that it is larger than
	the serial number of the current unit and set the latter to it only
	in this case.
	* rtsfind.ads (RTU_Id): Add System_Img_Enum_8, System_Img_Enum_16,
	System_Img_Enum_32, System_Val_Enum_8, System_Val_Enum_16 and
	System_Val_Enum_32.  Remove System_Img_Enum, System_Img_Enum_New
	and System_Val_Enum.
	* sem_attr.adb (Analyze_Access_Attribute): Do not flag a compiler
	generated Unrestricted_Access attribute as illegal in a declare
	expression.
	(RE_Unit_Table): Adjust to above changes.
	* libgnat/g-heasor.ads: Add pragma Compiler_Unit_Warning.
	* libgnat/g-table.ads: Likewise.
	* libgnat/g-pehage.ads: Add with clause and local renaming for
	System.Perfect_Hash_Generators.
	(Optimization): Turn into derived type.
	(Verbose): Turn into renaming.
	(Too_Many_Tries): Likewise.
	(Table_Name): Move to System.Perfect_Hash_Generators.
	(Define): Likewise.
	(Value): Likewise.
	* libgnat/g-pehage.adb: Remove with clause for Ada.Directories,
	GNAT.Heap_Sort_G and GNAT.Table.  Move bulk of implementation
	to System.Perfect_Hash_Generators, only keep the output part.
	* libgnat/s-imagen.ads: New generic unit.
	* libgnat/s-imagen.adb: New body.
	* libgnat/s-imen16.ads: New unit.
	* libgnat/s-imen32.ads: Likewise.
	* libgnat/s-imenu8.ads: Likewise.
	* libgnat/s-imenne.ads: Adjust description.
	* libgnat/s-imgenu.ads: Delete.
	* libgnat/s-imgenu.adb: Likewise.
	* libgnat/s-pehage.ads: New unit from GNAT.Perfect_Hash_Generators.
	* libgnat/s-pehage.adb: New body from GNAT.Perfect_Hash_Generators.
	* libgnat/s-valuen.ads: New generic unit.
	* libgnat/s-valuen.adb: New body.
	* libgnat/s-vaen16.ads: New unit.
	* libgnat/s-vaen32.ads: Likewise.
	* libgnat/s-vaenu8.ads: Likewise.
	* libgnat/s-valenu.ads: Delete.
	* libgnat/s-valenu.adb: Likewise.
	* gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Add s-pehage.o.
	(GNATBIND_OBJS): Remove s-imgenu.o.
This commit is contained in:
Piotr Trojanek 2021-01-08 19:53:41 +01:00 committed by Pierre-Marie de Rodat
parent 78a4cb56a0
commit c11207d345
29 changed files with 3584 additions and 2349 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/ada/Makefile.rtl
View File

@ -619,18 +619,20 @@ GNATRTL_NONTASKING_OBJS= \
s-imaged$(objext) \
s-imagef$(objext) \
s-imagei$(objext) \
s-imagen$(objext) \
s-imager$(objext) \
s-imageu$(objext) \
s-imagew$(objext) \
s-imde32$(objext) \
s-imde64$(objext) \
s-imenne$(objext) \
s-imen16$(objext) \
s-imen32$(objext) \
s-imenu8$(objext) \
s-imfi32$(objext) \
s-imfi64$(objext) \
s-imgbiu$(objext) \
s-imgboo$(objext) \
s-imgcha$(objext) \
s-imgenu$(objext) \
s-imgflt$(objext) \
s-imgint$(objext) \
s-imglfl$(objext) \
@ -714,6 +716,7 @@ GNATRTL_NONTASKING_OBJS= \
s-pack63$(objext) \
s-parame$(objext) \
s-parint$(objext) \
s-pehage$(objext) \
s-pooglo$(objext) \
s-pooloc$(objext) \
s-poosiz$(objext) \
@ -759,9 +762,11 @@ GNATRTL_NONTASKING_OBJS= \
s-valcha$(objext) \
s-vade32$(objext) \
s-vade64$(objext) \
s-vaen16$(objext) \
s-vaen32$(objext) \
s-vaenu8$(objext) \
s-vafi32$(objext) \
s-vafi64$(objext) \
s-valenu$(objext) \
s-valflt$(objext) \
s-valint$(objext) \
s-vallfl$(objext) \
@ -772,6 +777,7 @@ GNATRTL_NONTASKING_OBJS= \
s-valued$(objext) \
s-valuef$(objext) \
s-valuei$(objext) \
s-valuen$(objext) \
s-valuer$(objext) \
s-valueu$(objext) \
s-valuns$(objext) \

5
gcc/ada/debug.adb
View File

@ -146,7 +146,7 @@ package body Debug is
-- d_e Ignore entry calls and requeue statements for elaboration
-- d_f Issue info messages related to GNATprove usage
-- d_g
-- d_h
-- d_h Disable the use of (perfect) hash functions for enumeration Value
-- d_i Ignore activations and calls to instances for elaboration
-- d_j Read JSON files and populate Repinfo tables (opposite of -gnatRjs)
-- d_k
@ -971,6 +971,9 @@ package body Debug is
-- beginners find them confusing. Set automatically by GNATprove when
-- switch --info is used.
-- d_h The compiler does not make use of (perfect) hash functions in the
-- implementation of the Value attribute for enumeration types.
-- d_i The compiler ignores calls and task activations when they target a
-- subprogram or task type defined in an external instance for both
-- the static and dynamic elaboration models.

16
gcc/ada/einfo.adb
View File

@ -180,6 +180,7 @@ package body Einfo is
-- Corresponding_Record_Component Node21
-- Default_Expr_Function Node21
-- Discriminant_Constraint Elist21
-- Lit_Hash Node21
-- Interface_Name Node21
-- Original_Array_Type Node21
-- Small_Value Ureal21
@ -2836,6 +2837,12 @@ package body Einfo is
return Node33 (Id);
end Linker_Section_Pragma;
function Lit_Hash (Id : E) return E is
begin
pragma Assert (Is_Enumeration_Type (Id));
return Node21 (Id);
end Lit_Hash;
function Lit_Indexes (Id : E) return E is
begin
pragma Assert (Is_Enumeration_Type (Id));
@ -6103,6 +6110,12 @@ package body Einfo is
Set_Node33 (Id, V);
end Set_Linker_Section_Pragma;
procedure Set_Lit_Hash (Id : E; V : E) is
begin
pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id);
Set_Node21 (Id, V);
end Set_Lit_Hash;
procedure Set_Lit_Indexes (Id : E; V : E) is
begin
pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id);
@ -10884,6 +10897,9 @@ package body Einfo is
=>
Write_Str ("Interface_Name");
when Enumeration_Kind =>
Write_Str ("Lit_Hash");
when Array_Kind
| Modular_Integer_Kind
=>

12
gcc/ada/einfo.ads
View File

@ -3498,6 +3498,13 @@ package Einfo is
-- field may be set as a result of a linker section pragma applied to the
-- type of the object.
-- Lit_Hash (Node21)
-- Defined in enumeration types and subtypes. Non-empty only for the
-- case of an enumeration root type, where it contains the entity for
-- the generated hash function. See unit Exp_Imgv for full details of
-- the nature and use of this entity for implementing the Value
-- attribute for the enumeration type in question.
-- Lit_Indexes (Node18)
-- Defined in enumeration types and subtypes. Non-empty only for the
-- case of an enumeration root type, where it contains the entity for
@ -6150,6 +6157,7 @@ package Einfo is
-- Lit_Indexes (Node18) (root type only)
-- Default_Aspect_Value (Node19) (base type only)
-- Scalar_Range (Node20)
-- Lit_Hash (Node21) (root type only)
-- Enum_Pos_To_Rep (Node23) (type only)
-- Static_Discrete_Predicate (List25)
-- Has_Biased_Representation (Flag139)
@ -7469,6 +7477,7 @@ package Einfo is
function Last_Entity (Id : E) return E;
function Limited_View (Id : E) return E;
function Linker_Section_Pragma (Id : E) return N;
function Lit_Hash (Id : E) return E;
function Lit_Indexes (Id : E) return E;
function Lit_Strings (Id : E) return E;
function Low_Bound_Tested (Id : E) return B;
@ -8191,6 +8200,7 @@ package Einfo is
procedure Set_Last_Entity (Id : E; V : E);
procedure Set_Limited_View (Id : E; V : E);
procedure Set_Linker_Section_Pragma (Id : E; V : N);
procedure Set_Lit_Hash (Id : E; V : E);
procedure Set_Lit_Indexes (Id : E; V : E);
procedure Set_Lit_Strings (Id : E; V : E);
procedure Set_Low_Bound_Tested (Id : E; V : B := True);
@ -9073,6 +9083,7 @@ package Einfo is
pragma Inline (Limited_View);
pragma Inline (Link_Entities);
pragma Inline (Linker_Section_Pragma);
pragma Inline (Lit_Hash);
pragma Inline (Lit_Indexes);
pragma Inline (Lit_Strings);
pragma Inline (Low_Bound_Tested);
@ -9643,6 +9654,7 @@ package Einfo is
pragma Inline (Set_Last_Entity);
pragma Inline (Set_Limited_View);
pragma Inline (Set_Linker_Section_Pragma);
pragma Inline (Set_Lit_Hash);
pragma Inline (Set_Lit_Indexes);
pragma Inline (Set_Lit_Strings);
pragma Inline (Set_Low_Bound_Tested);

538
gcc/ada/exp_imgv.adb
View File

@ -26,6 +26,7 @@
with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Exp_Put_Image;
with Exp_Util; use Exp_Util;
@ -47,6 +48,8 @@ with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Urealp; use Urealp;
with System.Perfect_Hash_Generators;
package body Exp_Imgv is
procedure Rewrite_Object_Image
@ -65,21 +68,88 @@ package body Exp_Imgv is
------------------------------------
procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (E);
Loc : constant Source_Ptr := Sloc (E);
In_Main_Unit : constant Boolean := In_Extended_Main_Code_Unit (Loc);
Act : List_Id;
Eind : Entity_Id;
Estr : Entity_Id;
H_Id : Entity_Id;
H_OK : Boolean;
H_Sp : Node_Id;
Ind : List_Id;
Ityp : Node_Id;
Len : Nat;
Lit : Entity_Id;
Nlit : Nat;
S_Id : Entity_Id;
S_N : Nat;
Str : String_Id;
package SPHG renames System.Perfect_Hash_Generators;
Saved_SSO : constant Character := Opt.Default_SSO;
-- Used to save the current scalar storage order during the generation
-- of the literal lookup table.
Serial_Number_Budget : constant := 50;
-- We may want to compute a perfect hash function for use by the Value
-- attribute. However computing this function is costly and, therefore,
-- cannot be done when compiling every unit where the enumeration type
-- is referenced, so we do it only when compiling the unit where it is
-- declared. This means that we may need to control the internal serial
-- numbers of this unit, or else we would risk generating public symbols
-- with mismatched names later on. The strategy for this is to allocate
-- a fixed budget of serial numbers to be spent from a specified point
-- until the end of the processing and to make sure that it is always
-- exactly spent on all possible paths from this point.
Threshold : constant := 3;
-- Threshold above which we want to generate the hash function in the
-- default case.
Threshold_For_Size : constant := 9;
-- But the function and its tables take a bit of space so the threshold
-- is raised when compiling for size.
procedure Append_Table_To
(L : List_Id;
E : Entity_Id;
UB : Nat;
Ctyp : Entity_Id;
V : List_Id);
-- Append to L the declaration of E as a constant array of range 0 .. UB
-- and component type Ctyp with initial value V.
---------------------
-- Append_Table_To --
---------------------
procedure Append_Table_To
(L : List_Id;
E : Entity_Id;
UB : Nat;
Ctyp : Entity_Id;
V : List_Id)
is
begin
Append_To (L,
Make_Object_Declaration (Loc,
Defining_Identifier => E,
Constant_Present => True,
Object_Definition =>
Make_Constrained_Array_Definition (Loc,
Discrete_Subtype_Definitions => New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 0),
High_Bound => Make_Integer_Literal (Loc, UB))),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication => New_Occurrence_Of (Ctyp, Loc))),
Expression => Make_Aggregate (Loc, Expressions => V)));
end Append_Table_To;
begin
-- Nothing to do for types other than a root enumeration type
@ -99,10 +169,10 @@ package body Exp_Imgv is
Lit := First_Literal (E);
Len := 1;
Nlit := 0;
H_OK := False;
loop
Append_To (Ind,
Make_Integer_Literal (Loc, UI_From_Int (Len)));
Append_To (Ind, Make_Integer_Literal (Loc, UI_From_Int (Len)));
exit when No (Lit);
Nlit := Nlit + 1;
@ -114,6 +184,9 @@ package body Exp_Imgv is
end if;
Store_String_Chars (Name_Buffer (1 .. Name_Len));
if In_Main_Unit then
SPHG.Insert (Name_Buffer (1 .. Name_Len));
end if;
Len := Len + Int (Name_Len);
Next_Literal (Lit);
end loop;
@ -148,7 +221,7 @@ package body Exp_Imgv is
-- Generate literal table
Insert_Actions (N,
Act :=
New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Estr,
@ -157,27 +230,420 @@ package body Exp_Imgv is
New_Occurrence_Of (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
Strval => Str)),
Strval => Str)));
Make_Object_Declaration (Loc,
Defining_Identifier => Eind,
Constant_Present => True,
-- Generate index table
Object_Definition =>
Make_Constrained_Array_Definition (Loc,
Discrete_Subtype_Definitions => New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 0),
High_Bound => Make_Integer_Literal (Loc, Nlit))),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication => New_Occurrence_Of (Ityp, Loc))),
Append_Table_To (Act, Eind, Nlit, Ityp, Ind);
Expression =>
Make_Aggregate (Loc,
Expressions => Ind))),
Suppress => All_Checks);
-- If the number of literals is at most 3, then we are done. Otherwise
-- we compute a (perfect) hash function for use by the Value attribute.
if Nlit > Threshold then
-- We start to count serial numbers from here
S_N := Increment_Serial_Number;
-- Generate specification of hash function
H_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (E), 'H'));
Set_Ekind (H_Id, E_Function);
Set_Is_Internal (H_Id);
if not Debug_Generated_Code then
Set_Debug_Info_Off (H_Id);
end if;
Set_Lit_Hash (E, H_Id);
S_Id := Make_Temporary (Loc, 'S');
H_Sp := Make_Function_Specification (Loc,
Defining_Unit_Name => H_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => S_Id,
Parameter_Type =>
New_Occurrence_Of (Standard_String, Loc))),
Result_Definition =>
New_Occurrence_Of (Standard_Natural, Loc));
-- If the unit where the type is declared is the main unit, and the
-- number of literals is greater than Threshold_For_Size when we are
-- optimizing for size, and -gnatd_h is not specified, try to compute
-- the hash function.
if In_Main_Unit
and then (Optimize_Size = 0 or else Nlit > Threshold_For_Size)
and then not Debug_Flag_Underscore_H
then
declare
LB : constant Positive := 2 * Positive (Nlit) + 1;
UB : constant Positive := LB + 24;
begin
-- Try at most 25 * 4 times to compute the hash function before
-- giving up and using a linear search for the Value attribute.
for V in LB .. UB loop
begin
SPHG.Initialize (4321, V, SPHG.Memory_Space, Tries => 4);
SPHG.Compute ("");
H_OK := True;
exit;
exception
when SPHG.Too_Many_Tries => null;
end;
end loop;
end;
end if;
-- If the hash function has been successfully computed, 4 more tables
-- named P, T1, T2 and G are needed. The hash function is of the form
-- function Hash (S : String) return Natural is
-- F : constant Natural := S'First - 1;
-- L : constant Natural := S'Length;
-- A, B : Natural := 0;
-- J : Natural;
-- begin
-- for K in P'Range loop
-- exit when L < P (K);
-- J := Character'Pos (S (P (K) + F));
-- A := (A + Natural (T1 (K) * J)) mod N;
-- B := (B + Natural (T2 (K) * J)) mod N;
-- end loop;
-- return (Natural (G (A)) + Natural (G (B))) mod M;
-- end Hash;
-- where N is the length of G and M the number of literals.
if H_OK then
declare
Siz, L1, L2 : Natural;
I : Int;
Pos, T1, T2, G : List_Id;
EPos, ET1, ET2, EG : Entity_Id;
F, L, A, B, J, K : Entity_Id;
Body_Decls : List_Id;
Body_Stmts : List_Id;
Loop_Stmts : List_Id;
begin
-- Generate position table
SPHG.Define (SPHG.Character_Position, Siz, L1, L2);
Pos := New_List;
for J in 0 .. L1 - 1 loop
I := Int (SPHG.Value (SPHG.Character_Position, J));
Append_To (Pos, Make_Integer_Literal (Loc, UI_From_Int (I)));
end loop;
EPos :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (E), 'P'));
Append_Table_To
(Act, EPos, Nat (L1 - 1), Standard_Natural, Pos);
-- Generate function table 1
SPHG.Define (SPHG.Function_Table_1, Siz, L1, L2);
T1 := New_List;
for J in 0 .. L1 - 1 loop
I := Int (SPHG.Value (SPHG.Function_Table_1, J));
Append_To (T1, Make_Integer_Literal (Loc, UI_From_Int (I)));
end loop;
ET1 :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (E), "T1"));
Ityp :=
Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
Append_Table_To (Act, ET1, Nat (L1 - 1), Ityp, T1);
-- Generate function table 2
SPHG.Define (SPHG.Function_Table_2, Siz, L1, L2);
T2 := New_List;
for J in 0 .. L1 - 1 loop
I := Int (SPHG.Value (SPHG.Function_Table_2, J));
Append_To (T2, Make_Integer_Literal (Loc, UI_From_Int (I)));
end loop;
ET2 :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (E), "T2"));
Ityp :=
Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
Append_Table_To (Act, ET2, Nat (L1 - 1), Ityp, T2);
-- Generate graph table
SPHG.Define (SPHG.Graph_Table, Siz, L1, L2);
G := New_List;
for J in 0 .. L1 - 1 loop
I := Int (SPHG.Value (SPHG.Graph_Table, J));
Append_To (G, Make_Integer_Literal (Loc, UI_From_Int (I)));
end loop;
EG :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (E), 'G'));
Ityp :=
Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
Append_Table_To (Act, EG, Nat (L1 - 1), Ityp, G);
-- Generate body of hash function
F := Make_Temporary (Loc, 'F');
Body_Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => F,
Object_Definition =>
New_Occurrence_Of (Standard_Natural, Loc),
Expression =>
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (S_Id, Loc),
Attribute_Name => Name_First),
Right_Opnd =>
Make_Integer_Literal (Loc, 1))));
L := Make_Temporary (Loc, 'L');
Append_To (Body_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => L,
Object_Definition =>
New_Occurrence_Of (Standard_Natural, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (S_Id, Loc),
Attribute_Name => Name_Length)));
A := Make_Temporary (Loc, 'A');
Append_To (Body_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => A,
Object_Definition =>
New_Occurrence_Of (Standard_Natural, Loc),
Expression => Make_Integer_Literal (Loc, 0)));
B := Make_Temporary (Loc, 'B');
Append_To (Body_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => B,
Object_Definition =>
New_Occurrence_Of (Standard_Natural, Loc),
Expression => Make_Integer_Literal (Loc, 0)));
J := Make_Temporary (Loc, 'J');
Append_To (Body_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => J,
Object_Definition =>
New_Occurrence_Of (Standard_Natural, Loc)));
K := Make_Temporary (Loc, 'K');
-- Generate exit when L < P (K);
Loop_Stmts := New_List (
Make_Exit_Statement (Loc,
Condition =>
Make_Op_Lt (Loc,
Left_Opnd => New_Occurrence_Of (L, Loc),
Right_Opnd =>
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (EPos, Loc),
Expressions => New_List (
New_Occurrence_Of (K, Loc))))));
-- Generate J := Character'Pos (S (P (K) + F));
Append_To (Loop_Stmts,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (J, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Standard_Character, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (S_Id, Loc),
Expressions => New_List (
Make_Op_Add (Loc,
Left_Opnd =>
Make_Indexed_Component (Loc,
Prefix =>
New_Occurrence_Of (EPos, Loc),
Expressions => New_List (
New_Occurrence_Of (K, Loc))),
Right_Opnd =>
New_Occurrence_Of (F, Loc))))))));
-- Generate A := (A + Natural (T1 (K) * J)) mod N;
Append_To (Loop_Stmts,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (A, Loc),
Expression =>
Make_Op_Mod (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => New_Occurrence_Of (A, Loc),
Right_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd =>
Convert_To (Standard_Natural,
Make_Indexed_Component (Loc,
Prefix =>
New_Occurrence_Of (ET1, Loc),
Expressions => New_List (
New_Occurrence_Of (K, Loc)))),
Right_Opnd => New_Occurrence_Of (J, Loc))),
Right_Opnd => Make_Integer_Literal (Loc, Int (L1)))));
-- Generate B := (B + Natural (T2 (K) * J)) mod N;
Append_To (Loop_Stmts,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (B, Loc),
Expression =>
Make_Op_Mod (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => New_Occurrence_Of (B, Loc),
Right_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd =>
Convert_To (Standard_Natural,
Make_Indexed_Component (Loc,
Prefix =>
New_Occurrence_Of (ET2, Loc),
Expressions => New_List (
New_Occurrence_Of (K, Loc)))),
Right_Opnd => New_Occurrence_Of (J, Loc))),
Right_Opnd => Make_Integer_Literal (Loc, Int (L1)))));
-- Generate loop
Body_Stmts := New_List (
Make_Implicit_Loop_Statement (N,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => K,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (EPos, Loc),
Attribute_Name => Name_Range))),
Statements => Loop_Stmts));
-- Generate return (Natural (G (A)) + Natural (G (B))) mod M;
Append_To (Body_Stmts,
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Op_Mod (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd =>
Convert_To (Standard_Natural,
Make_Indexed_Component (Loc,
Prefix =>
New_Occurrence_Of (EG, Loc),
Expressions => New_List (
New_Occurrence_Of (A, Loc)))),
Right_Opnd =>
Convert_To (Standard_Natural,
Make_Indexed_Component (Loc,
Prefix =>
New_Occurrence_Of (EG, Loc),
Expressions => New_List (
New_Occurrence_Of (B, Loc))))),
Right_Opnd => Make_Integer_Literal (Loc, Nlit))));
-- Generate final body
Append_To (Act,
Make_Subprogram_Body (Loc,
Specification => H_Sp,
Declarations => Body_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts)));
end;
-- If we chose not to or did not manage to compute the hash function,
-- we need to build a dummy function always returning Natural'Last
-- because other units reference it if they use the Value attribute.
elsif In_Main_Unit then
declare
Body_Stmts : List_Id;
begin
-- Generate return Natural'Last
Body_Stmts := New_List (
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Standard_Natural, Loc),
Attribute_Name => Name_Last)));
-- Generate body
Append_To (Act,
Make_Subprogram_Body (Loc,
Specification => H_Sp,
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts)));
end;
-- For the other units, just declare the function
else
Append_To (Act,
Make_Subprogram_Declaration (Loc, Specification => H_Sp));
end if;
else
Set_Lit_Hash (E, Empty);
end if;
if In_Main_Unit then
System.Perfect_Hash_Generators.Finalize;
end if;
Insert_Actions (N, Act, Suppress => All_Checks);
-- This is where we check that our budget of serial numbers has been
-- entirely spent, see the declaration of Serial_Number_Budget above.
if Nlit > Threshold then
Synchronize_Serial_Number (S_N + Serial_Number_Budget);
end if;
-- Reset the scalar storage order to the saved value
@ -916,15 +1382,17 @@ package body Exp_Imgv is
-- For enumeration types other than those derived from types Boolean,
-- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
-- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
-- Enum'Val
-- (Value_Enumeration_NN
-- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
-- where typS and typI and the Lit_Strings and Lit_Indexes entities
-- from T's root type entity, and Num is Enum'Pos (Enum'Last). The
-- Value_Enumeration_NN function will search the tables looking for
-- where typS, typN and typH are the Lit_Strings, Lit_Indexes and Lit_Hash
-- entities from T's root type entity, and Num is Enum'Pos (Enum'Last).
-- The Value_Enumeration_NN function will search the tables looking for
-- X and return the position number in the table if found which is
-- used to provide the result of 'Value (using Enum'Val). If the
-- value is not found Constraint_Error is raised. The suffix _NN
-- depends on the element type of typI.
-- depends on the element type of typN.
procedure Expand_Value_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
@ -1083,10 +1551,11 @@ package body Exp_Imgv is
Analyze_And_Resolve (N, Btyp);
-- Here for normal case where we have enumeration tables, this
-- is where we build
-- Normal case where we have enumeration tables, build
-- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
-- T'Val
-- (Value_Enumeration_NN
-- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
else
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
@ -1108,6 +1577,15 @@ package body Exp_Imgv is
Prefix => New_Occurrence_Of (Rtyp, Loc),
Attribute_Name => Name_Last))));
if Present (Lit_Hash (Rtyp)) then
Prepend_To (Args,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Lit_Hash (Rtyp), Loc),
Attribute_Name => Name_Unrestricted_Access));
else
Prepend_To (Args, Make_Null (Loc));
end if;
Prepend_To (Args,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),

58
gcc/ada/exp_imgv.ads
View File

@ -35,39 +35,49 @@ package Exp_Imgv is
-- base type. The node N is the point in the tree where the resulting
-- declarations are to be inserted.
--
-- The form of the tables generated is as follows:
-- The form of the tables generated is as follows:
--
-- xxxS : string := "chars";
-- xxxI : array (0 .. N) of Natural_8/16/32 := (1, n, .., n);
-- xxxS : constant string (1 .. M) := "chars";
-- xxxN : constant array (0 .. N) of Index_Type := (i1, i2, .., iN, j);
--
-- Here xxxS is a string obtained by concatenating all the names
-- of the enumeration literals in sequence, representing any wide
-- characters according to the current wide character encoding
-- method, and with all letters forced to upper case.
-- Here xxxS is a string obtained by concatenating all the names of the
-- enumeration literals in sequence, representing any wide characters
-- according to the current wide character encoding method, and with all
-- letters forced to upper case.
--
-- The array xxxI is an array of ones origin indexes to the start
-- of each name, with one extra entry at the end, which is the index
-- to the character just past the end of the last literal, i.e. it is
-- the length of xxxS + 1. The element type is the shortest of the
-- possible types that will hold all the values.
-- The array xxxN is an array of indexes into xxxS pointing to the start
-- of each name, with one extra entry at the end, which is the index to
-- the character just past the end of the last literal, i.e. it is the
-- length of xxxS + 1. The element type is the shortest of the possible
-- types that will hold all the values.
--
-- For example, for the type
-- For example, for the type
--
-- type x is (hello,'!',goodbye);
-- type x is (hello,'!',goodbye);
--
-- the generated tables would consist of
-- the generated tables would consist of
--
-- xxxS : String := "hello'!'goodbye";
-- xxxI : array (0 .. 3) of Natural_8 := (1, 6, 9, 16);
-- xxxS : constant string (1 .. 15) := "hello'!'goodbye";
-- xxxN : constant array (0 .. 3) of Integer_8 := (1, 6, 9, 16);
--
-- Here Natural_8 is used since 16 < 2**(8-1)
-- Here Integer_8 is used since 16 < 2**(8-1).
--
-- If the entity E needs the tables constructing, the necessary
-- declarations are constructed, and the fields Lit_Strings and
-- Lit_Indexes of E are set to point to the corresponding entities.
-- If no tables are needed (E is not a user defined enumeration
-- root type, or pragma Discard_Names is in effect, then the
-- declarations are not constructed, and the fields remain Empty.
-- If the entity E needs the tables, the necessary declarations are built
-- and the fields Lit_Strings and Lit_Indexes of E are set to point to the
-- corresponding entities. If no tables are needed (E is not a user defined
-- enumeration root type, or pragma Discard_Names is in effect), then the
-- declarations are not constructed and the fields remain Empty.
--
-- If the number of enumeration literals is large enough, a (perfect) hash
-- function mapping the literals to their position number is also built and
-- requires in turn to build four additional tables:
--
-- xxxP : constant array (0 .. X - 1) of Natural = (p1, p2, ..., pX);
-- xxxT1 : constant array (0 .. Y - 1) of Index_Type = (q1, ..., qY);
-- xxxT2 : constant array (0 .. Y - 1) of Index_Type = (r1, ..., rY);
-- xxxG : constant array (0 .. Z - 1) of Index_Type = (s1, ..., sZ);
--
-- See the System.Perfect_Hash_Generators unit for a complete description.
procedure Expand_Image_Attribute (N : Node_Id);
-- This procedure is called from Exp_Attr to expand an occurrence of the

2
gcc/ada/gcc-interface/Make-lang.in
View File

@ -390,6 +390,7 @@ GNAT_ADA_OBJS = \
ada/libgnat/s-memory.o \
ada/libgnat/s-os_lib.o \
ada/libgnat/s-parame.o \
ada/libgnat/s-pehage.o \
ada/libgnat/s-purexc.o \
ada/libgnat/s-restri.o \
ada/libgnat/s-secsta.o \
@ -585,7 +586,6 @@ GNATBIND_OBJS = \
ada/libgnat/s-exctab.o \
ada/libgnat/s-htable.o \
ada/libgnat/s-imenne.o \
ada/libgnat/s-imgenu.o \
ada/libgnat/s-imgint.o \
ada/libgnat/s-mastop.o \
ada/libgnat/s-memory.o \

6
gcc/ada/gnat1drv.adb
View File

@ -423,6 +423,12 @@ procedure Gnat1drv is
if Warning_Mode = Suppress then
Debug_Flag_MM := True;
end if;
-- The implementation of 'Value that uses a perfect hash function
-- is significantly more complex and harder to initialize than the
-- old implementation. Deactivate it for CodePeer.
Debug_Flag_Underscore_H := True;
end if;
-- Enable some individual switches that are implied by relaxed RM

10
gcc/ada/lib.adb
View File

@ -1266,10 +1266,16 @@ package body Lib is
-- Synchronize_Serial_Number --
-------------------------------
procedure Synchronize_Serial_Number is
procedure Synchronize_Serial_Number (SN : Nat) is
TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
begin
TSN := TSN + 1;
-- We should not be trying to synchronize downward
pragma Assert (TSN <= SN);
if TSN < SN then
TSN := SN;
end if;
end Synchronize_Serial_Number;
--------------------

12
gcc/ada/lib.ads
View File

@ -741,13 +741,13 @@ package Lib is
-- This procedure is called to register a pragma N for which a notes
-- entry is required.
procedure Synchronize_Serial_Number;
procedure Synchronize_Serial_Number (SN : Nat);
-- This function increments the Serial_Number field for the current unit
-- but does not return the incremented value. This is used when there
-- is a situation where one path of control increments a serial number
-- (using Increment_Serial_Number), and the other path does not and it is
-- important to keep the serial numbers synchronized in the two cases (e.g.
-- when the references in a package and a client must be kept consistent).
-- up to SN if it is initially lower and does nothing otherwise. This is
-- used in situations where one path of control increments serial numbers
-- and the other path does not and it is important to keep serial numbers
-- synchronized in the two cases (e.g. when the references in a package
-- and a client must be kept consistent).
procedure Unlock;
-- Unlock internal tables, in cases where the back end needs to modify them

2
gcc/ada/libgnat/g-heasor.ads
View File

@ -46,6 +46,8 @@
-- Note: GNAT.Heap_Sort replaces and obsoletes GNAT.Heap_Sort_A, which is
-- retained in the GNAT library for backwards compatibility.
pragma Compiler_Unit_Warning;
package GNAT.Heap_Sort is
pragma Pure;

2020
gcc/ada/libgnat/g-pehage.adb
View File

File diff suppressed because it is too large Load Diff

115
gcc/ada/libgnat/g-pehage.ads
View File

@ -64,8 +64,12 @@
-- < h (w2). These hashing functions are convenient for use with realtime
-- applications.
with System.Perfect_Hash_Generators;
package GNAT.Perfect_Hash_Generators is
package SPHG renames System.Perfect_Hash_Generators;
Default_K_To_V : constant Float := 2.05;
-- Default ratio for the algorithm. When K is the number of keys, V =
-- (K_To_V) * K is the size of the main table of the hash function. To
@ -83,12 +87,12 @@ package GNAT.Perfect_Hash_Generators is
-- try and may have to iterate a number of times. This constant bounds the
-- number of tries.
type Optimization is (Memory_Space, CPU_Time);
type Optimization is new SPHG.Optimization;
-- Optimize either the memory space or the execution time. Note: in
-- practice, the optimization mode has little effect on speed. The tables
-- are somewhat smaller with Memory_Space.
Verbose : Boolean := False;
Verbose : Boolean renames SPHG.Verbose;
-- Output the status of the algorithm. For instance, the tables, the random
-- graph (edges, vertices) and selected char positions are output between
-- two iterations.
@ -106,10 +110,10 @@ package GNAT.Perfect_Hash_Generators is
-- the same words.
--
-- A classical way of doing is to Insert all the words and then to invoke
-- Initialize and Compute. If Compute fails to find a perfect hash
-- function, invoke Initialize another time with other configuration
-- parameters (probably with a greater K_To_V ratio). Once successful,
-- invoke Produce and Finalize.
-- Initialize and Compute. If this fails to find a perfect hash function,
-- invoke Initialize again with other configuration parameters (probably
-- with a greater K_To_V ratio). Once successful, invoke Produce and then
-- Finalize.
procedure Finalize;
-- Deallocate the internal structures and the words table
@ -117,7 +121,7 @@ package GNAT.Perfect_Hash_Generators is
procedure Insert (Value : String);
-- Insert a new word into the table. ASCII.NUL characters are not allowed.
Too_Many_Tries : exception;
Too_Many_Tries : exception renames SPHG.Too_Many_Tries;
-- Raised after Tries unsuccessful runs
procedure Compute (Position : String := Default_Position);
@ -138,101 +142,4 @@ package GNAT.Perfect_Hash_Generators is
-- GNAT file name for a package named Pkg_Name. If Use_Stdout is True, the
-- output goes to standard output, and no files are written.
----------------------------------------------------------------
-- The routines and structures defined below allow producing the hash
-- function using a different way from the procedure above. The procedure
-- Define returns the lengths of an internal table and its item type size.
-- The function Value returns the value of each item in the table.
-- The hash function has the following form:
-- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
-- G is a function based on a graph table [0,n-1] -> [0,m-1]. m is the
-- number of keys. n is an internally computed value and it can be obtained
-- as the length of vector G.
-- F1 and F2 are two functions based on two function tables T1 and T2.
-- Their definition depends on the chosen optimization mode.
-- Only some character positions are used in the words because they are
-- significant. They are listed in a character position table (P in the
-- pseudo-code below). For instance, in {"jan", "feb", "mar", "apr", "jun",
-- "jul", "aug", "sep", "oct", "nov", "dec"}, only positions 2 and 3 are
-- significant (the first character can be ignored). In this example, P =
-- {2, 3}
-- When Optimization is CPU_Time, the first dimension of T1 and T2
-- corresponds to the character position in the word and the second to the
-- character set. As all the character set is not used, we define a used
-- character table which associates a distinct index to each used character
-- (unused characters are mapped to zero). In this case, the second
-- dimension of T1 and T2 is reduced to the used character set (C in the
-- pseudo-code below). Therefore, the hash function has the following:
-- function Hash (S : String) return Natural is
-- F : constant Natural := S'First - 1;
-- L : constant Natural := S'Length;
-- F1, F2 : Natural := 0;
-- J : <t>;
-- begin
-- for K in P'Range loop
-- exit when L < P (K);
-- J := C (S (P (K) + F));
-- F1 := (F1 + Natural (T1 (K, J))) mod <n>;
-- F2 := (F2 + Natural (T2 (K, J))) mod <n>;
-- end loop;
-- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
-- end Hash;
-- When Optimization is Memory_Space, the first dimension of T1 and T2
-- corresponds to the character position in the word and the second
-- dimension is ignored. T1 and T2 are no longer matrices but vectors.
-- Therefore, the used character table is not available. The hash function
-- has the following form:
-- function Hash (S : String) return Natural is
-- F : constant Natural := S'First - 1;
-- L : constant Natural := S'Length;
-- F1, F2 : Natural := 0;
-- J : <t>;
-- begin
-- for K in P'Range loop
-- exit when L < P (K);
-- J := Character'Pos (S (P (K) + F));
-- F1 := (F1 + Natural (T1 (K) * J)) mod <n>;
-- F2 := (F2 + Natural (T2 (K) * J)) mod <n>;
-- end loop;
-- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
-- end Hash;
type Table_Name is
(Character_Position,
Used_Character_Set,
Function_Table_1,
Function_Table_2,
Graph_Table);
procedure Define
(Name : Table_Name;
Item_Size : out Natural;
Length_1 : out Natural;
Length_2 : out Natural);
-- Return the definition of the table Name. This includes the length of
-- dimensions 1 and 2 and the size of an unsigned integer item. When
-- Length_2 is zero, the table has only one dimension. All the ranges
-- start from zero.
function Value
(Name : Table_Name;
J : Natural;
K : Natural := 0) return Natural;
-- Return the value of the component (I, J) of the table Name. When the
-- table has only one dimension, J is ignored.
end GNAT.Perfect_Hash_Generators;

2
gcc/ada/libgnat/g-table.ads
View File

@ -41,6 +41,8 @@
-- GNAT.Table
-- Table (the compiler unit)
pragma Compiler_Unit_Warning;
with GNAT.Dynamic_Tables;
generic

105
gcc/ada/libgnat/s-imgenu.adb → gcc/ada/libgnat/s-imagen.adb
View File

@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ E N U M --
-- S Y S T E M . I M A G E _ N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- Copyright (C) 2021, 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,24 +29,28 @@
-- --
------------------------------------------------------------------------------
pragma Compiler_Unit_Warning;
with Ada.Unchecked_Conversion;
package body System.Img_Enum is
package body System.Image_N is
-------------------------
-- Image_Enumeration_8 --
-------------------------
-----------------------
-- Image_Enumeration --
-----------------------
function Image_Enumeration_8
procedure Image_Enumeration
(Pos : Natural;
S : in out String;
P : out Natural;
Names : String;
Indexes : System.Address)
return String
is
type Natural_8 is range 0 .. 2 ** 7 - 1;
type Index_Table is array (Natural) of Natural_8;
pragma Assert (S'First = 1);
subtype Names_Index is
Index_Type range Index_Type (Names'First)
.. Index_Type (Names'Last) + 1;
subtype Index is Natural range Natural'First .. Names'Length;
type Index_Table is array (Index) of Names_Index;
type Index_Table_Ptr is access Index_Table;
function To_Index_Table_Ptr is
@ -54,75 +58,22 @@ package body System.Img_Enum is
IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
Start : constant Natural := Natural (IndexesT (Pos));
Next : constant Natural := Natural (IndexesT (Pos + 1));
subtype Result_Type is String (1 .. Next - Start);
-- We need this result type to force the result to have the
-- required lower bound of 1, rather than the slice bounds.
begin
return Result_Type (Names (Start .. Next - 1));
end Image_Enumeration_8;
--------------------------
-- Image_Enumeration_16 --
--------------------------
function Image_Enumeration_16
(Pos : Natural;
Names : String;
Indexes : System.Address)
return String
is
type Natural_16 is range 0 .. 2 ** 15 - 1;
type Index_Table is array (Natural) of Natural_16;
type Index_Table_Ptr is access Index_Table;
function To_Index_Table_Ptr is
new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
pragma Assert (Pos in IndexesT'Range);
pragma Assert (Pos + 1 in IndexesT'Range);
Start : constant Natural := Natural (IndexesT (Pos));
Next : constant Natural := Natural (IndexesT (Pos + 1));
subtype Result_Type is String (1 .. Next - Start);
-- We need this result type to force the result to have the
-- required lower bound of 1, rather than the slice bounds.
pragma Assert (Next - 1 >= Start);
pragma Assert (Start >= Names'First);
pragma Assert (Next - 1 <= Names'Last);
pragma Assert (Next - Start <= S'Last);
-- The caller should guarantee that S is large enough to contain the
-- enumeration image.
begin
return Result_Type (Names (Start .. Next - 1));
end Image_Enumeration_16;
S (1 .. Next - Start) := Names (Start .. Next - 1);
P := Next - Start;
end Image_Enumeration;
--------------------------
-- Image_Enumeration_32 --
--------------------------
function Image_Enumeration_32
(Pos : Natural;
Names : String;
Indexes : System.Address)
return String
is
type Natural_32 is range 0 .. 2 ** 31 - 1;
type Index_Table is array (Natural) of Natural_32;
type Index_Table_Ptr is access Index_Table;
function To_Index_Table_Ptr is
new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
Start : constant Natural := Natural (IndexesT (Pos));
Next : constant Natural := Natural (IndexesT (Pos + 1));
subtype Result_Type is String (1 .. Next - Start);
-- We need this result type to force the result to have the
-- required lower bound of 1, rather than the slice bounds.
begin
return Result_Type (Names (Start .. Next - 1));
end Image_Enumeration_32;
end System.Img_Enum;
end System.Image_N;

49
gcc/ada/libgnat/s-imgenu.ads → gcc/ada/libgnat/s-imagen.ads
View File

@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ E N U M --
-- S Y S T E M . I M A G E _ N --
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- Copyright (C) 2021, 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- --
@ -34,45 +34,30 @@
-- package System (where it is too early to start building image tables).
-- Special routines exist for the enumeration types in these packages.
-- Note: this is an obsolete package, replaced by System.Img_Enum_New, which
-- provides procedures instead of functions for these enumeration image calls.
-- The reason we maintain this package is that when bootstrapping with old
-- compilers, the old compiler will search for this unit, expecting to find
-- these functions. The new compiler will search for procedures in the new
-- version of the unit.
generic
pragma Compiler_Unit_Warning;
type Index_Type is range <>;
package System.Img_Enum is
package System.Image_N is
pragma Pure;
function Image_Enumeration_8
procedure Image_Enumeration
(Pos : Natural;
S : in out String;
P : out Natural;
Names : String;
Indexes : System.Address) return String;
Indexes : System.Address);
-- Used to compute Enum'Image (Str) where Enum is some enumeration type
-- other than those defined in package Standard. Names is a string with a
-- lower bound of 1 containing the characters of all the enumeration
-- literals concatenated together in sequence. Indexes is the address of an
-- array of type array (0 .. N) of Natural_8, where N is the number of
-- other than those defined in package Standard. Names is a string with
-- a lower bound of 1 containing the characters of all the enumeration
-- literals concatenated together in sequence. Indexes is the address of
-- an array of type array (0 .. N) of Index_Type, where N is the number of
-- enumeration literals in the type. The Indexes values are the starting
-- subscript of each enumeration literal, indexed by Pos values, with an
-- extra entry at the end containing Names'Length + 1. The reason that
-- Indexes is passed by address is that the actual type is created on the
-- fly by the expander. The value returned is the desired 'Image value.
-- fly by the expander. The desired 'Image value is stored in S (1 .. P)
-- and P is set on return. The caller guarantees that S is long enough to
-- hold the result and that the lower bound is 1.
function Image_Enumeration_16
(Pos : Natural;
Names : String;
Indexes : System.Address) return String;
-- Identical to Image_Enumeration_8 except that it handles types
-- using array (0 .. Num) of Natural_16 for the Indexes table.
function Image_Enumeration_32
(Pos : Natural;
Names : String;
Indexes : System.Address) return String;
-- Identical to Image_Enumeration_8 except that it handles types
-- using array (0 .. Num) of Natural_32 for the Indexes table.
end System.Img_Enum;
end System.Image_N;

51
gcc/ada/libgnat/s-imen16.ads Normal file
View File

@ -0,0 +1,51 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ E N U M _ 1 6 --
-- --
-- S p e c --
-- --
-- Copyright (C) 2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Instantiation of System.Image_N for enumeration types whose names table
-- has a length that fits in a 16-bit but not a 8-bit integer.
with Interfaces;
with System.Image_N;
package System.Img_Enum_16 is
pragma Pure;
package Impl is new Image_N (Interfaces.Integer_16);
procedure Image_Enumeration_16
(Pos : Natural;
S : in out String;
P : out Natural;
Names : String;
Indexes : System.Address)
renames Impl.Image_Enumeration;
end System.Img_Enum_16;

51
gcc/ada/libgnat/s-imen32.ads Normal file
View File

@ -0,0 +1,51 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ E N U M _ 3 2 --
-- --
-- S p e c --
-- --
-- Copyright (C) 2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Instantiation of System.Image_N for enumeration types whose names table
-- has a length that fits in a 32-bit but not a 16-bit integer.
with Interfaces;
with System.Image_N;
package System.Img_Enum_32 is
pragma Pure;
package Impl is new Image_N (Interfaces.Integer_32);
procedure Image_Enumeration_32
(Pos : Natural;
S : in out String;
P : out Natural;
Names : String;
Indexes : System.Address)
renames Impl.Image_Enumeration;
end System.Img_Enum_32;

10
gcc/ada/libgnat/s-imenne.ads
View File

@ -34,11 +34,11 @@
-- package System (where it is too early to start building image tables).
-- Special routines exist for the enumeration types in these packages.
-- This is the new version of the package, for use by compilers built after
-- Nov 21st, 2007, which provides procedures that avoid using the secondary
-- stack. The original package System.Img_Enum is maintained in the sources
-- for bootstrapping with older versions of the compiler which expect to find
-- functions in this package.
-- Note: this is an obsolete package replaced by instantiations of the generic
-- package System.Image_N. The reason we maintain this package is that when
-- bootstrapping with an old compiler, the old compiler will search for this
-- unit, expecting to find these functions. The new compiler will search for
-- procedures in the instances of System.Image_N instead.
pragma Compiler_Unit_Warning;

51
gcc/ada/libgnat/s-imenu8.ads Normal file
View File

@ -0,0 +1,51 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ E N U M _ 8 --
-- --
-- S p e c --
-- --
-- Copyright (C) 2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Instantiation of System.Image_N for enumeration types whose names table
-- has a length that fits in a 8-bit integer.
with Interfaces;
with System.Image_N;
package System.Img_Enum_8 is
pragma Pure;
package Impl is new Image_N (Interfaces.Integer_8);
procedure Image_Enumeration_8
(Pos : Natural;
S : in out String;
P : out Natural;
Names : String;
Indexes : System.Address)
renames Impl.Image_Enumeration;
end System.Img_Enum_8;

2235
gcc/ada/libgnat/s-pehage.adb Normal file
View File

File diff suppressed because it is too large Load Diff

212
gcc/ada/libgnat/s-pehage.ads Normal file
View File

@ -0,0 +1,212 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . P E R F E C T _ H A S H _ G E N E R A T O R S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides a generator of static minimal perfect hash functions.
-- To understand what a perfect hash function is, we define several notions.
-- These definitions are inspired from the following paper:
-- Zbigniew J. Czech, George Havas, and Bohdan S. Majewski ``An Optimal
-- Algorithm for Generating Minimal Perfect Hash Functions'', Information
-- Processing Letters, 43(1992) pp.257-264, Oct.1992
-- Let W be a set of m words. A hash function h is a function that maps the
-- set of words W into some given interval I of integers [0, k-1], where k is
-- an integer, usually k >= m. h (w) where w is a word in W computes an
-- address or an integer from I for the storage or the retrieval of that
-- item. The storage area used to store items is known as a hash table. Words
-- for which the same address is computed are called synonyms. Due to the
-- existence of synonyms a situation called collision may arise in which two
-- items w1 and w2 have the same address. Several schemes for resolving
-- collisions are known. A perfect hash function is an injection from the word
-- set W to the integer interval I with k >= m. If k = m, then h is a minimal
-- perfect hash function. A hash function is order preserving if it puts
-- entries into the hash table in a prespecified order.
-- A minimal perfect hash function is defined by two properties:
-- Since no collisions occur each item can be retrieved from the table in
-- *one* probe. This represents the "perfect" property.
-- The hash table size corresponds to the exact size of W and *no larger*.
-- This represents the "minimal" property.
-- The functions generated by this package require the words to be known in
-- advance (they are "static" hash functions). The hash functions are also
-- order preserving. If w2 is inserted after w1 in the generator, then h (w1)
-- < h (w2). These hashing functions are convenient for use with realtime
-- applications.
pragma Compiler_Unit_Warning;
package System.Perfect_Hash_Generators is
type Optimization is (Memory_Space, CPU_Time);
-- Optimize either the memory space or the execution time. Note: in
-- practice, the optimization mode has little effect on speed. The tables
-- are somewhat smaller with Memory_Space.
Verbose : Boolean := False;
-- Output the status of the algorithm. For instance, the tables, the random
-- graph (edges, vertices) and selected char positions are output between
-- two iterations.
procedure Initialize
(Seed : Natural;
V : Positive;
Optim : Optimization;
Tries : Positive);
-- Initialize the generator and its internal structures. Set the number of
-- vertices in the random graphs. This value has to be greater than twice
-- the number of keys in order for the algorithm to succeed. The word set
-- is not modified (in particular when it is already set). For instance, it
-- is possible to run several times the generator with different settings
-- on the same words.
--
-- A classical way of doing is to Insert all the words and then to invoke
-- Initialize and Compute. If this fails to find a perfect hash function,
-- invoke Initialize again with other configuration parameters (probably
-- with a greater number of vertices). Once successful, invoke Define and
-- Value, and then Finalize.
procedure Finalize;
-- Deallocate the internal structures and the words table
procedure Insert (Value : String);
-- Insert a new word into the table. ASCII.NUL characters are not allowed.
Too_Many_Tries : exception;
-- Raised after Tries unsuccessful runs
procedure Compute (Position : String);
-- Compute the hash function. Position allows the definition of selection
-- of character positions used in the word hash function. Positions can be
-- separated by commas and ranges like x-y may be used. Character '$'
-- represents the final character of a word. With an empty position, the
-- generator automatically produces positions to reduce the memory usage.
-- Raise Too_Many_Tries if the algorithm does not succeed within Tries
-- attempts (see Initialize).
-- The procedure Define returns the lengths of an internal table and its
-- item type size. The function Value returns the value of each item in
-- the table. Together they can be used to retrieve the parameters of the
-- hash function which has been computed by a call to Compute.
-- The hash function has the following form:
-- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
-- G is a function based on a graph table [0,n-1] -> [0,m-1]. m is the
-- number of keys. n is an internally computed value and it can be obtained
-- as the length of vector G.
-- F1 and F2 are two functions based on two function tables T1 and T2.
-- Their definition depends on the chosen optimization mode.
-- Only some character positions are used in the words because they are
-- significant. They are listed in a character position table (P in the
-- pseudo-code below). For instance, in {"jan", "feb", "mar", "apr", "jun",
-- "jul", "aug", "sep", "oct", "nov", "dec"}, only positions 2 and 3 are
-- significant (the first character can be ignored). In this example, P =
-- {2, 3}
-- When Optimization is CPU_Time, the first dimension of T1 and T2
-- corresponds to the character position in the word and the second to the
-- character set. As all the character set is not used, we define a used
-- character table which associates a distinct index to each used character
-- (unused characters are mapped to zero). In this case, the second
-- dimension of T1 and T2 is reduced to the used character set (C in the
-- pseudo-code below). Therefore, the hash function has the following:
-- function Hash (S : String) return Natural is
-- F : constant Natural := S'First - 1;
-- L : constant Natural := S'Length;
-- F1, F2 : Natural := 0;
-- J : <t>;
-- begin
-- for K in P'Range loop
-- exit when L < P (K);
-- J := C (S (P (K) + F));
-- F1 := (F1 + Natural (T1 (K, J))) mod <n>;
-- F2 := (F2 + Natural (T2 (K, J))) mod <n>;
-- end loop;
-- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
-- end Hash;
-- When Optimization is Memory_Space, the first dimension of T1 and T2
-- corresponds to the character position in the word and the second
-- dimension is ignored. T1 and T2 are no longer matrices but vectors.
-- Therefore, the used character table is not available. The hash function
-- has the following form:
-- function Hash (S : String) return Natural is
-- F : constant Natural := S'First - 1;
-- L : constant Natural := S'Length;
-- F1, F2 : Natural := 0;
-- J : <t>;
-- begin
-- for K in P'Range loop
-- exit when L < P (K);
-- J := Character'Pos (S (P (K) + F));
-- F1 := (F1 + Natural (T1 (K) * J)) mod <n>;
-- F2 := (F2 + Natural (T2 (K) * J)) mod <n>;
-- end loop;
-- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
-- end Hash;
type Table_Name is
(Character_Position,
Used_Character_Set,
Function_Table_1,
Function_Table_2,
Graph_Table);
procedure Define
(Name : Table_Name;
Item_Size : out Natural;
Length_1 : out Natural;
Length_2 : out Natural);
-- Return the definition of the table Name. This includes the length of
-- dimensions 1 and 2 and the size of an unsigned integer item. When
-- Length_2 is zero, the table has only one dimension. All the ranges
-- start from zero.
function Value
(Name : Table_Name;
J : Natural;
K : Natural := 0) return Natural;
-- Return the value of the component (J, K) of the table Name. When the
-- table has only one dimension, K is ignored.
end System.Perfect_Hash_Generators;

52
gcc/ada/libgnat/s-vaen16.ads Normal file
View File

@ -0,0 +1,52 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . V A L _ E N U M _ 1 6 --
-- --
-- S p e c --
-- --
-- Copyright (C) 2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Instantiation of System.Value_N for enumeration types whose names table
-- has a length that fits in a 16-bit but not a 8-bit integer.
with Interfaces;
with System.Value_N;
package System.Val_Enum_16 is
pragma Preelaborate;
package Impl is new Value_N (Interfaces.Integer_16);
function Value_Enumeration_16
(Names : String;
Indexes : System.Address;
Hash : Impl.Hash_Function_Ptr;
Num : Natural;
Str : String)
return Natural
renames Impl.Value_Enumeration;
end System.Val_Enum_16;

52
gcc/ada/libgnat/s-vaen32.ads Normal file
View File

@ -0,0 +1,52 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . V A L _ E N U M _ 3 2 --
-- --
-- S p e c --
-- --
-- Copyright (C) 2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Instantiation of System.Value_N for enumeration types whose names table
-- has a length that fits in a 32-bit but not a 16-bit integer.
with Interfaces;
with System.Value_N;
package System.Val_Enum_32 is
pragma Preelaborate;
package Impl is new Value_N (Interfaces.Integer_32);
function Value_Enumeration_32
(Names : String;
Indexes : System.Address;
Hash : Impl.Hash_Function_Ptr;
Num : Natural;
Str : String)
return Natural
renames Impl.Value_Enumeration;
end System.Val_Enum_32;

52
gcc/ada/libgnat/s-vaenu8.ads Normal file
View File

@ -0,0 +1,52 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . V A L _ E N U M _ 8 --
-- --
-- S p e c --
-- --
-- Copyright (C) 2021, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Instantiation of System.Value_N for enumeration types whose names table
-- has a length that fits in a 8-bit integer.
with Interfaces;
with System.Value_N;
package System.Val_Enum_8 is
pragma Preelaborate;
package Impl is new Value_N (Interfaces.Integer_8);
function Value_Enumeration_8
(Names : String;
Indexes : System.Address;
Hash : Impl.Hash_Function_Ptr;
Num : Natural;
Str : String)
return Natural
renames Impl.Value_Enumeration;
end System.Val_Enum_8;

131
gcc/ada/libgnat/s-valenu.adb → gcc/ada/libgnat/s-valuen.adb
View File

@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . V A L _ E N U M --
-- S Y S T E M . V A L U E _ N --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- Copyright (C) 2021, 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- --
@ -33,25 +33,30 @@ with Ada.Unchecked_Conversion;
with System.Val_Util; use System.Val_Util;
package body System.Val_Enum is
package body System.Value_N is
-------------------------
-- Value_Enumeration_8 --
-------------------------
-----------------------
-- Value_Enumeration --
-----------------------
function Value_Enumeration_8
function Value_Enumeration
(Names : String;
Indexes : System.Address;
Hash : Hash_Function_Ptr;
Num : Natural;
Str : String)
return Natural
is
F : Natural;
L : Natural;
H : Natural;
S : String (Str'Range) := Str;
type Natural_8 is range 0 .. 2 ** 7 - 1;
type Index_Table is array (Natural) of Natural_8;
subtype Names_Index is
Index_Type range Index_Type (Names'First)
.. Index_Type (Names'Last) + 1;
subtype Index is Natural range Natural'First .. Names'Length;
type Index_Table is array (Index) of Names_Index;
type Index_Table_Ptr is access Index_Table;
function To_Index_Table_Ptr is
@ -59,97 +64,37 @@ package body System.Val_Enum is
IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
begin
Normalize_String (S, F, L);
for J in 0 .. Num loop
if Names
(Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1) = S (F .. L)
then
return J;
end if;
end loop;
Bad_Value (Str);
end Value_Enumeration_8;
--------------------------
-- Value_Enumeration_16 --
--------------------------
function Value_Enumeration_16
(Names : String;
Indexes : System.Address;
Num : Natural;
Str : String)
return Natural
is
F : Natural;
L : Natural;
S : String (Str'Range) := Str;
type Natural_16 is range 0 .. 2 ** 15 - 1;
type Index_Table is array (Natural) of Natural_16;
type Index_Table_Ptr is access Index_Table;
function To_Index_Table_Ptr is
new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
pragma Assert (Num + 1 in IndexesT'Range);
begin
Normalize_String (S, F, L);
for J in 0 .. Num loop
-- If we have a valid hash value, do a single lookup
H := (if Hash /= null then Hash.all (S (F .. L)) else Natural'Last);
if H /= Natural'Last then
if Names
(Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1) = S (F .. L)
(Natural (IndexesT (H)) ..
Natural (IndexesT (H + 1)) - 1) = S (F .. L)
then
return J;
return H;
end if;
end loop;
-- Otherwise do a linear search
else
for J in 0 .. Num loop
if Names
(Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1) = S (F .. L)
then
return J;
end if;
end loop;
end if;
Bad_Value (Str);
end Value_Enumeration_16;
end Value_Enumeration;
--------------------------
-- Value_Enumeration_32 --
--------------------------
function Value_Enumeration_32
(Names : String;
Indexes : System.Address;
Num : Natural;
Str : String)
return Natural
is
F : Natural;
L : Natural;
S : String (Str'Range) := Str;
type Natural_32 is range 0 .. 2 ** 31 - 1;
type Index_Table is array (Natural) of Natural_32;
type Index_Table_Ptr is access Index_Table;
function To_Index_Table_Ptr is
new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
begin
Normalize_String (S, F, L);
for J in 0 .. Num loop
if Names
(Natural (IndexesT (J)) ..
Natural (IndexesT (J + 1)) - 1) = S (F .. L)
then
return J;
end if;
end loop;
Bad_Value (Str);
end Value_Enumeration_32;
end System.Val_Enum;
end System.Value_N;

38
gcc/ada/libgnat/s-valenu.ads → gcc/ada/libgnat/s-valuen.ads
View File

@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . V A L _ E N U M --
-- S Y S T E M . V A L U E _ N --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- Copyright (C) 2021, 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- --
@ -33,12 +33,19 @@
-- other than those in packages Standard and System. See unit Exp_Imgv for
-- details of the format of constructed image tables.
package System.Val_Enum is
generic
type Index_Type is range <>;
package System.Value_N is
pragma Preelaborate;
function Value_Enumeration_8
type Hash_Function_Ptr is access function (S : String) return Natural;
function Value_Enumeration
(Names : String;
Indexes : System.Address;
Hash : Hash_Function_Ptr;
Num : Natural;
Str : String)
return Natural;
@ -46,10 +53,11 @@ package System.Val_Enum is
-- other than those defined in package Standard. Names is a string with
-- a lower bound of 1 containing the characters of all the enumeration
-- literals concatenated together in sequence. Indexes is the address
-- of an array of type array (0 .. N) of Natural_8, where N is the
-- of an array of type array (0 .. N) of Index_Type, where N is the
-- number of enumeration literals in the type. The Indexes values are
-- the starting subscript of each enumeration literal, indexed by Pos
-- values, with an extra entry at the end containing Names'Length + 1.
-- The parameter Hash is a (perfect) hash function for Names and Indexes.
-- The parameter Num is the value N - 1 (i.e. Enum'Pos (Enum'Last)).
-- The reason that Indexes is passed by address is that the actual type
-- is created on the fly by the expander.
@ -59,22 +67,4 @@ package System.Val_Enum is
-- If the image is found in Names, then the corresponding Pos value is
-- returned. If not, Constraint_Error is raised.
function Value_Enumeration_16
(Names : String;
Indexes : System.Address;
Num : Natural;
Str : String)
return Natural;
-- Identical to Value_Enumeration_8 except that it handles types
-- using array (0 .. Num) of Natural_16 for the Indexes table.
function Value_Enumeration_32
(Names : String;
Indexes : System.Address;
Num : Natural;
Str : String)
return Natural;
-- Identical to Value_Enumeration_8 except that it handles types
-- using array (0 .. Num) of Natural_32 for the Indexes table.
end System.Val_Enum;
end System.Value_N;

25
gcc/ada/rtsfind.ads
View File

@ -259,8 +259,9 @@ package Rtsfind is
System_Img_Decimal_32,
System_Img_Decimal_64,
System_Img_Decimal_128,
System_Img_Enum,
System_Img_Enum_New,
System_Img_Enum_8,
System_Img_Enum_16,
System_Img_Enum_32,
System_Img_Fixed_32,
System_Img_Fixed_64,
System_Img_Fixed_128,
@ -430,7 +431,9 @@ package Rtsfind is
System_Val_Decimal_32,
System_Val_Decimal_64,
System_Val_Decimal_128,
System_Val_Enum,
System_Val_Enum_8,
System_Val_Enum_16,
System_Val_Enum_32,
System_Val_Fixed_32,
System_Val_Fixed_64,
System_Val_Fixed_128,
@ -2663,9 +2666,11 @@ package Rtsfind is
RE_Image_Decimal128 => System_Img_Decimal_128,
RE_Image_Enumeration_8 => System_Img_Enum_New,
RE_Image_Enumeration_16 => System_Img_Enum_New,
RE_Image_Enumeration_32 => System_Img_Enum_New,
RE_Image_Enumeration_8 => System_Img_Enum_8,
RE_Image_Enumeration_16 => System_Img_Enum_16,
RE_Image_Enumeration_32 => System_Img_Enum_32,
RE_Image_Float => System_Img_Flt,
@ -3720,9 +3725,11 @@ package Rtsfind is
RE_Value_Decimal128 => System_Val_Decimal_128,
RE_Value_Enumeration_8 => System_Val_Enum,
RE_Value_Enumeration_16 => System_Val_Enum,
RE_Value_Enumeration_32 => System_Val_Enum,
RE_Value_Enumeration_8 => System_Val_Enum_8,
RE_Value_Enumeration_16 => System_Val_Enum_16,
RE_Value_Enumeration_32 => System_Val_Enum_32,
RE_Value_Fixed32 => System_Val_Fixed_32,

9
gcc/ada/sem_attr.adb
View File

@ -834,10 +834,13 @@ package body Sem_Attr is
begin
-- Access and Unchecked_Access are illegal in declare_expressions,
-- according to the RM. We also make the GNAT-specific
-- Unrestricted_Access attribute illegal.
-- according to the RM. We also make the GNAT Unrestricted_Access
-- attribute illegal if it comes from source.
if In_Declare_Expr > 0 then
if In_Declare_Expr > 0
and then (Attr_Id /= Attribute_Unrestricted_Access
or else Comes_From_Source (N))
then
Error_Attr ("% attribute cannot occur in a declare_expression", N);
end if;