procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] Basic support for 128-bit types

Browse source 
gcc/ada/

	* Makefile.rtl (GNATRTL_128BIT_PAIRS): New variable.
	(GNATRTL_128BIT_OBJS): Likewise.
	(Windows): In 64-bit mode, add the former to LIBGNAT_TARGET_PAIRS and
	the latter to EXTRA_GNATRTL_NONTASKING_OBJS.
	(x86_64/linux): Likewise, but unconditionally.
	(GNATRTL_NONTASKING_OBJS): Add s-aridou, s-exponn, s-expont,
	s-exponu.
	* ada_get_targ.adb (Get_Long_Long_Long_Size): New function.
	* checks.adb (Apply_Arithmetic_Overflow_Strict): Use Integer_Type_For
	to find an appropriate integer type; if it does not exist and the max
	integer size is larger than 64, use the 128-bit arithmetic routines.
	* cstand.adb (Create_Standard): Build Standard_Long_Long_Long_Integer
	and its base type.  Use it for Etype of Any_Integer, Any_Modular and
	Any_Numeric.  Use its size for Build Standard_Long_Long_Long_Unsigned
	and Universal_Integer.
	(Print_Standard): Print Long_Long_Long_Integer.
	* exp_attr.adb (Expand_N_Attribute_Reference) <Attribute_Mod>: Adjust
	comment.
	* exp_ch3.adb (Simple_Init_Initialize_Scalars_Type): Deal with 128-bit
	types.
	* exp_ch4.adb (Expand_Array_Comparison): Likewise.
	(Expand_N_Op_Expon): Likewise.
	(Narrow_Large_Operation): Likewise.
	* exp_dbug.adb (Bounds_Match_Size): Handle 128-bit size.
	* exp_fixd.adb (Build_Double_Divide_Code): Use RE_Double_Divide64.
	* exp_intr.adb (Expand_Binary_Operator_Call): Handle 128-bit size.
	* exp_pakd.ads (E_Array): Extend range to 127.
	(Bits_Id): Fill in up to 127.
	(Get_Id): Likewise.
	(GetU_Id): Likewise.
	(Set_Id): Likewise.
	(SetU_Id): Likewise.
	* exp_pakd.adb (Revert_Storage_Order): Handle 128-bit size.
	* exp_util.adb (Integer_Type_For): Likewise.
	(Small_Integer_Type_For): Likewise.
	* fname.adb (Is_Predefined_File_Name): Do not return False for names
	larger than 12 characters if they start with "s-".
	* freeze.adb (Adjust_Esize_For_Alignment): Change the maximum value
	to System_Max_Integer_Size.
	(Check_Suspicious_Modulus): Adjust comment.
	(Freeze_Entity): Likewise.
	* get_targ.ads (Get_Long_Long_Long_Size): New function.
	* get_targ.adb (Get_Long_Long_Long_Size): Likewise.
	(Width_From_Size): Deal with 128-bit size.
	* gnat1drv.adb (Adjust_Global_Switches): Deal with 128-bit types.
	* impunit.adb (Get_Kind_Of_File): Bump buffer size.  Accept files with
	13 characters if they start with 's'.  Compare slice of Buffer.
	(Not_Impl_Defined_Unit): Accept files with 13 characters if they start
	with 's'.
	* krunch.ads: Document length for 128-bit support units.
	* krunch.adb (Krunch): Set length to 9 for 128-bit support units.
	* layout.adb (Layout_Type): Use System_Max_Integer_Size as alignment
	limit.
	* rtsfind.ads (RTU_Id): Add System_Arith_128,
	System_Compare_Array_Signed_128, System_Compare_Array_Unsigned_128,
	System_Exn_LLLI, System_Exp_LLLU, System_Pack_[65..127].
	(RE_Id): Add RE_Integer_128, RE_Unsigned_128, RE_Add_With_Ovflo_Check128
	RE_Multiply_With_Ovflo_Check128, RE_Subtract_With_Ovflo_Check128,
	RE_Bswap_128, RE_Compare_Array_S128, RE_Compare_Array_U128,
	RE_Exn_Long_Long_Long_Integer, RE_Exp_Long_Long_Long_Integer,
	RE_Exp_Long_Long_Long_Unsigned, RE_Bits_[65-127], RE_Get_[65-127],
	RE_Set_[65-127], RE_IS_Is16, RE_IS_Iu16, RE_Integer_128 and
	RE_Unsigned_128.  Rename RE_Add_With_Ovflo_Check, RE_Double_Divide,
	RE_Multiply_With_Ovflo_Check, RE_Scaled_Divide and
	RE_Subtract_With_Ovflo_Check.  Remove RE_IS_Iz1, RE_IS_Iz2, RE_IS_Iz4,
	RE_IS_Iz8, RE_Long_Unsigned, RE_Short_Unsigned, RE_Short_Short_Unsigned
	(RE_Unit_Table): Likewise.
	* sem_aux.adb (Corresponding_Unsigned_Type): Deal with a size equal to
	that of Standard_Long_Long_Long_Integer.
	(First_Subtype): Deal with Standard_Long_Long_Long_Integer'Base.
	* sem_ch13.adb (Analyze_Attribute_Definition_Clause) <Attribute_Size>:
	Check the size against powers of 2 and System_Max_Integer_Size for
	objects as well.
	(Set_Enum_Esize): Deal with 128-bit bounds.
	* sem_ch3.adb (Set_Modular_Size): Handle 128-bit size.
	(Modular_Type_Declaration): Deal with 128-bit types.
	(Signed_Integer_Type_Declaration): Support derivation from
	Standard_Long_Long_Long_Integer.
	* sem_ch4.adb (Analyze_Mod): Handle 128-bit modulus.
	* sem_intr.adb: Add with and use clauses for Ttypes.
	(Check_Shift): Handle 128-bit size and modulus.
	* sem_prag.adb (Analyze_Pragma) <Pragma_Initialize_Scalars>: Deal
	with Signed_128 and Unsigned_128.
	(Analyze_Integer_Value): Handle 128-bit size.
	* sem_util.ads (Addressable): Adjust description.
	* sem_util.adb (Addressable): Return true for 128 if the system
	supports 128 bits.
	(Set_Invalid_Binder_Values): Deal with Signed_128 and Unsigned_128.
	* set_targ.ads (Long_Long_Long_Size): New variable.
	* set_targ.adb (S_Long_Long_Long_Size): New constant.
	(DTN): Add entry for S_Long_Long_Long_Size.
	(DTV): Add entry for Long_Long_Long_Size.
	(Set_Targ): Set Long_Long_Long_Size.
	* snames.ads-tmpl (Name_Max_Integer_Size): New attribute name.
	(Name_Signed_128): New scalar name.
	(Name_Unsigned_128): Likewise.
	(Scalar_Id): Adjust.
	(Integer_Scalar_Id): Likewise.
	(Attribute_Id): Add Attribute_Max_Integer_Size.
	* stand.ads (Standard_Entity_Type): Add S_Long_Long_Long_Integer.
	(Standard_Long_Long_Long_Integer): New renaming.
	(Universal_Integer): Adjust description.
	(Standard_Long_Long_Long_Unsigned): New variable.
	* switch-c.adb (Scan_Front_End_Switches): Deal with -gnate128.
	* ttypes.ads (Standard_Long_Long_Long_Integer_Size): New variable.
	(Standard_Long_Long_Long_Integer_Width): Likewise.
	(System_Max_Integer_Size): Turn into variable.
	(System_Max_Binary_Modulus_Power): Likewise.
	* uintp.ads (Uint_127): New constant.
	* uintp.adb (UI_Power_2): Extednd to 128.
	(UI_Power_10): Likewise.
	(UI_Expon): Deal with exponent up to 128 specially.
	* usage.adb (Write_Switch_Char): Print -gnate128 switch.
	* libgnat/a-tifiio.adb (Put_Scaled): Call Scaled_Divide64.
	* libgnat/interfac__2020.ads (Integer_128): New integer type.
	(Unsigned_128): New modular type.
	(Shift_Left, Shift_Right, Shift_Right_Arithmetic, Rotate_Left,
	Rotate_Right): New intrinsic functions operating on it.
	* libgnat/s-aridou.ads, libgnat/s-aridou.adb: New generic
	package.
	* libgnat/s-arit64.ads, libgnat/s-arit64.adb: Instantiate
	System.Arithmetic_Double.
	* libgnat/s-arit128.ads, libgnat/s-arit128.adb: Likewise.
	* libgnat/s-bytswa.ads: Add with clause for Interfaces, use subtypes
	of unsigned types defined in Interfaces and add Bswap_128.
	* libgnat/s-casi128.ads, libgnat/s-casi128.adb: New package.
	* libgnat/s-caun128.ads, libgnat/s-caun128.adb: Likewise.
	* libgnat/s-exnint.ads: Instantiate System.Exponn.
	* libgnat/s-exnint.adb: Add pragma No_Body.
	* libgnat/s-exnlli.ads: Instantiate System.Exponn.
	* libgnat/s-exnlli.adb: Add pragma No_Body.
	* libgnat/s-exnllli.ads: Instantiate System.Exponn.
	* libgnat/s-expint.ads: Likewise.
	* libgnat/s-expint.adb: Add pragma No_Body.
	* libgnat/s-explli.ads: Instantiate System.Exponn.
	* libgnat/s-explli.adb: Add pragma No_Body.
	* libgnat/s-expllli.ads: Instantiate System.Exponn.
	* libgnat/s-explllu.ads: Instantiate System.Exponu.
	* libgnat/s-expllu.ads: Likewise.
	* libgnat/s-expllu.adb: Add pragma No_Body.
	* libgnat/s-exponn.ads, libgnat/s-exponn.adb: New generic
	function.
	* libgnat/s-expont.ads, libgnat/s-expont.adb: Likewise.
	* libgnat/s-exponu.ads, libgnat/s-exponu.adb: Likewise.
	* libgnat/s-expuns.ads, libgnat/s-expuns.adb: Likewise.
	* libgnat/s-pack65.ads, libgnat/s-pack65.adb: New package.
	* libgnat/s-pack66.ads, libgnat/s-pack66.adb: New package.
	* libgnat/s-pack67.ads, libgnat/s-pack67.adb: New package.
	* libgnat/s-pack68.ads, libgnat/s-pack68.adb: New package.
	* libgnat/s-pack69.ads, libgnat/s-pack69.adb: New package.
	* libgnat/s-pack70.ads, libgnat/s-pack70.adb: New package.
	* libgnat/s-pack71.ads, libgnat/s-pack71.adb: New package.
	* libgnat/s-pack72.ads, libgnat/s-pack72.adb: New package.
	* libgnat/s-pack73.ads, libgnat/s-pack73.adb: New package.
	* libgnat/s-pack74.ads, libgnat/s-pack74.adb: New package.
	* libgnat/s-pack75.ads, libgnat/s-pack75.adb: New package.
	* libgnat/s-pack76.ads, libgnat/s-pack76.adb: New package.
	* libgnat/s-pack77.ads, libgnat/s-pack77.adb: New package.
	* libgnat/s-pack78.ads, libgnat/s-pack78.adb: New package.
	* libgnat/s-pack79.ads, libgnat/s-pack79.adb: New package.
	* libgnat/s-pack80.ads, libgnat/s-pack80.adb: New package.
	* libgnat/s-pack81.ads, libgnat/s-pack81.adb: New package.
	* libgnat/s-pack82.ads, libgnat/s-pack82.adb: New package.
	* libgnat/s-pack83.ads, libgnat/s-pack83.adb: New package.
	* libgnat/s-pack84.ads, libgnat/s-pack84.adb: New package.
	* libgnat/s-pack85.ads, libgnat/s-pack85.adb: New package.
	* libgnat/s-pack86.ads, libgnat/s-pack86.adb: New package.
	* libgnat/s-pack87.ads, libgnat/s-pack87.adb: New package.
	* libgnat/s-pack88.ads, libgnat/s-pack88.adb: New package.
	* libgnat/s-pack89.ads, libgnat/s-pack89.adb: New package.
	* libgnat/s-pack90.ads, libgnat/s-pack90.adb: New package.
	* libgnat/s-pack91.ads, libgnat/s-pack91.adb: New package.
	* libgnat/s-pack92.ads, libgnat/s-pack92.adb: New package.
	* libgnat/s-pack93.ads, libgnat/s-pack93.adb: New package.
	* libgnat/s-pack94.ads, libgnat/s-pack94.adb: New package.
	* libgnat/s-pack95.ads, libgnat/s-pack95.adb: New package.
	* libgnat/s-pack96.ads, libgnat/s-pack96.adb: New package.
	* libgnat/s-pack97.ads, libgnat/s-pack97.adb: New package.
	* libgnat/s-pack98.ads, libgnat/s-pack98.adb: New package.
	* libgnat/s-pack99.ads, libgnat/s-pack99.adb: New package.
	* libgnat/s-pack100.ads, libgnat/s-pack100.adb: New package.
	* libgnat/s-pack101.ads, libgnat/s-pack101.adb: New package.
	* libgnat/s-pack102.ads, libgnat/s-pack102.adb: New package.
	* libgnat/s-pack103.ads, libgnat/s-pack103.adb: New package.
	* libgnat/s-pack104.ads, libgnat/s-pack104.adb: New package.
	* libgnat/s-pack105.ads, libgnat/s-pack105.adb: New package.
	* libgnat/s-pack106.ads, libgnat/s-pack106.adb: New package.
	* libgnat/s-pack107.ads, libgnat/s-pack107.adb: New package.
	* libgnat/s-pack108.ads, libgnat/s-pack108.adb: New package.
	* libgnat/s-pack109.ads, libgnat/s-pack109.adb: New package.
	* libgnat/s-pack110.ads, libgnat/s-pack110.adb: New package.
	* libgnat/s-pack111.ads, libgnat/s-pack111.adb: New package.
	* libgnat/s-pack112.ads, libgnat/s-pack112.adb: New package.
	* libgnat/s-pack113.ads, libgnat/s-pack113.adb: New package.
	* libgnat/s-pack114.ads, libgnat/s-pack114.adb: New package.
	* libgnat/s-pack115.ads, libgnat/s-pack115.adb: New package.
	* libgnat/s-pack116.ads, libgnat/s-pack116.adb: New package.
	* libgnat/s-pack117.ads, libgnat/s-pack117.adb: New package.
	* libgnat/s-pack118.ads, libgnat/s-pack118.adb: New package.
	* libgnat/s-pack119.ads, libgnat/s-pack119.adb: New package.
	* libgnat/s-pack120.ads, libgnat/s-pack120.adb: New package.
	* libgnat/s-pack121.ads, libgnat/s-pack121.adb: New package.
	* libgnat/s-pack122.ads, libgnat/s-pack122.adb: New package.
	* libgnat/s-pack123.ads, libgnat/s-pack123.adb: New package.
	* libgnat/s-pack124.ads, libgnat/s-pack124.adb: New package.
	* libgnat/s-pack125.ads, libgnat/s-pack125.adb: New package.
	* libgnat/s-pack126.ads, libgnat/s-pack126.adb: New package.
	* libgnat/s-pack127.ads, libgnat/s-pack127.adb: New package.
	* libgnat/s-rannum.ads (Random): New function returning 128-bit.
	* libgnat/s-rannum.adb (Random): Implement it.
	* libgnat/s-scaval.ads: Add with clause for Interfaces, use subtypes
	of unsigned types defined in Interfaces.
	* libgnat/s-scaval.adb: Add use clause for Interfaces.
	* libgnat/s-scaval__128.ads, libgnat/s-scaval__128.adb: New
	package.
	* libgnat/s-unstyp.ads (Long_Long_Long_Unsigned): New modular type.
	(Shift_Left, Shift_Right, Shift_Right_Arithmetic, Rotate_Left,
	Rotate_Right): New intrinsic functions operating on it.

gcc/testsuite/

	* gnat.dg/multfixed.adb: Update expected exception message.
This commit is contained in:
Eric Botcazou 2020-08-07 15:41:06 +02:00 • committed by Pierre-Marie de Rodat
parent 6551e4cb27
commit a5476382a7
208 changed files with 21019 additions and 1186 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

88
gcc/ada/Makefile.rtl
View file

@ -518,6 +518,7 @@ GNATRTL_NONTASKING_OBJS= \
s-aoinar$(objext) \
s-aomoar$(objext) \
s-aotase$(objext) \
s-aridou$(objext) \
s-arit64$(objext) \
s-assert$(objext) \
s-atacco$(objext) \
@ -582,6 +583,9 @@ GNATRTL_NONTASKING_OBJS= \
s-explli$(objext) \
s-expllu$(objext) \
s-expmod$(objext) \
s-exponn$(objext) \
s-expont$(objext) \
s-exponu$(objext) \
s-expuns$(objext) \
s-fatflt$(objext) \
s-fatgen$(objext) \
@ -867,6 +871,82 @@ TRASYM_DWARF_UNIX_OBJS = $(TRASYM_DWARF_COMMON_OBJS) s-mmauni$(objext)
TRASYM_DWARF_MINGW_OBJS = $(TRASYM_DWARF_COMMON_OBJS)
GNATRTL_128BIT_PAIRS = \
s-scaval.ads<libgnat/s-scaval__128.ads \
s-scaval.adb<libgnat/s-scaval__128.adb
# Objects needed for 128-bit types
GNATRTL_128BIT_OBJS = \
s-arit128$(objext) \
s-casi128$(objext) \
s-caun128$(objext) \
s-exnllli$(objext) \
s-expllli$(objext) \
s-explllu$(objext) \
s-pack65$(objext) \
s-pack66$(objext) \
s-pack67$(objext) \
s-pack68$(objext) \
s-pack69$(objext) \
s-pack70$(objext) \
s-pack71$(objext) \
s-pack72$(objext) \
s-pack73$(objext) \
s-pack74$(objext) \
s-pack75$(objext) \
s-pack76$(objext) \
s-pack77$(objext) \
s-pack78$(objext) \
s-pack79$(objext) \
s-pack80$(objext) \
s-pack81$(objext) \
s-pack82$(objext) \
s-pack83$(objext) \
s-pack84$(objext) \
s-pack85$(objext) \
s-pack86$(objext) \
s-pack87$(objext) \
s-pack88$(objext) \
s-pack89$(objext) \
s-pack90$(objext) \
s-pack91$(objext) \
s-pack92$(objext) \
s-pack93$(objext) \
s-pack94$(objext) \
s-pack95$(objext) \
s-pack96$(objext) \
s-pack97$(objext) \
s-pack98$(objext) \
s-pack99$(objext) \
s-pack100$(objext) \
s-pack101$(objext) \
s-pack102$(objext) \
s-pack103$(objext) \
s-pack104$(objext) \
s-pack105$(objext) \
s-pack106$(objext) \
s-pack107$(objext) \
s-pack108$(objext) \
s-pack109$(objext) \
s-pack110$(objext) \
s-pack111$(objext) \
s-pack112$(objext) \
s-pack113$(objext) \
s-pack114$(objext) \
s-pack115$(objext) \
s-pack116$(objext) \
s-pack117$(objext) \
s-pack118$(objext) \
s-pack119$(objext) \
s-pack120$(objext) \
s-pack121$(objext) \
s-pack122$(objext) \
s-pack123$(objext) \
s-pack124$(objext) \
s-pack125$(objext) \
s-pack126$(objext) \
s-pack127$(objext)
# Shared library version
LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(GNAT_SRC)/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/'))
@ -2023,12 +2103,14 @@ ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),)
LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS)
SO_OPTS= -m32 -Wl,-soname,
else
LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS)
LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS) $(GNATRTL_128BIT_PAIRS)
EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS)
SO_OPTS = -m64 -Wl,-soname,
endif
else
ifeq ($(strip $(MULTISUBDIR)),/64)
LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS)
LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS) $(GNATRTL_128BIT_PAIRS)
EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS)
SO_OPTS = -m64 -Wl,-soname,
else
LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS)
@ -2420,12 +2502,14 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),)
s-tsmona.adb<libgnat/s-tsmona__linux.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_64_TARGET_PAIRS) \
$(GNATRTL_128BIT_PAIRS) \
system.ads<libgnat/system-linux-x86.ads
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS)
EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS)
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
EH_MECHANISM=-gcc

9
gcc/ada/ada_get_targ.adb
View file

@ -100,6 +100,15 @@ package body Get_Targ is
return 64;
end Get_Long_Long_Size;
-----------------------------
-- Get_Long_Long_Long_Size --
-----------------------------
function Get_Long_Long_Long_Size return Pos is
begin
return 64;
end Get_Long_Long_Long_Size;
----------------------
-- Get_Pointer_Size --
----------------------

51
gcc/ada/checks.adb
View file

@ -1013,8 +1013,7 @@ package body Checks is
-- Now see if an overflow check is required
declare
Siz : constant Int := UI_To_Int (Esize (Rtyp));
Dsiz : constant Int := Siz * 2;
Dsiz : constant Uint := 2 * Esize (Rtyp);
Opnod : Node_Id;
Ctyp : Entity_Id;
Opnd : Node_Id;
@ -1050,33 +1049,47 @@ package body Checks is
-- an integer type of sufficient length to hold the largest possible
-- result.
-- If the size of check type exceeds the size of Long_Long_Integer,
-- If the size of the check type exceeds the maximum integer size,
-- we use a different approach, expanding to:
-- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
-- typ (xxx_With_Ovflo_Check (Integer_NN (x), Integer_NN (y)))
-- where xxx is Add, Multiply or Subtract as appropriate
-- Find check type if one exists
if Dsiz <= Standard_Integer_Size then
Ctyp := Standard_Integer;
elsif Dsiz <= Standard_Long_Long_Integer_Size then
Ctyp := Standard_Long_Long_Integer;
if Dsiz <= System_Max_Integer_Size then
Ctyp := Integer_Type_For (Dsiz, Uns => False);
-- No check type exists, use runtime call
else
if Nkind (N) = N_Op_Add then
Cent := RE_Add_With_Ovflo_Check;
elsif Nkind (N) = N_Op_Multiply then
Cent := RE_Multiply_With_Ovflo_Check;
if System_Max_Integer_Size = 64 then
Ctyp := RTE (RE_Integer_64);
else
pragma Assert (Nkind (N) = N_Op_Subtract);
Cent := RE_Subtract_With_Ovflo_Check;
Ctyp := RTE (RE_Integer_128);
end if;
if Nkind (N) = N_Op_Add then
if System_Max_Integer_Size = 64 then
Cent := RE_Add_With_Ovflo_Check64;
else
Cent := RE_Add_With_Ovflo_Check128;
end if;
elsif Nkind (N) = N_Op_Subtract then
if System_Max_Integer_Size = 64 then
Cent := RE_Subtract_With_Ovflo_Check64;
else
Cent := RE_Subtract_With_Ovflo_Check128;
end if;
else pragma Assert (Nkind (N) = N_Op_Multiply);
if System_Max_Integer_Size = 64 then
Cent := RE_Multiply_With_Ovflo_Check64;
else
Cent := RE_Multiply_With_Ovflo_Check128;
end if;
end if;
Rewrite (N,
@ -1084,8 +1097,8 @@ package body Checks is
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (Cent), Loc),
Parameter_Associations => New_List (
OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
OK_Convert_To (Ctyp, Left_Opnd (N)),
OK_Convert_To (Ctyp, Right_Opnd (N))))));
Analyze_And_Resolve (N, Typ);
return;

65
gcc/ada/cstand.adb
View file

@ -719,6 +719,11 @@ package body CStand is
(Standard_Long_Long_Integer, Standard_Long_Long_Integer_Size);
Set_Is_Implementation_Defined (Standard_Long_Long_Integer);
Build_Signed_Integer_Type
(Standard_Long_Long_Long_Integer,
Standard_Long_Long_Long_Integer_Size);
Set_Is_Implementation_Defined (Standard_Long_Long_Long_Integer);
Create_Unconstrained_Base_Type
(Standard_Short_Short_Integer, E_Signed_Integer_Subtype);
@ -734,6 +739,9 @@ package body CStand is
Create_Unconstrained_Base_Type
(Standard_Long_Long_Integer, E_Signed_Integer_Subtype);
Create_Unconstrained_Base_Type
(Standard_Long_Long_Long_Integer, E_Signed_Integer_Subtype);
Create_Float_Types;
-- Create type definition node for type Character. Note that we do not
@ -1238,11 +1246,11 @@ package body CStand is
Set_Elem_Alignment (Any_Fixed);
Any_Integer := New_Standard_Entity ("an integer type");
Set_Ekind (Any_Integer, E_Signed_Integer_Type);
Set_Scope (Any_Integer, Standard_Standard);
Set_Etype (Any_Integer, Standard_Long_Long_Integer);
Init_Size (Any_Integer, Standard_Long_Long_Integer_Size);
Set_Elem_Alignment (Any_Integer);
Set_Ekind (Any_Integer, E_Signed_Integer_Type);
Set_Scope (Any_Integer, Standard_Standard);
Set_Etype (Any_Integer, Standard_Long_Long_Long_Integer);
Init_Size (Any_Integer, Standard_Long_Long_Long_Integer_Size);
Set_Elem_Alignment (Any_Integer);
Set_Integer_Bounds
(Any_Integer,
@ -1251,19 +1259,19 @@ package body CStand is
Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
Any_Modular := New_Standard_Entity ("a modular type");
Set_Ekind (Any_Modular, E_Modular_Integer_Type);
Set_Scope (Any_Modular, Standard_Standard);
Set_Etype (Any_Modular, Standard_Long_Long_Integer);
Init_Size (Any_Modular, Standard_Long_Long_Integer_Size);
Set_Elem_Alignment (Any_Modular);
Set_Is_Unsigned_Type (Any_Modular);
Set_Ekind (Any_Modular, E_Modular_Integer_Type);
Set_Scope (Any_Modular, Standard_Standard);
Set_Etype (Any_Modular, Standard_Long_Long_Long_Integer);
Init_Size (Any_Modular, Standard_Long_Long_Long_Integer_Size);
Set_Elem_Alignment (Any_Modular);
Set_Is_Unsigned_Type (Any_Modular);
Any_Numeric := New_Standard_Entity ("a numeric type");
Set_Ekind (Any_Numeric, E_Signed_Integer_Type);
Set_Scope (Any_Numeric, Standard_Standard);
Set_Etype (Any_Numeric, Standard_Long_Long_Integer);
Init_Size (Any_Numeric, Standard_Long_Long_Integer_Size);
Set_Elem_Alignment (Any_Numeric);
Set_Ekind (Any_Numeric, E_Signed_Integer_Type);
Set_Scope (Any_Numeric, Standard_Standard);
Set_Etype (Any_Numeric, Standard_Long_Long_Long_Integer);
Init_Size (Any_Numeric, Standard_Long_Long_Long_Integer_Size);
Set_Elem_Alignment (Any_Numeric);
Any_Real := New_Standard_Entity ("a real type");
Set_Ekind (Any_Real, E_Floating_Point_Type);
@ -1339,11 +1347,17 @@ package body CStand is
Build_Unsigned_Integer_Type
(Standard_Long_Unsigned, Standard_Long_Integer_Size);
Standard_Long_Long_Unsigned
:= New_Standard_Entity ("long_long_unsigned");
Standard_Long_Long_Unsigned :=
New_Standard_Entity ("long_long_unsigned");
Build_Unsigned_Integer_Type
(Standard_Long_Long_Unsigned, Standard_Long_Long_Integer_Size);
Standard_Long_Long_Long_Unsigned :=
New_Standard_Entity ("long_long_long_unsigned");
Build_Unsigned_Integer_Type
(Standard_Long_Long_Long_Unsigned,
Standard_Long_Long_Long_Integer_Size);
-- Standard_Unsigned_64 is not user visible, but is used internally. It
-- is an unsigned type mod 2**64 with 64 bits size.
@ -1358,16 +1372,16 @@ package body CStand is
-- Note: universal integer and universal real are constructed as fully
-- formed signed numeric types, with parameters corresponding to the
-- longest runtime types (Long_Long_Integer and Long_Long_Float). This
-- allows Gigi to properly process references to universal types that
-- are not folded at compile time.
-- longest runtime types (Long_Long_Long_Integer and Long_Long_Float).
-- This allows Gigi to properly process references to universal types
-- that are not folded at compile time.
Universal_Integer := New_Standard_Entity ("universal_integer");
Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set_Defining_Identifier (Decl, Universal_Integer);
Set_Scope (Universal_Integer, Standard_Standard);
Build_Signed_Integer_Type
(Universal_Integer, Standard_Long_Long_Integer_Size);
(Universal_Integer, Standard_Long_Long_Long_Integer_Size);
Universal_Real := New_Standard_Entity ("universal_real");
Decl := New_Node (N_Full_Type_Declaration, Stloc);
@ -1955,6 +1969,13 @@ package body CStand is
P (";");
Write_Eol;
Write_Str (" type Long_Long_Long_Integer");
P_Int_Range (Standard_Long_Long_Long_Integer_Size);
Write_Str (" for Long_Long_Long_Integer'Size use ");
Write_Int (Standard_Long_Long_Long_Integer_Size);
P (";");
Write_Eol;
-- Floating point types
P_Float_Type (Standard_Short_Float);

2
gcc/ada/exp_attr.adb
View file

@ -4586,7 +4586,7 @@ package body Exp_Attr is
-- b) The integer value is negative. In this case, we know that the
-- result is modulus + value, where the value might be as small as
-- -modulus. The trouble is what type do we use to do the subtract.
-- No type will do, since modulus can be as big as 2**64, and no
-- No type will do, since modulus can be as big as 2**128, and no
-- integer type accommodates this value. Let's do bit of algebra
-- modulus + value

14
gcc/ada/exp_ch3.adb
View file

@ -8565,8 +8565,10 @@ package body Exp_Ch3 is
Scal_Typ := Name_Unsigned_16;
elsif Size_To_Use <= 32 then
Scal_Typ := Name_Unsigned_32;
else
elsif Size_To_Use <= 64 then
Scal_Typ := Name_Unsigned_64;
else
Scal_Typ := Name_Unsigned_128;
end if;
-- Signed types
@ -8578,8 +8580,10 @@ package body Exp_Ch3 is
Scal_Typ := Name_Signed_16;
elsif Size_To_Use <= 32 then
Scal_Typ := Name_Signed_32;
else
elsif Size_To_Use <= 64 then
Scal_Typ := Name_Signed_64;
else
Scal_Typ := Name_Signed_128;
end if;
end if;
@ -8633,10 +8637,10 @@ package body Exp_Ch3 is
then
Expr := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
-- Resolve as Long_Long_Unsigned, because the largest number
-- Resolve as Long_Long_Long_Unsigned, because the largest number
-- we can generate is out of range of universal integer.
Analyze_And_Resolve (Expr, Standard_Long_Long_Unsigned);
Analyze_And_Resolve (Expr, Standard_Long_Long_Long_Unsigned);
-- Case of signed types
@ -8724,7 +8728,7 @@ package body Exp_Ch3 is
end if;
-- The maximum size to use is System_Max_Integer_Size bits. This
-- will create values of type Long_Long_Unsigned and the range
-- will create values of type Long_Long_Long_Unsigned and the range
-- must fit this type.
if Size_To_Use /= No_Uint

86
gcc/ada/exp_ch4.adb
View file

@ -1385,7 +1385,7 @@ package body Exp_Ch4 is
-- (left'address, right'address, left'length, right'length) <op> 0
-- x = U for unsigned, S for signed
-- n = 8,16,32,64 for component size
-- n = 8,16,32,64,128 for component size
-- Add _Unaligned if length < 4 and component size is 8.
-- <op> is the standard comparison operator
@ -1422,12 +1422,19 @@ package body Exp_Ch4 is
Comp := RE_Compare_Array_S32;
end if;
else pragma Assert (Component_Size (Typ1) = 64);
elsif Component_Size (Typ1) = 64 then
if Is_Unsigned_Type (Ctyp) then
Comp := RE_Compare_Array_U64;
else
Comp := RE_Compare_Array_S64;
end if;
else pragma Assert (Component_Size (Typ1) = 128);
if Is_Unsigned_Type (Ctyp) then
Comp := RE_Compare_Array_U128;
else
Comp := RE_Compare_Array_S128;
end if;
end if;
if RTE_Available (Comp) then
@ -8992,15 +8999,18 @@ package body Exp_Ch4 is
Make_Integer_Literal (Loc, Modulus (Rtyp)),
Exp))));
-- Binary modular case, in this case, we call one of two routines,
-- Binary modular case, in this case, we call one of three routines,
-- either the unsigned integer case, or the unsigned long long
-- integer case, with a final "and" operation to do the required mod.
-- integer case, or the unsigned long long long integer case, with a
-- final "and" operation to do the required mod.
else
if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
if Esize (Rtyp) <= Standard_Integer_Size then
Ent := RTE (RE_Exp_Unsigned);
else
elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
Ent := RTE (RE_Exp_Long_Long_Unsigned);
else
Ent := RTE (RE_Exp_Long_Long_Long_Unsigned);
end if;
Rewrite (N,
@ -9022,36 +9032,43 @@ package body Exp_Ch4 is
Analyze_And_Resolve (N, Typ);
return;
-- Signed integer cases, done using either Integer or Long_Long_Integer.
-- It is not worth having routines for Short_[Short_]Integer, since for
-- most machines it would not help, and it would generate more code that
-- might need certification when a certified run time is required.
-- Signed integer cases, using either Integer, Long_Long_Integer or
-- Long_Long_Long_Integer. It is not worth also having routines for
-- Short_[Short_]Integer, since for most machines it would not help,
-- and it would generate more code that might need certification when
-- a certified run time is required.
-- In the integer cases, we have two routines, one for when overflow
-- checks are required, and one when they are not required, since there
-- is a real gain in omitting checks on many machines.
elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
or else (Rtyp = Base_Type (Standard_Long_Integer)
and then
Esize (Standard_Long_Integer) > Esize (Standard_Integer))
or else Rtyp = Universal_Integer
then
Etyp := Standard_Long_Long_Integer;
if Ovflo then
Rent := RE_Exp_Long_Long_Integer;
else
Rent := RE_Exn_Long_Long_Integer;
end if;
elsif Is_Signed_Integer_Type (Rtyp) then
Etyp := Standard_Integer;
if Esize (Rtyp) <= Standard_Integer_Size then
Etyp := Standard_Integer;
if Ovflo then
Rent := RE_Exp_Integer;
else
Rent := RE_Exn_Integer;
end if;
elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
Etyp := Standard_Long_Long_Integer;
if Ovflo then
Rent := RE_Exp_Long_Long_Integer;
else
Rent := RE_Exn_Long_Long_Integer;
end if;
if Ovflo then
Rent := RE_Exp_Integer;
else
Rent := RE_Exn_Integer;
Etyp := Standard_Long_Long_Long_Integer;
if Ovflo then
Rent := RE_Exp_Long_Long_Long_Integer;
else
Rent := RE_Exn_Long_Long_Long_Integer;
end if;
end if;
-- Floating-point cases. We do not need separate routines for the
@ -14101,6 +14118,11 @@ package body Exp_Ch4 is
elsif Is_OK_For_Range (Uint_64) then
return Uint_64;
-- If the size of Typ is 128 then check 127
elsif Tsiz = Uint_128 and then Is_OK_For_Range (Uint_127) then
return Uint_127;
else
return Uint_128;
end if;
@ -14220,12 +14242,8 @@ package body Exp_Ch4 is
-- type instead of the first subtype because operations are done in
-- the base type, so this avoids the need for useless conversions.
if Nsiz <= Standard_Integer_Size then
Ntyp := Etype (Standard_Integer);
elsif Nsiz <= Standard_Long_Long_Integer_Size then
Ntyp := Etype (Standard_Long_Long_Integer);
if Nsiz <= System_Max_Integer_Size then
Ntyp := Etype (Integer_Type_For (Nsiz, Uns => False));
else
return;
end if;

6
gcc/ada/exp_dbug.adb
View file

@ -247,7 +247,7 @@ package body Exp_Dbug is
-- Here we check if the static bounds match the natural size, which is
-- the size passed through with the debugging information. This is the
-- Esize rounded up to 8, 16, 32 or 64 as appropriate.
-- Esize rounded up to 8, 16, 32, 64 or 128 as appropriate.
else
declare
@ -261,8 +261,10 @@ package body Exp_Dbug is
Siz := Uint_16;
elsif Esize (E) <= 32 then
Siz := Uint_32;
else
elsif Esize (E) <= 64 then
Siz := Uint_64;
else
Siz := Uint_128;
end if;
if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then

4
gcc/ada/exp_fixd.adb
View file

@ -620,7 +620,7 @@ package body Exp_Fixd is
Object_Definition => New_Occurrence_Of (QR_Typ, Loc)),
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Double_Divide), Loc),
Name => New_Occurrence_Of (RTE (RE_Double_Divide64), Loc),
Parameter_Associations => New_List (
Build_Conversion (N, QR_Typ, X),
Build_Conversion (N, QR_Typ, Y),
@ -977,7 +977,7 @@ package body Exp_Fixd is
Object_Definition => New_Occurrence_Of (QR_Typ, Loc)),
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Scaled_Divide), Loc),
Name => New_Occurrence_Of (RTE (RE_Scaled_Divide64), Loc),
Parameter_Associations => New_List (
Build_Conversion (N, QR_Typ, X),
Build_Conversion (N, QR_Typ, Y),

12
gcc/ada/exp_intr.adb
View file

@ -205,12 +205,16 @@ package body Exp_Intr is
return;
end if;
-- Use Unsigned_32 for sizes of 32 or below, else Unsigned_64
-- Use the appropriate type for the size
if Siz > 32 then
T3 := RTE (RE_Unsigned_64);
else
if Siz <= 32 then
T3 := RTE (RE_Unsigned_32);
elsif Siz <= 64 then
T3 := RTE (RE_Unsigned_64);
else pragma Assert (Siz <= 128);
T3 := RTE (RE_Unsigned_128);
end if;
-- Copy operator node, and reset type and entity fields, for

5
gcc/ada/exp_pakd.adb
View file

@ -233,8 +233,11 @@ package body Exp_Pakd is
elsif T_Size <= 32 then
Swap_RE := RE_Bswap_32;
else pragma Assert (T_Size <= 64);
elsif T_Size <= 64 then
Swap_RE := RE_Bswap_64;
else pragma Assert (T_Size <= 128);
Swap_RE := RE_Bswap_128;
end if;
Swap_F := RTE (Swap_RE);

340
gcc/ada/exp_pakd.ads
View file

@ -217,12 +217,12 @@ package Exp_Pakd is
-- Entity Tables for Packed Access Routines --
----------------------------------------------
-- For the cases of component size = 3,5-7,9-15,17-31,33-63 we call library
-- routines. These tables provide the entity for the proper routine. They
-- are exposed in the spec to allow checking for the presence of the needed
-- routine when an array is subject to pragma Pack.
-- For the cases of component size = 3,5-7,9-15,17-31,33-63,65-127 we call
-- library routines. These tables provide the entity for the right routine.
-- They are exposed in the spec to allow checking for the presence of the
-- needed routine when an array is subject to pragma Pack.
type E_Array is array (Int range 01 .. 63) of RE_Id;
type E_Array is array (Int range 1 .. 127) of RE_Id;
-- Array of Bits_nn entities. Note that we do not use library routines
-- for the 8-bit and 16-bit cases, but we still fill in the table, using
@ -292,7 +292,71 @@ package Exp_Pakd is
60 => RE_Bits_60,
61 => RE_Bits_61,
62 => RE_Bits_62,
63 => RE_Bits_63);
63 => RE_Bits_63,
64 => RE_Unsigned_64,
65 => RE_Bits_65,
66 => RE_Bits_66,
67 => RE_Bits_67,
68 => RE_Bits_68,
69 => RE_Bits_69,
70 => RE_Bits_70,
71 => RE_Bits_71,
72 => RE_Bits_72,
73 => RE_Bits_73,
74 => RE_Bits_74,
75 => RE_Bits_75,
76 => RE_Bits_76,
77 => RE_Bits_77,
78 => RE_Bits_78,
79 => RE_Bits_79,
80 => RE_Bits_80,
81 => RE_Bits_81,
82 => RE_Bits_82,
83 => RE_Bits_83,
84 => RE_Bits_84,
85 => RE_Bits_85,
86 => RE_Bits_86,
87 => RE_Bits_87,
88 => RE_Bits_88,
89 => RE_Bits_89,
90 => RE_Bits_90,
91 => RE_Bits_91,
92 => RE_Bits_92,
93 => RE_Bits_93,
94 => RE_Bits_94,
95 => RE_Bits_95,
96 => RE_Bits_96,
97 => RE_Bits_97,
98 => RE_Bits_98,
99 => RE_Bits_99,
100 => RE_Bits_100,
101 => RE_Bits_101,
102 => RE_Bits_102,
103 => RE_Bits_103,
104 => RE_Bits_104,
105 => RE_Bits_105,
106 => RE_Bits_106,
107 => RE_Bits_107,
108 => RE_Bits_108,
109 => RE_Bits_109,
110 => RE_Bits_110,
111 => RE_Bits_111,
112 => RE_Bits_112,
113 => RE_Bits_113,
114 => RE_Bits_114,
115 => RE_Bits_115,
116 => RE_Bits_116,
117 => RE_Bits_117,
118 => RE_Bits_118,
119 => RE_Bits_119,
120 => RE_Bits_120,
121 => RE_Bits_121,
122 => RE_Bits_122,
123 => RE_Bits_123,
124 => RE_Bits_124,
125 => RE_Bits_125,
126 => RE_Bits_126,
127 => RE_Bits_127);
-- Array of Get routine entities. These are used to obtain an element from
-- a packed array. The N'th entry is used to obtain elements from a packed
@ -362,7 +426,71 @@ package Exp_Pakd is
60 => RE_Get_60,
61 => RE_Get_61,
62 => RE_Get_62,
63 => RE_Get_63);
63 => RE_Get_63,
64 => RE_Null,
65 => RE_Get_65,
66 => RE_Get_66,
67 => RE_Get_67,
68 => RE_Get_68,
69 => RE_Get_69,
70 => RE_Get_70,
71 => RE_Get_71,
72 => RE_Get_72,
73 => RE_Get_73,
74 => RE_Get_74,
75 => RE_Get_75,
76 => RE_Get_76,
77 => RE_Get_77,
78 => RE_Get_78,
79 => RE_Get_79,
80 => RE_Get_80,
81 => RE_Get_81,
82 => RE_Get_82,
83 => RE_Get_83,
84 => RE_Get_84,
85 => RE_Get_85,
86 => RE_Get_86,
87 => RE_Get_87,
88 => RE_Get_88,
89 => RE_Get_89,
90 => RE_Get_90,
91 => RE_Get_91,
92 => RE_Get_92,
93 => RE_Get_93,
94 => RE_Get_94,
95 => RE_Get_95,
96 => RE_Get_96,
97 => RE_Get_97,
98 => RE_Get_98,
99 => RE_Get_99,
100 => RE_Get_100,
101 => RE_Get_101,
102 => RE_Get_102,
103 => RE_Get_103,
104 => RE_Get_104,
105 => RE_Get_105,
106 => RE_Get_106,
107 => RE_Get_107,
108 => RE_Get_108,
109 => RE_Get_109,
110 => RE_Get_110,
111 => RE_Get_111,
112 => RE_Get_112,
113 => RE_Get_113,
114 => RE_Get_114,
115 => RE_Get_115,
116 => RE_Get_116,
117 => RE_Get_117,
118 => RE_Get_118,
119 => RE_Get_119,
120 => RE_Get_120,
121 => RE_Get_121,
122 => RE_Get_122,
123 => RE_Get_123,
124 => RE_Get_124,
125 => RE_Get_125,
126 => RE_Get_126,
127 => RE_Get_127);
-- Array of Get routine entities to be used in the case where the packed
-- array is itself a component of a packed structure, and therefore may not
@ -432,7 +560,71 @@ package Exp_Pakd is
60 => RE_GetU_60,
61 => RE_Get_61,
62 => RE_GetU_62,
63 => RE_Get_63);
63 => RE_Get_63,
64 => RE_Null,
65 => RE_Get_65,
66 => RE_GetU_66,
67 => RE_Get_67,
68 => RE_GetU_68,
69 => RE_Get_69,
70 => RE_GetU_70,
71 => RE_Get_71,
72 => RE_GetU_72,
73 => RE_Get_73,
74 => RE_GetU_74,
75 => RE_Get_75,
76 => RE_GetU_76,
77 => RE_Get_77,
78 => RE_GetU_78,
79 => RE_Get_79,
80 => RE_GetU_80,
81 => RE_Get_81,
82 => RE_GetU_82,
83 => RE_Get_83,
84 => RE_GetU_84,
85 => RE_Get_85,
86 => RE_GetU_86,
87 => RE_Get_87,
88 => RE_GetU_88,
89 => RE_Get_89,
90 => RE_GetU_90,
91 => RE_Get_91,
92 => RE_GetU_92,
93 => RE_Get_93,
94 => RE_GetU_94,
95 => RE_Get_95,
96 => RE_GetU_96,
97 => RE_Get_97,
98 => RE_GetU_98,
99 => RE_Get_99,
100 => RE_GetU_100,
101 => RE_Get_101,
102 => RE_GetU_102,
103 => RE_Get_103,
104 => RE_GetU_104,
105 => RE_Get_105,
106 => RE_GetU_106,
107 => RE_Get_107,
108 => RE_GetU_108,
109 => RE_Get_109,
110 => RE_GetU_110,
111 => RE_Get_111,
112 => RE_GetU_112,
113 => RE_Get_113,
114 => RE_GetU_114,
115 => RE_Get_115,
116 => RE_GetU_116,
117 => RE_Get_117,
118 => RE_GetU_118,
119 => RE_Get_119,
120 => RE_GetU_120,
121 => RE_Get_121,
122 => RE_GetU_122,
123 => RE_Get_123,
124 => RE_GetU_124,
125 => RE_Get_125,
126 => RE_GetU_126,
127 => RE_Get_127);
-- Array of Set routine entities. These are used to assign an element of a
-- packed array. The N'th entry is used to assign elements for a packed
@ -502,7 +694,71 @@ package Exp_Pakd is
60 => RE_Set_60,
61 => RE_Set_61,
62 => RE_Set_62,
63 => RE_Set_63);
63 => RE_Set_63,
64 => RE_Null,
65 => RE_Set_65,
66 => RE_Set_66,
67 => RE_Set_67,
68 => RE_Set_68,
69 => RE_Set_69,
70 => RE_Set_70,
71 => RE_Set_71,
72 => RE_Set_72,
73 => RE_Set_73,
74 => RE_Set_74,
75 => RE_Set_75,
76 => RE_Set_76,
77 => RE_Set_77,
78 => RE_Set_78,
79 => RE_Set_79,
80 => RE_Set_80,
81 => RE_Set_81,
82 => RE_Set_82,
83 => RE_Set_83,
84 => RE_Set_84,
85 => RE_Set_85,
86 => RE_Set_86,
87 => RE_Set_87,
88 => RE_Set_88,
89 => RE_Set_89,
90 => RE_Set_90,
91 => RE_Set_91,
92 => RE_Set_92,
93 => RE_Set_93,
94 => RE_Set_94,
95 => RE_Set_95,
96 => RE_Set_96,
97 => RE_Set_97,
98 => RE_Set_98,
99 => RE_Set_99,
100 => RE_Set_100,
101 => RE_Set_101,
102 => RE_Set_102,
103 => RE_Set_103,
104 => RE_Set_104,
105 => RE_Set_105,
106 => RE_Set_106,
107 => RE_Set_107,
108 => RE_Set_108,
109 => RE_Set_109,
110 => RE_Set_110,
111 => RE_Set_111,
112 => RE_Set_112,
113 => RE_Set_113,
114 => RE_Set_114,
115 => RE_Set_115,
116 => RE_Set_116,
117 => RE_Set_117,
118 => RE_Set_118,
119 => RE_Set_119,
120 => RE_Set_120,
121 => RE_Set_121,
122 => RE_Set_122,
123 => RE_Set_123,
124 => RE_Set_124,
125 => RE_Set_125,
126 => RE_Set_126,
127 => RE_Set_127);
-- Array of Set routine entities to be used in the case where the packed
-- array is itself a component of a packed structure, and therefore may not
@ -572,7 +828,71 @@ package Exp_Pakd is
60 => RE_SetU_60,
61 => RE_Set_61,
62 => RE_SetU_62,
63 => RE_Set_63);
63 => RE_Set_63,
64 => RE_Null,
65 => RE_Set_65,
66 => RE_SetU_66,
67 => RE_Set_67,
68 => RE_SetU_68,
69 => RE_Set_69,
70 => RE_SetU_70,
71 => RE_Set_71,
72 => RE_SetU_72,
73 => RE_Set_73,
74 => RE_SetU_74,
75 => RE_Set_75,
76 => RE_SetU_76,
77 => RE_Set_77,
78 => RE_SetU_78,
79 => RE_Set_79,
80 => RE_SetU_80,
81 => RE_Set_81,
82 => RE_SetU_82,
83 => RE_Set_83,
84 => RE_SetU_84,
85 => RE_Set_85,
86 => RE_SetU_86,
87 => RE_Set_87,
88 => RE_SetU_88,
89 => RE_Set_89,
90 => RE_SetU_90,
91 => RE_Set_91,
92 => RE_SetU_92,
93 => RE_Set_93,
94 => RE_SetU_94,
95 => RE_Set_95,
96 => RE_SetU_96,
97 => RE_Set_97,
98 => RE_SetU_98,
99 => RE_Set_99,
100 => RE_SetU_100,
101 => RE_Set_101,
102 => RE_SetU_102,
103 => RE_Set_103,
104 => RE_SetU_104,
105 => RE_Set_105,
106 => RE_SetU_106,
107 => RE_Set_107,
108 => RE_SetU_108,
109 => RE_Set_109,
110 => RE_SetU_110,
111 => RE_Set_111,
112 => RE_SetU_112,
113 => RE_Set_113,
114 => RE_SetU_114,
115 => RE_Set_115,
116 => RE_SetU_116,
117 => RE_Set_117,
118 => RE_SetU_118,
119 => RE_Set_119,
120 => RE_SetU_120,
121 => RE_Set_121,
122 => RE_SetU_122,
123 => RE_Set_123,
124 => RE_SetU_124,
125 => RE_Set_125,
126 => RE_SetU_126,
127 => RE_Set_127);
-----------------
-- Subprograms --

16
gcc/ada/exp_util.adb
View file

@ -7751,6 +7751,15 @@ package body Exp_Util is
return Standard_Long_Long_Integer;
end if;
-- This is the canonical 128-bit type
elsif S <= Standard_Long_Long_Long_Integer_Size then
if Uns then
return Standard_Long_Long_Long_Unsigned;
else
return Standard_Long_Long_Long_Integer;
end if;
else
raise Program_Error;
end if;
@ -13593,6 +13602,13 @@ package body Exp_Util is
return Standard_Long_Long_Integer;
end if;
elsif S <= Standard_Long_Long_Long_Integer_Size then
if Uns then
return Standard_Long_Long_Long_Unsigned;
else
return Standard_Long_Long_Long_Integer;
end if;
else
raise Program_Error;
end if;

6
gcc/ada/fname.adb
View file

@ -140,11 +140,13 @@ package body Fname is
Renamings_Included : Boolean := True) return Boolean
is
begin
-- Definitely false if longer than 12 characters (8.3)
-- except for the Interfaces packages
-- Definitely false if longer than 12 characters (8.3), except for the
-- Interfaces packages and also the implementation units of the 128-bit
-- types under System.
if Fname'Length > 12
and then Fname (Fname'First .. Fname'First + 1) /= "i-"
and then Fname (Fname'First .. Fname'First + 1) /= "s-"
then
return False;
end if;

12
gcc/ada/freeze.adb
View file

@ -80,8 +80,8 @@ package body Freeze is
-- Typ is a type that is being frozen. If no size clause is given,
-- but a default Esize has been computed, then this default Esize is
-- adjusted up if necessary to be consistent with a given alignment,
-- but never to a value greater than Long_Long_Integer'Size. This
-- is used for all discrete types and for fixed-point types.
-- but never to a value greater than System_Max_Integer_Size. This is
-- used for all discrete types and for fixed-point types.
procedure Build_And_Analyze_Renamed_Body
(Decl : Node_Id;
@ -231,9 +231,7 @@ package body Freeze is
if Known_Esize (Typ) and then Known_Alignment (Typ) then
Align := Alignment_In_Bits (Typ);
if Align > Esize (Typ)
and then Align <= Standard_Long_Long_Integer_Size
then
if Align > Esize (Typ) and then Align <= System_Max_Integer_Size then
Set_Esize (Typ, Align);
end if;
end if;
@ -2204,7 +2202,7 @@ package body Freeze is
-- generated a message on the template.
procedure Check_Suspicious_Modulus (Utype : Entity_Id);
-- Give warning for modulus of 8, 16, 32, or 64 given as an explicit
-- Give warning for modulus of 8, 16, 32, 64 or 128 given as an explicit
-- integer literal without an explicit corresponding size clause. The
-- caller has checked that Utype is a modular integer type.
@ -2896,7 +2894,7 @@ package body Freeze is
end if;
end if;
-- Bit packing is never needed for 8, 16, 32, 64
-- Bit packing is never needed for 8, 16, 32, 64 or 128
if Addressable (Csiz) then

21
gcc/ada/get_targ.adb
View file

@ -126,6 +126,18 @@ package body Get_Targ is
return C_Get_Long_Long_Size;
end Get_Long_Long_Size;
-----------------------------
-- Get_Long_Long_Long_Size --
-----------------------------
function Get_Long_Long_Long_Size return Pos is
function C_Get_Long_Long_Long_Size return Pos;
pragma Import (C, C_Get_Long_Long_Long_Size,
"get_target_long_long_long_size");
begin
return C_Get_Long_Long_Long_Size;
end Get_Long_Long_Long_Size;
----------------------
-- Get_Pointer_Size --
----------------------
@ -309,10 +321,11 @@ package body Get_Targ is
function Width_From_Size (Size : Pos) return Pos is
begin
case Size is
when 8 => return 4;
when 16 => return 6;
when 32 => return 11;
when 64 => return 21;
when 8 => return 4;
when 16 => return 6;
when 32 => return 11;
when 64 => return 21;
when 128 => return 40;
when others => raise Program_Error;
end case;
end Width_From_Size;

3
gcc/ada/get_targ.ads
View file

@ -68,6 +68,9 @@ package Get_Targ is
function Get_Long_Long_Size return Pos;
-- Size of Standard.Long_Long_Integer
function Get_Long_Long_Long_Size return Pos;
-- Size of Standard.Long_Long_Long_Integer
function Get_Pointer_Size return Pos;
-- Size of System.Address

27
gcc/ada/gnat1drv.adb
View file

@ -799,6 +799,33 @@ procedure Gnat1drv is
Set_Standard_Output;
end if;
-- Enable or disable the support for 128-bit types
if Enable_128bit_Types then
if Ttypes.Standard_Long_Long_Long_Integer_Size < 128 then
Write_Line
("128-bit types not implemented in this configuration");
raise Unrecoverable_Error;
end if;
-- In GNAT mode the support is automatically enabled if available,
-- so that the runtime is compiled with the support enabled.
elsif GNAT_Mode then
Enable_128bit_Types :=
Ttypes.Standard_Long_Long_Long_Integer_Size = 128;
else
Ttypes.Standard_Long_Long_Long_Integer_Size :=
Ttypes.Standard_Long_Long_Integer_Size;
Ttypes.Standard_Long_Long_Long_Integer_Width :=
Ttypes.Standard_Long_Long_Integer_Width;
Ttypes.System_Max_Integer_Size :=
Ttypes.Standard_Long_Long_Integer_Size;
Ttypes.System_Max_Binary_Modulus_Power :=
Ttypes.Standard_Long_Long_Integer_Size;
end if;
-- Finally capture adjusted value of Suppress_Options as the initial
-- value for Scope_Suppress, which will be modified as we move from
-- scope to scope (by Suppress/Unsuppress/Overflow_Checks pragmas).

44
gcc/ada/impunit.adb
View file

@ -687,7 +687,7 @@ package body Impunit is
function Get_Kind_Of_File (File : String) return Kind_Of_Unit is
pragma Assert (File'First = 1);
Buffer : String (1 .. 8);
Buffer : String (1 .. 9);
begin
Error_Msg_Strlen := 0;
@ -701,13 +701,6 @@ package body Impunit is
return Ada_95_Unit;
end if;
-- If length of file name is greater than 12, not predefined. The value
-- 12 here is an 8 char name with extension .ads.
if File'Length > 12 then
return Not_Predefined_Unit;
end if;
-- Not predefined if file name does not start with a- g- s- i-
if File'Length < 3
@ -721,6 +714,16 @@ package body Impunit is
return Not_Predefined_Unit;
end if;
-- If length of file name is greater than 12, not predefined. The value
-- 12 here is an 8 char name with extension .ads. The exception of 13 is
-- for the implementation units of the 128-bit types under System.
if File'Length > 12
and then not (File'Length = 13 and then File (1) = 's')
then
return Not_Predefined_Unit;
end if;
-- Not predefined if file name does not end in .ads. This can happen
-- when non-standard file names are being used.
@ -739,7 +742,7 @@ package body Impunit is
-- See if name is in 95 list
for J in Non_Imp_File_Names_95'Range loop
if Buffer = Non_Imp_File_Names_95 (J).Fname then
if Buffer (1 .. 8) = Non_Imp_File_Names_95 (J).Fname then
return Ada_95_Unit;
end if;
end loop;
@ -747,7 +750,7 @@ package body Impunit is
-- See if name is in 2005 list
for J in Non_Imp_File_Names_05'Range loop
if Buffer = Non_Imp_File_Names_05 (J).Fname then
if Buffer (1 .. 8) = Non_Imp_File_Names_05 (J).Fname then
return Ada_2005_Unit;
end if;
end loop;
@ -755,7 +758,7 @@ package body Impunit is
-- See if name is in 2012 list
for J in Non_Imp_File_Names_12'Range loop
if Buffer = Non_Imp_File_Names_12 (J).Fname then
if Buffer (1 .. 8) = Non_Imp_File_Names_12 (J).Fname then
return Ada_2012_Unit;
end if;
end loop;
@ -763,7 +766,7 @@ package body Impunit is
-- See if name is in 202X list
for J in Non_Imp_File_Names_2X'Range loop
if Buffer = Non_Imp_File_Names_2X (J).Fname then
if Buffer (1 .. 8) = Non_Imp_File_Names_2X (J).Fname then
return Ada_202X_Unit;
end if;
end loop;
@ -927,13 +930,6 @@ package body Impunit is
return True;
end if;
-- If length of file name is greater than 12, then it's a user unit
-- and not a GNAT implementation defined unit.
if Name_Len > 12 then
return True;
end if;
-- Implementation defined if unit in the gnat hierarchy
if (Name_Len = 8 and then Name_Buffer (1 .. 8) = "gnat.ads")
@ -955,6 +951,16 @@ package body Impunit is
return True;
end if;
-- If length of file name is greater than 12, not predefined. The value
-- 12 here is an 8 char name with extension .ads. The exception of 13 is
-- for the implementation units of the 128-bit types under System.
if Name_Len > 12
and then not (Name_Len = 13 and then Name_Buffer (1) = 's')
then
return True;
end if;
-- Not impl-defined if file name does not end in .ads. This can happen
-- when non-standard file names are being used.

15
gcc/ada/krunch.adb
View file

@ -89,7 +89,20 @@ begin
Startloc := 3;
Buffer (2 .. Len - 5) := Buffer (7 .. Len);
Curlen := Len - 5;
Krlen := 8;
if Buffer (Curlen - 2 .. Curlen) = "128"
or else Buffer (3 .. 9) = "exn_lll"
or else Buffer (3 .. 9) = "exp_lll"
or else (Buffer (3 .. 6) = "pack" and then Curlen = 10)
then
if Buffer (3 .. 15) = "compare_array" then
Buffer (3 .. 4) := "ca";
Buffer (5 .. Curlen - 11) := Buffer (16 .. Curlen);
Curlen := Curlen - 11;
end if;
Krlen := 9;
else
Krlen := 8;
end if;
elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then
Startloc := 3;

3
gcc/ada/krunch.ads
View file

@ -114,6 +114,9 @@
-- we replace the prefix ada.wide_wide_text_io- by a-zt- and then
-- the normal crunching rules are applied.
-- The units implementing the support of 128-bit types are crunched to 9 and
-- System.Compare_Array_* is replaced with System.CA_* before crunching.
-- These are the only irregularity required (so far) to keep the file names
-- unique in the standard predefined libraries.

12
gcc/ada/layout.adb
View file

@ -436,11 +436,11 @@ package body Layout is
end if;
-- For array base types, set the component size if object size of the
-- component type is known and is a small power of 2 (8, 16, 32, 64),
-- since this is what will always be used, except if a very large
-- alignment was specified and so Adjust_Esize_For_Alignment gave up
-- because, in this case, the object size is not a multiple of the
-- alignment and, therefore, cannot be the component size.
-- component type is known and is a small power of 2 (8, 16, 32, 64
-- or 128), since this is what will always be used, except if a very
-- large alignment was specified and so Adjust_Esize_For_Alignment
-- gave up because, in this case, the object size is not a multiple
-- of the alignment and, therefore, cannot be the component size.
if Ekind (E) = E_Array_Type and then Unknown_Component_Size (E) then
declare
@ -455,7 +455,7 @@ package body Layout is
and then Known_Static_Esize (CT)
and then not (Known_Alignment (CT)
and then Alignment_In_Bits (CT) >
Standard_Long_Long_Integer_Size)
System_Max_Integer_Size)
then
declare
S : constant Uint := Esize (CT);

2
gcc/ada/libgnat/a-tifiio.adb
View file

@ -580,7 +580,7 @@ package body Ada.Text_IO.Fixed_IO is
YY := 10**(Integer'Min (Max_Digits, AA - (J - 1) * Max_Digits));
end if;
Scaled_Divide (XX, YY, Z, Q (J), R => XX, Round => False);
Scaled_Divide64 (XX, YY, Z, Q (J), R => XX, Round => False);
end loop;
if -E > A then

35
gcc/ada/libgnat/interfac__2020.ads
View file

@ -60,7 +60,12 @@ package Interfaces is
-- such as SPARK or CodePeer. In the normal case Long_Long_Integer is
-- always 64-bits so we get the desired 64-bit type.
type Unsigned_8 is mod 2 ** 8;
type Integer_128 is new Long_Long_Long_Integer;
-- Note: we use Long_Long_Long_Integer instead of literal bounds to allow
-- this unit to be compiled with compilers not supporting 128-bit integers.
-- We do not put a confirming size clause of 128 bits for the same reason.
type Unsigned_8 is mod 2 ** 8;
for Unsigned_8'Size use 8;
type Unsigned_16 is mod 2 ** 16;
@ -78,6 +83,9 @@ package Interfaces is
for Unsigned_64'Size use 64;
-- See comment on Integer_64 above
type Unsigned_128 is mod 2 ** Long_Long_Long_Integer'Size;
-- See comment on Integer_128 above
function Shift_Left
(Value : Unsigned_8;
Amount : Natural) return Unsigned_8
@ -178,6 +186,31 @@ package Interfaces is
Amount : Natural) return Unsigned_64
with Import, Convention => Intrinsic, Static;
function Shift_Left
(Value : Unsigned_128;
Amount : Natural) return Unsigned_128
with Import, Convention => Intrinsic, Static;
function Shift_Right
(Value : Unsigned_128;
Amount : Natural) return Unsigned_128
with Import, Convention => Intrinsic, Static;
function Shift_Right_Arithmetic
(Value : Unsigned_128;
Amount : Natural) return Unsigned_128
with Import, Convention => Intrinsic, Static;
function Rotate_Left
(Value : Unsigned_128;
Amount : Natural) return Unsigned_128
with Import, Convention => Intrinsic, Static;
function Rotate_Right
(Value : Unsigned_128;
Amount : Natural) return Unsigned_128
with Import, Convention => Intrinsic, Static;
-- IEEE Floating point types
type IEEE_Float_32 is digits 6;

678
gcc/ada/libgnat/s-aridou.adb Normal file
View file

@ -0,0 +1,678 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . A R I T H _ D O U B L E --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with Ada.Unchecked_Conversion;
package body System.Arith_Double is
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
function To_Uns is new Ada.Unchecked_Conversion (Double_Int, Double_Uns);
function To_Int is new Ada.Unchecked_Conversion (Double_Uns, Double_Int);
Double_Size : constant Natural := Double_Int'Size;
Single_Size : constant Natural := Double_Int'Size / 2;
-----------------------
-- Local Subprograms --
-----------------------
function "+" (A, B : Single_Uns) return Double_Uns is
(Double_Uns (A) + Double_Uns (B));
function "+" (A : Double_Uns; B : Single_Uns) return Double_Uns is
(A + Double_Uns (B));
-- Length doubling additions
function "*" (A, B : Single_Uns) return Double_Uns is
(Double_Uns (A) * Double_Uns (B));
-- Length doubling multiplication
function "/" (A : Double_Uns; B : Single_Uns) return Double_Uns is
(A / Double_Uns (B));
-- Length doubling division
function "&" (Hi, Lo : Single_Uns) return Double_Uns is
(Shift_Left (Double_Uns (Hi), Single_Size) or Double_Uns (Lo));
-- Concatenate hi, lo values to form double result
function "abs" (X : Double_Int) return Double_Uns is
(if X = Double_Int'First
then 2 ** (Double_Size - 1)
else Double_Uns (Double_Int'(abs X)));
-- Convert absolute value of X to unsigned. Note that we can't just use
-- the expression of the Else since it overflows for X = Double_Int'First.
function "rem" (A : Double_Uns; B : Single_Uns) return Double_Uns is
(A rem Double_Uns (B));
-- Length doubling remainder
function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean;
-- Determines if (3 * Single_Size)-bit value X1&X2&X3 <= Y1&Y2&Y3
function Lo (A : Double_Uns) return Single_Uns is
(Single_Uns (A and (2 ** Single_Size - 1)));
-- Low order half of double value
function Hi (A : Double_Uns) return Single_Uns is
(Single_Uns (Shift_Right (A, Single_Size)));
-- High order half of double value
procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns);
-- Computes X1&X2&X3 := X1&X2&X3 - Y1&Y1&Y3 mod 2 ** (3 * Single_Size)
function To_Neg_Int (A : Double_Uns) return Double_Int;
-- Convert to negative integer equivalent. If the input is in the range
-- 0 .. 2 ** (Double_Size - 1), then the corresponding nonpositive signed
-- integer (obtained by negating the given value) is returned, otherwise
-- constraint error is raised.
function To_Pos_Int (A : Double_Uns) return Double_Int;
-- Convert to positive integer equivalent. If the input is in the range
-- 0 .. 2 ** (Double_Size - 1) - 1, then the corresponding non-negative
-- signed integer is returned, otherwise constraint error is raised.
procedure Raise_Error;
pragma No_Return (Raise_Error);
-- Raise constraint error with appropriate message
--------------------------
-- Add_With_Ovflo_Check --
--------------------------
function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is
R : constant Double_Int := To_Int (To_Uns (X) + To_Uns (Y));
begin
if X >= 0 then
if Y < 0 or else R >= 0 then
return R;
end if;
else -- X < 0
if Y > 0 or else R < 0 then
return R;
end if;
end if;
Raise_Error;
end Add_With_Ovflo_Check;
-------------------
-- Double_Divide --
-------------------
procedure Double_Divide
(X, Y, Z : Double_Int;
Q, R : out Double_Int;
Round : Boolean)
is
Xu : constant Double_Uns := abs X;
Yu : constant Double_Uns := abs Y;
Yhi : constant Single_Uns := Hi (Yu);
Ylo : constant Single_Uns := Lo (Yu);
Zu : constant Double_Uns := abs Z;
Zhi : constant Single_Uns := Hi (Zu);
Zlo : constant Single_Uns := Lo (Zu);
T1, T2 : Double_Uns;
Du, Qu, Ru : Double_Uns;
Den_Pos : Boolean;
begin
if Yu = 0 or else Zu = 0 then
Raise_Error;
end if;
-- Set final signs (RM 4.5.5(27-30))
Den_Pos := (Y < 0) = (Z < 0);
-- Compute Y * Z. Note that if the result overflows Double_Uns, then
-- the rounded result is zero, except for the very special case where
-- X = -2 ** (Double_Size - 1) and abs(Y*Z) = 2 ** Double_Size, when
-- Round is True.
if Yhi /= 0 then
if Zhi /= 0 then
-- Handle the special case when Round is True
if Yhi = 1
and then Zhi = 1
and then Ylo = 0
and then Zlo = 0
and then X = Double_Int'First
and then Round
then
Q := (if Den_Pos then -1 else 1);
else
Q := 0;
end if;
R := X;
return;
else
T2 := Yhi * Zlo;
end if;
else
T2 := Ylo * Zhi;
end if;
T1 := Ylo * Zlo;
T2 := T2 + Hi (T1);
if Hi (T2) /= 0 then
-- Handle the special case when Round is True
if Hi (T2) = 1
and then Lo (T2) = 0
and then Lo (T1) = 0
and then X = Double_Int'First
and then Round
then
Q := (if Den_Pos then -1 else 1);
else
Q := 0;
end if;
R := X;
return;
end if;
Du := Lo (T2) & Lo (T1);
-- Check overflow case of largest negative number divided by -1
if X = Double_Int'First and then Du = 1 and then not Den_Pos then
Raise_Error;
end if;
-- Perform the actual division
pragma Assert (Du /= 0);
-- Multiplication of 2-limb arguments Yu and Zu leads to 4-limb result
-- (where each limb is a single value). Cases where 4 limbs are needed
-- require Yhi/=0 and Zhi/=0 and lead to early exit. Remaining cases
-- where 3 limbs are needed correspond to Hi(T2)/=0 and lead to early
-- exit. Thus, at this point, the result fits in 2 limbs which are
-- exactly Lo(T2) and Lo(T1), which corresponds to the value of Du.
-- As the case where one of Yu or Zu is null also led to early exit,
-- we have Du/=0 here.
Qu := Xu / Du;
Ru := Xu rem Du;
-- Deal with rounding case
if Round and then Ru > (Du - Double_Uns'(1)) / Double_Uns'(2) then
Qu := Qu + Double_Uns'(1);
end if;
-- Case of dividend (X) sign positive
if X >= 0 then
R := To_Int (Ru);
Q := (if Den_Pos then To_Int (Qu) else -To_Int (Qu));
-- Case of dividend (X) sign negative
-- We perform the unary minus operation on the unsigned value
-- before conversion to signed, to avoid a possible overflow
-- for value -2 ** (Double_Size - 1), both for computing R and Q.
else
R := To_Int (-Ru);
Q := (if Den_Pos then To_Int (-Qu) else To_Int (Qu));
end if;
end Double_Divide;
---------
-- Le3 --
---------
function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean is
begin
if X1 < Y1 then
return True;
elsif X1 > Y1 then
return False;
elsif X2 < Y2 then
return True;
elsif X2 > Y2 then
return False;
else
return X3 <= Y3;
end if;
end Le3;
-------------------------------
-- Multiply_With_Ovflo_Check --
-------------------------------
function Multiply_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is
Xu : constant Double_Uns := abs X;
Xhi : constant Single_Uns := Hi (Xu);
Xlo : constant Single_Uns := Lo (Xu);
Yu : constant Double_Uns := abs Y;
Yhi : constant Single_Uns := Hi (Yu);
Ylo : constant Single_Uns := Lo (Yu);
T1, T2 : Double_Uns;
begin
if Xhi /= 0 then
if Yhi /= 0 then
Raise_Error;
else
T2 := Xhi * Ylo;
end if;
elsif Yhi /= 0 then
T2 := Xlo * Yhi;
else -- Yhi = Xhi = 0
T2 := 0;
end if;
-- Here we have T2 set to the contribution to the upper half of the
-- result from the upper halves of the input values.
T1 := Xlo * Ylo;
T2 := T2 + Hi (T1);
if Hi (T2) /= 0 then
Raise_Error;
end if;
T2 := Lo (T2) & Lo (T1);
if X >= 0 then
if Y >= 0 then
return To_Pos_Int (T2);
pragma Annotate (CodePeer, Intentional, "precondition",
"Intentional Unsigned->Signed conversion");
else
return To_Neg_Int (T2);
end if;
else -- X < 0
if Y < 0 then
return To_Pos_Int (T2);
pragma Annotate (CodePeer, Intentional, "precondition",
"Intentional Unsigned->Signed conversion");
else
return To_Neg_Int (T2);
end if;
end if;
end Multiply_With_Ovflo_Check;
-----------------
-- Raise_Error --
-----------------
procedure Raise_Error is
begin
raise Constraint_Error with "Double arithmetic overflow";
end Raise_Error;
-------------------
-- Scaled_Divide --
-------------------
procedure Scaled_Divide
(X, Y, Z : Double_Int;
Q, R : out Double_Int;
Round : Boolean)
is
Xu : constant Double_Uns := abs X;
Xhi : constant Single_Uns := Hi (Xu);
Xlo : constant Single_Uns := Lo (Xu);
Yu : constant Double_Uns := abs Y;
Yhi : constant Single_Uns := Hi (Yu);
Ylo : constant Single_Uns := Lo (Yu);
Zu : Double_Uns := abs Z;
Zhi : Single_Uns := Hi (Zu);
Zlo : Single_Uns := Lo (Zu);
D : array (1 .. 4) of Single_Uns;
-- The dividend, four digits (D(1) is high order)
Qd : array (1 .. 2) of Single_Uns;
-- The quotient digits, two digits (Qd(1) is high order)
S1, S2, S3 : Single_Uns;
-- Value to subtract, three digits (S1 is high order)
Qu : Double_Uns;
Ru : Double_Uns;
-- Unsigned quotient and remainder
Mask : Single_Uns;
-- Mask of bits used to compute the scaling factor below
Scale : Natural;
-- Scaling factor used for multiple-precision divide. Dividend and
-- Divisor are multiplied by 2 ** Scale, and the final remainder is
-- divided by the scaling factor. The reason for this scaling is to
-- allow more accurate estimation of quotient digits.
Shift : Natural;
-- Shift factor used to compute the scaling factor above
T1, T2, T3 : Double_Uns;
-- Temporary values
begin
-- First do the multiplication, giving the four digit dividend
T1 := Xlo * Ylo;
D (4) := Lo (T1);
D (3) := Hi (T1);
if Yhi /= 0 then
T1 := Xlo * Yhi;
T2 := D (3) + Lo (T1);
D (3) := Lo (T2);
D (2) := Hi (T1) + Hi (T2);
if Xhi /= 0 then
T1 := Xhi * Ylo;
T2 := D (3) + Lo (T1);
D (3) := Lo (T2);
T3 := D (2) + Hi (T1);
T3 := T3 + Hi (T2);
D (2) := Lo (T3);
D (1) := Hi (T3);
T1 := (D (1) & D (2)) + Double_Uns'(Xhi * Yhi);
D (1) := Hi (T1);
D (2) := Lo (T1);
else
D (1) := 0;
end if;
else
if Xhi /= 0 then
T1 := Xhi * Ylo;
T2 := D (3) + Lo (T1);
D (3) := Lo (T2);
D (2) := Hi (T1) + Hi (T2);
else
D (2) := 0;
end if;
D (1) := 0;
end if;
-- Now it is time for the dreaded multiple precision division. First an
-- easy case, check for the simple case of a one digit divisor.
if Zhi = 0 then
if D (1) /= 0 or else D (2) >= Zlo then
Raise_Error;
-- Here we are dividing at most three digits by one digit
else
T1 := D (2) & D (3);
T2 := Lo (T1 rem Zlo) & D (4);
Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo);
Ru := T2 rem Zlo;
end if;
-- If divisor is double digit and dividend is too large, raise error
elsif (D (1) & D (2)) >= Zu then
Raise_Error;
-- This is the complex case where we definitely have a double digit
-- divisor and a dividend of at least three digits. We use the classical
-- multiple-precision division algorithm (see section (4.3.1) of Knuth's
-- "The Art of Computer Programming", Vol. 2 for a description
-- (algorithm D).
else
-- First normalize the divisor so that it has the leading bit on.
-- We do this by finding the appropriate left shift amount.
Shift := Single_Size / 2;
Mask := Shift_Left (2 ** (Single_Size / 2) - 1, Shift);
Scale := 0;
while Shift /= 0 loop
if (Hi (Zu) and Mask) = 0 then
Scale := Scale + Shift;
Zu := Shift_Left (Zu, Shift);
end if;
Shift := Shift / 2;
Mask := Shift_Left (Mask, Shift);
end loop;
Zhi := Hi (Zu);
Zlo := Lo (Zu);
pragma Assert (Zhi /= 0);
-- We have Hi(Zu)/=0 before normalization. The sequence of Shift_Left
-- operations results in the leading bit of Zu being 1 by moving the
-- leftmost 1-bit in Zu to leading position, thus Zhi=Hi(Zu)/=0 here.
-- Note that when we scale up the dividend, it still fits in four
-- digits, since we already tested for overflow, and scaling does
-- not change the invariant that (D (1) & D (2)) < Zu.
T1 := Shift_Left (D (1) & D (2), Scale);
D (1) := Hi (T1);
T2 := Shift_Left (0 & D (3), Scale);
D (2) := Lo (T1) or Hi (T2);
T3 := Shift_Left (0 & D (4), Scale);
D (3) := Lo (T2) or Hi (T3);
D (4) := Lo (T3);
-- Loop to compute quotient digits, runs twice for Qd(1) and Qd(2)
for J in 0 .. 1 loop
-- Compute next quotient digit. We have to divide three digits by
-- two digits. We estimate the quotient by dividing the leading
-- two digits by the leading digit. Given the scaling we did above
-- which ensured the first bit of the divisor is set, this gives
-- an estimate of the quotient that is at most two too high.
Qd (J + 1) := (if D (J + 1) = Zhi
then 2 ** Single_Size - 1
else Lo ((D (J + 1) & D (J + 2)) / Zhi));
-- Compute amount to subtract
T1 := Qd (J + 1) * Zlo;
T2 := Qd (J + 1) * Zhi;
S3 := Lo (T1);
T1 := Hi (T1) + Lo (T2);
S2 := Lo (T1);
S1 := Hi (T1) + Hi (T2);
-- Adjust quotient digit if it was too high
-- We use the version of the algorithm in the 2nd Edition of
-- "The Art of Computer Programming". This had a bug not
-- discovered till 1995, see Vol 2 errata:
-- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz.
-- Under rare circumstances the expression in the test could
-- overflow. This version was further corrected in 2005, see
-- Vol 2 errata:
-- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz.
-- This implementation is not impacted by these bugs, due to the
-- use of a word-size comparison done in function Le3 instead of
-- a comparison on two-word integer quantities in the original
-- algorithm.
loop
exit when Le3 (S1, S2, S3, D (J + 1), D (J + 2), D (J + 3));
Qd (J + 1) := Qd (J + 1) - 1;
Sub3 (S1, S2, S3, 0, Zhi, Zlo);
end loop;
-- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step
Sub3 (D (J + 1), D (J + 2), D (J + 3), S1, S2, S3);
end loop;
-- The two quotient digits are now set, and the remainder of the
-- scaled division is in D3&D4. To get the remainder for the
-- original unscaled division, we rescale this dividend.
-- We rescale the divisor as well, to make the proper comparison
-- for rounding below.
Qu := Qd (1) & Qd (2);
Ru := Shift_Right (D (3) & D (4), Scale);
Zu := Shift_Right (Zu, Scale);
end if;
-- Deal with rounding case
if Round and then Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2) then
-- Protect against wrapping around when rounding, by signaling
-- an overflow when the quotient is too large.
if Qu = Double_Uns'Last then
Raise_Error;
end if;
Qu := Qu + Double_Uns'(1);
end if;
-- Set final signs (RM 4.5.5(27-30))
-- Case of dividend (X * Y) sign positive
if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then
R := To_Pos_Int (Ru);
Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu));
-- Case of dividend (X * Y) sign negative
else
R := To_Neg_Int (Ru);
Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu));
end if;
end Scaled_Divide;
----------
-- Sub3 --
----------
procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns) is
begin
if Y3 > X3 then
if X2 = 0 then
X1 := X1 - 1;
end if;
X2 := X2 - 1;
end if;
X3 := X3 - Y3;
if Y2 > X2 then
X1 := X1 - 1;
end if;
X2 := X2 - Y2;
X1 := X1 - Y1;
end Sub3;
-------------------------------
-- Subtract_With_Ovflo_Check --
-------------------------------
function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is
R : constant Double_Int := To_Int (To_Uns (X) - To_Uns (Y));
begin
if X >= 0 then
if Y > 0 or else R >= 0 then
return R;
end if;
else -- X < 0
if Y <= 0 or else R < 0 then
return R;
end if;
end if;
Raise_Error;
end Subtract_With_Ovflo_Check;
----------------
-- To_Neg_Int --
----------------
function To_Neg_Int (A : Double_Uns) return Double_Int is
R : constant Double_Int :=
(if A = 2 ** (Double_Size - 1) then Double_Int'First else -To_Int (A));
-- Note that we can't just use the expression of the Else, because it
-- overflows for A = 2 ** (Double_Size - 1).
begin
if R <= 0 then
return R;
else
Raise_Error;
end if;
end To_Neg_Int;
----------------
-- To_Pos_Int --
----------------
function To_Pos_Int (A : Double_Uns) return Double_Int is
R : constant Double_Int := To_Int (A);
begin
if R >= 0 then
return R;
else
Raise_Error;
end if;
end To_Pos_Int;
end System.Arith_Double;

94
gcc/ada/libgnat/s-aridou.ads Normal file
View file

@ -0,0 +1,94 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . A R I T H _ D O U B L E --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- This package provides software routines for doing arithmetic on "double"
-- signed integer values in cases where either overflow checking is required,
-- or intermediate results are longer than the result type.
generic
type Double_Int is range <>;
type Double_Uns is mod <>;
type Single_Uns is mod <>;
with function Shift_Left (A : Double_Uns; B : Natural) return Double_Uns
is <>;
with function Shift_Right (A : Double_Uns; B : Natural) return Double_Uns
is <>;
with function Shift_Left (A : Single_Uns; B : Natural) return Single_Uns
is <>;
package System.Arith_Double is
pragma Pure;
function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int;
-- Raises Constraint_Error if sum of operands overflows Double_Int,
-- otherwise returns the signed integer sum.
function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int;
-- Raises Constraint_Error if difference of operands overflows Double_Int,
-- otherwise returns the signed integer difference.
function Multiply_With_Ovflo_Check (X, Y : Double_Int) return Double_Int;
pragma Convention (C, Multiply_With_Ovflo_Check);
-- Raises Constraint_Error if product of operands overflows Double_Int,
-- otherwise returns the signed integer product. Gigi may also call this
-- routine directly.
procedure Scaled_Divide
(X, Y, Z : Double_Int;
Q, R : out Double_Int;
Round : Boolean);
-- Performs the division of (X * Y) / Z, storing the quotient in Q
-- and the remainder in R. Constraint_Error is raised if Z is zero,
-- or if the quotient does not fit in Double_Int. Round indicates if
-- the result should be rounded. If Round is False, then Q, R are
-- the normal quotient and remainder from a truncating division.
-- If Round is True, then Q is the rounded quotient. The remainder
-- R is not affected by the setting of the Round flag.
procedure Double_Divide
(X, Y, Z : Double_Int;
Q, R : out Double_Int;
Round : Boolean);
-- Performs the division X / (Y * Z), storing the quotient in Q and
-- the remainder in R. Constraint_Error is raised if Y or Z is zero,
-- or if the quotient does not fit in Double_Int. Round indicates if the
-- result should be rounded. If Round is False, then Q, R are the normal
-- quotient and remainder from a truncating division. If Round is True,
-- then Q is the rounded quotient. The remainder R is not affected by the
-- setting of the Round flag.
end System.Arith_Double;

64
gcc/ada/libgnat/s-arit128.adb Normal file
View file

@ -0,0 +1,64 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . A R I T H _ 1 2 8 --
-- --
-- B o d y --
-- --
-- Copyright (C) 2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Arith_Double;
package body System.Arith_128 is
subtype Uns128 is Interfaces.Unsigned_128;
subtype Uns64 is Interfaces.Unsigned_64;
use Interfaces;
package Impl is new Arith_Double (Int128, Uns128, Uns64);
function Add_With_Ovflo_Check128 (X, Y : Int128) return Int128
renames Impl.Add_With_Ovflo_Check;
function Subtract_With_Ovflo_Check128 (X, Y : Int128) return Int128
renames Impl.Subtract_With_Ovflo_Check;
function Multiply_With_Ovflo_Check128 (X, Y : Int128) return Int128
renames Impl.Multiply_With_Ovflo_Check;
procedure Scaled_Divide128
(X, Y, Z : Int128;
Q, R : out Int128;
Round : Boolean)
renames Impl.Scaled_Divide;
procedure Double_Divide128
(X, Y, Z : Int128;
Q, R : out Int128;
Round : Boolean)
renames Impl.Double_Divide;
end System.Arith_128;

84
gcc/ada/libgnat/s-arit128.ads Normal file
View file

@ -0,0 +1,84 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . A R I T H _ 1 2 8 --
-- --
-- S p e c --
-- --
-- Copyright (C) 2020, 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. --
-- --
------------------------------------------------------------------------------
-- This unit provides software routines for doing arithmetic on 128-bit
-- signed integer values in cases where either overflow checking is
-- required, or intermediate results are longer than 128 bits.
pragma Restrictions (No_Elaboration_Code);
-- Allow direct call from gigi generated code
with Interfaces;
package System.Arith_128 is
pragma Pure;
subtype Int128 is Interfaces.Integer_128;
function Add_With_Ovflo_Check128 (X, Y : Int128) return Int128;
-- Raises Constraint_Error if sum of operands overflows 128 bits,
-- otherwise returns the 128-bit signed integer sum.
function Subtract_With_Ovflo_Check128 (X, Y : Int128) return Int128;
-- Raises Constraint_Error if difference of operands overflows 128
-- bits, otherwise returns the 128-bit signed integer difference.
function Multiply_With_Ovflo_Check128 (X, Y : Int128) return Int128;
pragma Export (C, Multiply_With_Ovflo_Check128, "__gnat_mulv128");
-- Raises Constraint_Error if product of operands overflows 128
-- bits, otherwise returns the 128-bit signed integer product.
-- Gigi may also call this routine directly.
procedure Scaled_Divide128
(X, Y, Z : Int128;
Q, R : out Int128;
Round : Boolean);
-- Performs the division of (X * Y) / Z, storing the quotient in Q
-- and the remainder in R. Constraint_Error is raised if Z is zero,
-- or if the quotient does not fit in 128 bits. Round indicates if
-- the result should be rounded. If Round is False, then Q, R are
-- the normal quotient and remainder from a truncating division.
-- If Round is True, then Q is the rounded quotient. The remainder
-- R is not affected by the setting of the Round flag.
procedure Double_Divide128
(X, Y, Z : Int128;
Q, R : out Int128;
Round : Boolean);
-- Performs the division X / (Y * Z), storing the quotient in Q and
-- the remainder in R. Constraint_Error is raised if Y or Z is zero,
-- or if the quotient does not fit in 128 bits. Round indicates if the
-- result should be rounded. If Round is False, then Q, R are the normal
-- quotient and remainder from a truncating division. If Round is True,
-- then Q is the rounded quotient. The remainder R is not affected by the
-- setting of the Round flag.
end System.Arith_128;

643
gcc/ada/libgnat/s-arit64.adb
View file

@ -29,649 +29,36 @@
-- --
------------------------------------------------------------------------------
with Interfaces; use Interfaces;
with Ada.Unchecked_Conversion;
with System.Arith_Double;
package body System.Arith_64 is
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
subtype Uns64 is Interfaces.Unsigned_64;
subtype Uns32 is Interfaces.Unsigned_32;
subtype Uns64 is Unsigned_64;
function To_Uns is new Ada.Unchecked_Conversion (Int64, Uns64);
function To_Int is new Ada.Unchecked_Conversion (Uns64, Int64);
use Interfaces;
subtype Uns32 is Unsigned_32;
package Impl is new Arith_Double (Int64, Uns64, Uns32);
-----------------------
-- Local Subprograms --
-----------------------
function Add_With_Ovflo_Check64 (X, Y : Int64) return Int64
renames Impl.Add_With_Ovflo_Check;
function "+" (A, B : Uns32) return Uns64 is (Uns64 (A) + Uns64 (B));
function "+" (A : Uns64; B : Uns32) return Uns64 is (A + Uns64 (B));
-- Length doubling additions
function Subtract_With_Ovflo_Check64 (X, Y : Int64) return Int64
renames Impl.Subtract_With_Ovflo_Check;
function "*" (A, B : Uns32) return Uns64 is (Uns64 (A) * Uns64 (B));
-- Length doubling multiplication
function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64
renames Impl.Multiply_With_Ovflo_Check;
function "/" (A : Uns64; B : Uns32) return Uns64 is (A / Uns64 (B));
-- Length doubling division
function "&" (Hi, Lo : Uns32) return Uns64 is
(Shift_Left (Uns64 (Hi), 32) or Uns64 (Lo));
-- Concatenate hi, lo values to form 64-bit result
function "abs" (X : Int64) return Uns64 is
(if X = Int64'First then 2**63 else Uns64 (Int64'(abs X)));
-- Convert absolute value of X to unsigned. Note that we can't just use
-- the expression of the Else, because it overflows for X = Int64'First.
function "rem" (A : Uns64; B : Uns32) return Uns64 is (A rem Uns64 (B));
-- Length doubling remainder
function Le3 (X1, X2, X3 : Uns32; Y1, Y2, Y3 : Uns32) return Boolean;
-- Determines if 96 bit value X1&X2&X3 <= Y1&Y2&Y3
function Lo (A : Uns64) return Uns32 is (Uns32 (A and 16#FFFF_FFFF#));
-- Low order half of 64-bit value
function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32)));
-- High order half of 64-bit value
procedure Sub3 (X1, X2, X3 : in out Uns32; Y1, Y2, Y3 : Uns32);
-- Computes X1&X2&X3 := X1&X2&X3 - Y1&Y1&Y3 with mod 2**96 wrap
function To_Neg_Int (A : Uns64) return Int64 with Inline;
-- Convert to negative integer equivalent. If the input is in the range
-- 0 .. 2 ** 63, then the corresponding negative signed integer (obtained
-- by negating the given value) is returned, otherwise constraint error
-- is raised.
function To_Pos_Int (A : Uns64) return Int64 with Inline;
-- Convert to positive integer equivalent. If the input is in the range
-- 0 .. 2 ** 63-1, then the corresponding non-negative signed integer is
-- returned, otherwise constraint error is raised.
procedure Raise_Error with Inline;
pragma No_Return (Raise_Error);
-- Raise constraint error with appropriate message
--------------------------
-- Add_With_Ovflo_Check --
--------------------------
function Add_With_Ovflo_Check (X, Y : Int64) return Int64 is
R : constant Int64 := To_Int (To_Uns (X) + To_Uns (Y));
begin
if X >= 0 then
if Y < 0 or else R >= 0 then
return R;
end if;
else -- X < 0
if Y > 0 or else R < 0 then
return R;
end if;
end if;
Raise_Error;
end Add_With_Ovflo_Check;
-------------------
-- Double_Divide --
-------------------
procedure Double_Divide
procedure Scaled_Divide64
(X, Y, Z : Int64;
Q, R : out Int64;
Round : Boolean)
is
Xu : constant Uns64 := abs X;
Yu : constant Uns64 := abs Y;
renames Impl.Scaled_Divide;
Yhi : constant Uns32 := Hi (Yu);
Ylo : constant Uns32 := Lo (Yu);
Zu : constant Uns64 := abs Z;
Zhi : constant Uns32 := Hi (Zu);
Zlo : constant Uns32 := Lo (Zu);
T1, T2 : Uns64;
Du, Qu, Ru : Uns64;
Den_Pos : Boolean;
begin
if Yu = 0 or else Zu = 0 then
Raise_Error;
end if;
-- Set final signs (RM 4.5.5(27-30))
Den_Pos := (Y < 0) = (Z < 0);
-- Compute Y * Z. Note that if the result overflows 64 bits unsigned,
-- then the rounded result is zero, except for the very special case
-- where X = -2**63 and abs(Y*Z) = 2**64, when Round is True.
if Yhi /= 0 then
if Zhi /= 0 then
-- Handle the special case when Round is True
if Yhi = 1
and then Zhi = 1
and then Ylo = 0
and then Zlo = 0
and then X = Int64'First
and then Round
then
Q := (if Den_Pos then -1 else 1);
else
Q := 0;
end if;
R := X;
return;
else
T2 := Yhi * Zlo;
end if;
else
T2 := Ylo * Zhi;
end if;
T1 := Ylo * Zlo;
T2 := T2 + Hi (T1);
if Hi (T2) /= 0 then
-- Handle the special case when Round is True
if Hi (T2) = 1
and then Lo (T2) = 0
and then Lo (T1) = 0
and then X = Int64'First
and then Round
then
Q := (if Den_Pos then -1 else 1);
else
Q := 0;
end if;
R := X;
return;
end if;
Du := Lo (T2) & Lo (T1);
-- Check overflow case of largest negative number divided by -1
if X = Int64'First and then Du = 1 and then not Den_Pos then
Raise_Error;
end if;
-- Perform the actual division
pragma Assert (Du /= 0);
-- Multiplication of 2-limbs arguments Yu and Zu leads to 4-limbs
-- result (where each limb is 32bits). Cases where 4 limbs are needed
-- require Yhi/=0 and Zhi/=0 and lead to early exit. Remaining cases
-- where 3 limbs are needed correspond to Hi(T2)/=0 and lead to
-- early exit. Thus at this point result fits in 2 limbs which are
-- exactly Lo(T2) and Lo(T1), which corresponds to the value of Du.
-- As the case where one of Yu or Zu is null also led to early exit,
-- Du/=0 here.
Qu := Xu / Du;
Ru := Xu rem Du;
-- Deal with rounding case
if Round and then Ru > (Du - Uns64'(1)) / Uns64'(2) then
Qu := Qu + Uns64'(1);
end if;
-- Case of dividend (X) sign positive
if X >= 0 then
R := To_Int (Ru);
Q := (if Den_Pos then To_Int (Qu) else -To_Int (Qu));
-- Case of dividend (X) sign negative
-- We perform the unary minus operation on the unsigned value
-- before conversion to signed, to avoid a possible overflow for
-- value -2**63, both for computing R and Q.
else
R := To_Int (-Ru);
Q := (if Den_Pos then To_Int (-Qu) else To_Int (Qu));
end if;
end Double_Divide;
---------
-- Le3 --
---------
function Le3 (X1, X2, X3 : Uns32; Y1, Y2, Y3 : Uns32) return Boolean is
begin
if X1 < Y1 then
return True;
elsif X1 > Y1 then
return False;
elsif X2 < Y2 then
return True;
elsif X2 > Y2 then
return False;
else
return X3 <= Y3;
end if;
end Le3;
-------------------------------
-- Multiply_With_Ovflo_Check --
-------------------------------
function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64 is
Xu : constant Uns64 := abs X;
Xhi : constant Uns32 := Hi (Xu);
Xlo : constant Uns32 := Lo (Xu);
Yu : constant Uns64 := abs Y;
Yhi : constant Uns32 := Hi (Yu);
Ylo : constant Uns32 := Lo (Yu);
T1, T2 : Uns64;
begin
if Xhi /= 0 then
if Yhi /= 0 then
Raise_Error;
else
T2 := Xhi * Ylo;
end if;
elsif Yhi /= 0 then
T2 := Xlo * Yhi;
else -- Yhi = Xhi = 0
T2 := 0;
end if;
-- Here we have T2 set to the contribution to the upper half of the
-- result from the upper halves of the input values.
T1 := Xlo * Ylo;
T2 := T2 + Hi (T1);
if Hi (T2) /= 0 then
Raise_Error;
end if;
T2 := Lo (T2) & Lo (T1);
if X >= 0 then
if Y >= 0 then
return To_Pos_Int (T2);
pragma Annotate (CodePeer, Intentional, "precondition",
"Intentional Unsigned->Signed conversion");
else
return To_Neg_Int (T2);
end if;
else -- X < 0
if Y < 0 then
return To_Pos_Int (T2);
pragma Annotate (CodePeer, Intentional, "precondition",
"Intentional Unsigned->Signed conversion");
else
return To_Neg_Int (T2);
end if;
end if;
end Multiply_With_Ovflo_Check;
-----------------
-- Raise_Error --
-----------------
procedure Raise_Error is
begin
raise Constraint_Error with "64-bit arithmetic overflow";
end Raise_Error;
-------------------
-- Scaled_Divide --
-------------------
procedure Scaled_Divide
procedure Double_Divide64
(X, Y, Z : Int64;
Q, R : out Int64;
Round : Boolean)
is
Xu : constant Uns64 := abs X;
Xhi : constant Uns32 := Hi (Xu);
Xlo : constant Uns32 := Lo (Xu);
Yu : constant Uns64 := abs Y;
Yhi : constant Uns32 := Hi (Yu);
Ylo : constant Uns32 := Lo (Yu);
Zu : Uns64 := abs Z;
Zhi : Uns32 := Hi (Zu);
Zlo : Uns32 := Lo (Zu);
D : array (1 .. 4) of Uns32;
-- The dividend, four digits (D(1) is high order)
Qd : array (1 .. 2) of Uns32;
-- The quotient digits, two digits (Qd(1) is high order)
S1, S2, S3 : Uns32;
-- Value to subtract, three digits (S1 is high order)
Qu : Uns64;
Ru : Uns64;
-- Unsigned quotient and remainder
Scale : Natural;
-- Scaling factor used for multiple-precision divide. Dividend and
-- Divisor are multiplied by 2 ** Scale, and the final remainder is
-- divided by the scaling factor. The reason for this scaling is to
-- allow more accurate estimation of quotient digits.
T1, T2, T3 : Uns64;
-- Temporary values
begin
-- First do the multiplication, giving the four digit dividend
T1 := Xlo * Ylo;
D (4) := Lo (T1);
D (3) := Hi (T1);
if Yhi /= 0 then
T1 := Xlo * Yhi;
T2 := D (3) + Lo (T1);
D (3) := Lo (T2);
D (2) := Hi (T1) + Hi (T2);
if Xhi /= 0 then
T1 := Xhi * Ylo;
T2 := D (3) + Lo (T1);
D (3) := Lo (T2);
T3 := D (2) + Hi (T1);
T3 := T3 + Hi (T2);
D (2) := Lo (T3);
D (1) := Hi (T3);
T1 := (D (1) & D (2)) + Uns64'(Xhi * Yhi);
D (1) := Hi (T1);
D (2) := Lo (T1);
else
D (1) := 0;
end if;
else
if Xhi /= 0 then
T1 := Xhi * Ylo;
T2 := D (3) + Lo (T1);
D (3) := Lo (T2);
D (2) := Hi (T1) + Hi (T2);
else
D (2) := 0;
end if;
D (1) := 0;
end if;
-- Now it is time for the dreaded multiple precision division. First an
-- easy case, check for the simple case of a one digit divisor.
if Zhi = 0 then
if D (1) /= 0 or else D (2) >= Zlo then
Raise_Error;
-- Here we are dividing at most three digits by one digit
else
T1 := D (2) & D (3);
T2 := Lo (T1 rem Zlo) & D (4);
Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo);
Ru := T2 rem Zlo;
end if;
-- If divisor is double digit and dividend is too large, raise error
elsif (D (1) & D (2)) >= Zu then
Raise_Error;
-- This is the complex case where we definitely have a double digit
-- divisor and a dividend of at least three digits. We use the classical
-- multiple-precision division algorithm (see section (4.3.1) of Knuth's
-- "The Art of Computer Programming", Vol. 2 for a description
-- (algorithm D).
else
-- First normalize the divisor so that it has the leading bit on.
-- We do this by finding the appropriate left shift amount.
Scale := 0;
if (Zhi and 16#FFFF0000#) = 0 then
Scale := 16;
Zu := Shift_Left (Zu, 16);
end if;
if (Hi (Zu) and 16#FF00_0000#) = 0 then
Scale := Scale + 8;
Zu := Shift_Left (Zu, 8);
end if;
if (Hi (Zu) and 16#F000_0000#) = 0 then
Scale := Scale + 4;
Zu := Shift_Left (Zu, 4);
end if;
if (Hi (Zu) and 16#C000_0000#) = 0 then
Scale := Scale + 2;
Zu := Shift_Left (Zu, 2);
end if;
if (Hi (Zu) and 16#8000_0000#) = 0 then
Scale := Scale + 1;
Zu := Shift_Left (Zu, 1);
end if;
Zhi := Hi (Zu);
Zlo := Lo (Zu);
pragma Assert (Zhi /= 0);
-- Hi(Zu)/=0 before normalization. The sequence of Shift_Left
-- operations results in the leading bit of Zu being 1 by moving
-- the leftmost 1-bit in Zu to leading position, thus Zhi=Hi(Zu)/=0
-- here.
-- Note that when we scale up the dividend, it still fits in four
-- digits, since we already tested for overflow, and scaling does
-- not change the invariant that (D (1) & D (2)) < Zu.
T1 := Shift_Left (D (1) & D (2), Scale);
D (1) := Hi (T1);
T2 := Shift_Left (0 & D (3), Scale);
D (2) := Lo (T1) or Hi (T2);
T3 := Shift_Left (0 & D (4), Scale);
D (3) := Lo (T2) or Hi (T3);
D (4) := Lo (T3);
-- Loop to compute quotient digits, runs twice for Qd(1) and Qd(2)
for J in 0 .. 1 loop
-- Compute next quotient digit. We have to divide three digits by
-- two digits. We estimate the quotient by dividing the leading
-- two digits by the leading digit. Given the scaling we did above
-- which ensured the first bit of the divisor is set, this gives
-- an estimate of the quotient that is at most two too high.
Qd (J + 1) := (if D (J + 1) = Zhi
then 2 ** 32 - 1
else Lo ((D (J + 1) & D (J + 2)) / Zhi));
-- Compute amount to subtract
T1 := Qd (J + 1) * Zlo;
T2 := Qd (J + 1) * Zhi;
S3 := Lo (T1);
T1 := Hi (T1) + Lo (T2);
S2 := Lo (T1);
S1 := Hi (T1) + Hi (T2);
-- Adjust quotient digit if it was too high
-- We use the version of the algorithm in the 2nd Edition of
-- "The Art of Computer Programming". This had a bug not
-- discovered till 1995, see Vol 2 errata:
-- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz.
-- Under rare circumstances the expression in the test could
-- overflow. This version was further corrected in 2005, see
-- Vol 2 errata:
-- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz.
-- This implementation is not impacted by these bugs, due to the
-- use of a word-size comparison done in function Le3 instead of
-- a comparison on two-word integer quantities in the original
-- algorithm.
loop
exit when Le3 (S1, S2, S3, D (J + 1), D (J + 2), D (J + 3));
Qd (J + 1) := Qd (J + 1) - 1;
Sub3 (S1, S2, S3, 0, Zhi, Zlo);
end loop;
-- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step
Sub3 (D (J + 1), D (J + 2), D (J + 3), S1, S2, S3);
end loop;
-- The two quotient digits are now set, and the remainder of the
-- scaled division is in D3&D4. To get the remainder for the
-- original unscaled division, we rescale this dividend.
-- We rescale the divisor as well, to make the proper comparison
-- for rounding below.
Qu := Qd (1) & Qd (2);
Ru := Shift_Right (D (3) & D (4), Scale);
Zu := Shift_Right (Zu, Scale);
end if;
-- Deal with rounding case
if Round and then Ru > (Zu - Uns64'(1)) / Uns64'(2) then
-- Protect against wrapping around when rounding, by signaling
-- an overflow when the quotient is too large.
if Qu = Uns64'Last then
Raise_Error;
end if;
Qu := Qu + Uns64 (1);
end if;
-- Set final signs (RM 4.5.5(27-30))
-- Case of dividend (X * Y) sign positive
if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then
R := To_Pos_Int (Ru);
Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu));
-- Case of dividend (X * Y) sign negative
else
R := To_Neg_Int (Ru);
Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu));
end if;
end Scaled_Divide;
----------
-- Sub3 --
----------
procedure Sub3 (X1, X2, X3 : in out Uns32; Y1, Y2, Y3 : Uns32) is
begin
if Y3 > X3 then
if X2 = 0 then
X1 := X1 - 1;
end if;
X2 := X2 - 1;
end if;
X3 := X3 - Y3;
if Y2 > X2 then
X1 := X1 - 1;
end if;
X2 := X2 - Y2;
X1 := X1 - Y1;
end Sub3;
-------------------------------
-- Subtract_With_Ovflo_Check --
-------------------------------
function Subtract_With_Ovflo_Check (X, Y : Int64) return Int64 is
R : constant Int64 := To_Int (To_Uns (X) - To_Uns (Y));
begin
if X >= 0 then
if Y > 0 or else R >= 0 then
return R;
end if;
else -- X < 0
if Y <= 0 or else R < 0 then
return R;
end if;
end if;
Raise_Error;
end Subtract_With_Ovflo_Check;
----------------
-- To_Neg_Int --
----------------
function To_Neg_Int (A : Uns64) return Int64 is
R : constant Int64 := (if A = 2**63 then Int64'First else -To_Int (A));
-- Note that we can't just use the expression of the Else, because it
-- overflows for A = 2**63.
begin
if R <= 0 then
return R;
else
Raise_Error;
end if;
end To_Neg_Int;
----------------
-- To_Pos_Int --
----------------
function To_Pos_Int (A : Uns64) return Int64 is
R : constant Int64 := To_Int (A);
begin
if R >= 0 then
return R;
else
Raise_Error;
end if;
end To_Pos_Int;
renames Impl.Double_Divide;
end System.Arith_64;

30
gcc/ada/libgnat/s-arit64.ads
View file

@ -43,42 +43,54 @@ package System.Arith_64 is
subtype Int64 is Interfaces.Integer_64;
function Add_With_Ovflo_Check (X, Y : Int64) return Int64;
function Add_With_Ovflo_Check64 (X, Y : Int64) return Int64;
-- Raises Constraint_Error if sum of operands overflows 64 bits,
-- otherwise returns the 64-bit signed integer sum.
function Subtract_With_Ovflo_Check (X, Y : Int64) return Int64;
function Subtract_With_Ovflo_Check64 (X, Y : Int64) return Int64;
-- Raises Constraint_Error if difference of operands overflows 64
-- bits, otherwise returns the 64-bit signed integer difference.
function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64;
pragma Export (C, Multiply_With_Ovflo_Check, "__gnat_mulv64");
function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64;
pragma Export (C, Multiply_With_Ovflo_Check64, "__gnat_mulv64");
-- Raises Constraint_Error if product of operands overflows 64
-- bits, otherwise returns the 64-bit signed integer product.
-- GIGI may also call this routine directly.
-- Gigi may also call this routine directly.
procedure Scaled_Divide
procedure Scaled_Divide64
(X, Y, Z : Int64;
Q, R : out Int64;
Round : Boolean);
-- Performs the division of (X * Y) / Z, storing the quotient in Q
-- and the remainder in R. Constraint_Error is raised if Z is zero,
-- or if the quotient does not fit in 64-bits. Round indicates if
-- or if the quotient does not fit in 64 bits. Round indicates if
-- the result should be rounded. If Round is False, then Q, R are
-- the normal quotient and remainder from a truncating division.
-- If Round is True, then Q is the rounded quotient. The remainder
-- R is not affected by the setting of the Round flag.
procedure Double_Divide
procedure Scaled_Divide
(X, Y, Z : Int64;
Q, R : out Int64;
Round : Boolean) renames Scaled_Divide64;
-- Renamed procedure to preserve compatibility with earlier versions
procedure Double_Divide64
(X, Y, Z : Int64;
Q, R : out Int64;
Round : Boolean);
-- Performs the division X / (Y * Z), storing the quotient in Q and
-- the remainder in R. Constraint_Error is raised if Y or Z is zero,
-- or if the quotient does not fit in 64-bits. Round indicates if the
-- or if the quotient does not fit in 64 bits. Round indicates if the
-- result should be rounded. If Round is False, then Q, R are the normal
-- quotient and remainder from a truncating division. If Round is True,
-- then Q is the rounded quotient. The remainder R is not affected by the
-- setting of the Round flag.
procedure Double_Divide
(X, Y, Z : Int64;
Q, R : out Int64;
Round : Boolean) renames Double_Divide64;
-- Renamed procedure to preserve compatibility with earlier versions
end System.Arith_64;

12
gcc/ada/libgnat/s-bytswa.ads
View file

@ -33,13 +33,16 @@
-- (supporting alternative byte ordering), and by the GNAT.Byte_Swapping run
-- time package which provides user level routines for byte swapping.
with Interfaces;
package System.Byte_Swapping is
pragma Pure;
type U16 is mod 2**16;
type U32 is mod 2**32;
type U64 is mod 2**64;
subtype U16 is Interfaces.Unsigned_16;
subtype U32 is Interfaces.Unsigned_32;
subtype U64 is Interfaces.Unsigned_64;
subtype U128 is Interfaces.Unsigned_128;
function Bswap_16 (X : U16) return U16;
pragma Import (Intrinsic, Bswap_16, "__builtin_bswap16");
@ -50,4 +53,7 @@ package System.Byte_Swapping is
function Bswap_64 (X : U64) return U64;
pragma Import (Intrinsic, Bswap_64, "__builtin_bswap64");
function Bswap_128 (X : U128) return U128;
pragma Import (Intrinsic, Bswap_128, "__builtin_bswap128");
end System.Byte_Swapping;

116
gcc/ada/libgnat/s-casi128.adb Normal file
View file

@ -0,0 +1,116 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY COMPONENTS --
-- --
-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 1 2 8 --
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Address_Operations; use System.Address_Operations;
with Ada.Unchecked_Conversion;
package body System.Compare_Array_Signed_128 is
type Word is range -2**127 .. 2**127 - 1;
for Word'Size use 128;
-- Used to process operands by 128-bit words
type Uword is new Word;
for Uword'Alignment use 1;
-- Used to process operands when unaligned
type WP is access Word;
type UP is access Uword;
function W is new Ada.Unchecked_Conversion (Address, WP);
function U is new Ada.Unchecked_Conversion (Address, UP);
------------------------
-- Compare_Array_S128 --
------------------------
function Compare_Array_S128
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural) return Integer
is
Clen : Natural := Natural'Min (Left_Len, Right_Len);
-- Number of elements left to compare
L : Address := Left;
R : Address := Right;
-- Pointers to next elements to compare
begin
-- Case of going by aligned quadruple words
if ModA (OrA (Left, Right), 16) = 0 then
while Clen /= 0 loop
if W (L).all /= W (R).all then
if W (L).all > W (R).all then
return +1;
else
return -1;
end if;
end if;
Clen := Clen - 1;
L := AddA (L, 16);
R := AddA (R, 16);
end loop;
-- Case of going by unaligned quadruple words
else
while Clen /= 0 loop
if U (L).all /= U (R).all then
if U (L).all > U (R).all then
return +1;
else
return -1;
end if;
end if;
Clen := Clen - 1;
L := AddA (L, 16);
R := AddA (R, 16);
end loop;
end if;
-- Here if common section equal, result decided by lengths
if Left_Len = Right_Len then
return 0;
elsif Left_Len > Right_Len then
return +1;
else
return -1;
end if;
end Compare_Array_S128;
end System.Compare_Array_Signed_128;

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

@ -0,0 +1,52 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY COMPONENTS --
-- --
-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 1 2 8 --
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2020, 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. --
-- --
------------------------------------------------------------------------------
-- This package contains functions for runtime comparisons on arrays whose
-- elements are 128-bit discrete type values to be treated as signed.
package System.Compare_Array_Signed_128 is
-- Note: although the functions in this package are in a sense Pure, the
-- package cannot be declared as Pure, since the arguments are addresses,
-- not the data, and the result is not pure wrt the address values.
function Compare_Array_S128
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural) return Integer;
-- Compare the array starting at address Left of length Left_Len
-- with the array starting at address Right of length Right_Len.
-- The comparison is in the normal Ada semantic sense of array
-- comparison. The result is -1,0,+1 for Left<Right, Left=Right,
-- Left>Right respectively.
end System.Compare_Array_Signed_128;

115
gcc/ada/libgnat/s-caun128.adb Normal file
View file

@ -0,0 +1,115 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY COMPONENTS --
-- --
-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 1 2 8 --
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Address_Operations; use System.Address_Operations;
with Ada.Unchecked_Conversion;
package body System.Compare_Array_Unsigned_128 is
type Word is mod 2 ** 128;
-- Used to process operands by 128-bit words
type Uword is new Word;
for Uword'Alignment use 1;
-- Used to process operands when unaligned
type WP is access Word;
type UP is access Uword;
function W is new Ada.Unchecked_Conversion (Address, WP);
function U is new Ada.Unchecked_Conversion (Address, UP);
------------------------
-- Compare_Array_U128 --
------------------------
function Compare_Array_U128
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural) return Integer
is
Clen : Natural := Natural'Min (Left_Len, Right_Len);
-- Number of elements left to compare
L : Address := Left;
R : Address := Right;
-- Pointers to next elements to compare
begin
-- Case of going by aligned quadruple words
if ModA (OrA (Left, Right), 16) = 0 then
while Clen /= 0 loop
if W (L).all /= W (R).all then
if W (L).all > W (R).all then
return +1;
else
return -1;
end if;
end if;
Clen := Clen - 1;
L := AddA (L, 16);
R := AddA (R, 16);
end loop;
-- Case of going by unaligned quadruple words
else
while Clen /= 0 loop
if U (L).all /= U (R).all then
if U (L).all > U (R).all then
return +1;
else
return -1;
end if;
end if;
Clen := Clen - 1;
L := AddA (L, 16);
R := AddA (R, 16);
end loop;
end if;
-- Here if common section equal, result decided by lengths
if Left_Len = Right_Len then
return 0;
elsif Left_Len > Right_Len then
return +1;
else
return -1;
end if;
end Compare_Array_U128;
end System.Compare_Array_Unsigned_128;

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

@ -0,0 +1,52 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY COMPONENTS --
-- --
-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 1 2 8 --
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2020, 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. --
-- --
------------------------------------------------------------------------------
-- This package contains functions for runtime comparisons on arrays whose
-- elements are 128-bit discrete type values to be treated as unsigned.
package System.Compare_Array_Unsigned_128 is
-- Note: although the functions in this package are in a sense Pure, the
-- package cannot be declared as Pure, since the arguments are addresses,
-- not the data, and the result is not pure wrt the address values.
function Compare_Array_U128
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural) return Integer;
-- Compare the array starting at address Left of length Left_Len
-- with the array starting at address Right of length Right_Len.
-- The comparison is in the normal Ada semantic sense of array
-- comparison. The result is -1,0,+1 for Left<Right, Left=Right,
-- Left>Right respectively.
end System.Compare_Array_Unsigned_128;

42
gcc/ada/libgnat/s-exnint.adb
View file

@ -29,42 +29,8 @@
-- --
------------------------------------------------------------------------------
package body System.Exn_Int is
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
-----------------
-- Exn_Integer --
-----------------
function Exn_Integer (Left : Integer; Right : Natural) return Integer is
pragma Suppress (Division_Check);
pragma Suppress (Overflow_Check);
Result : Integer := 1;
Factor : Integer := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing base values -1, 0, +1 since
-- the expander does this when the base is a literal, and other cases
-- will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
end if;
Exp := Exp / 2;
exit when Exp = 0;
Factor := Factor * Factor;
end loop;
end if;
return Result;
end Exn_Integer;
end System.Exn_Int;
pragma No_Body;

8
gcc/ada/libgnat/s-exnint.ads
View file

@ -31,9 +31,11 @@
-- Integer exponentiation (checks off)
package System.Exn_Int is
pragma Pure;
with System.Exponn;
function Exn_Integer (Left : Integer; Right : Natural) return Integer;
package System.Exn_Int is
function Exn_Integer is new Exponn (Integer);
pragma Pure_Function (Exn_Integer);
end System.Exn_Int;

46
gcc/ada/libgnat/s-exnlli.adb
View file

@ -29,46 +29,8 @@
-- --
------------------------------------------------------------------------------
package body System.Exn_LLI is
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
---------------------------
-- Exn_Long_Long_Integer --
---------------------------
function Exn_Long_Long_Integer
(Left : Long_Long_Integer;
Right : Natural)
return Long_Long_Integer
is
pragma Suppress (Division_Check);
pragma Suppress (Overflow_Check);
Result : Long_Long_Integer := 1;
Factor : Long_Long_Integer := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing base values -1, 0, +1 since
-- the expander does this when the base is a literal, and other cases
-- will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
end if;
Exp := Exp / 2;
exit when Exp = 0;
Factor := Factor * Factor;
end loop;
end if;
return Result;
end Exn_Long_Long_Integer;
end System.Exn_LLI;
pragma No_Body;

11
gcc/ada/libgnat/s-exnlli.ads
View file

@ -31,12 +31,11 @@
-- Long_Long_Integer exponentiation (checks off)
package System.Exn_LLI is
pragma Pure;
with System.Exponn;
function Exn_Long_Long_Integer
(Left : Long_Long_Integer;
Right : Natural)
return Long_Long_Integer;
package System.Exn_LLI is
function Exn_Long_Long_Integer is new Exponn (Long_Long_Integer);
pragma Pure_Function (Exn_Long_Long_Integer);
end System.Exn_LLI;

41
gcc/ada/libgnat/s-exnllli.ads Normal file
View file

@ -0,0 +1,41 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . E X N _ L L L I --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Long_Long_Long_Integer exponentiation (checks off)
with System.Exponn;
package System.Exn_LLLI is
function Exn_Long_Long_Long_Integer is new Exponn (Long_Long_Long_Integer);
pragma Pure_Function (Exn_Long_Long_Long_Integer);
end System.Exn_LLLI;

55
gcc/ada/libgnat/s-expint.adb
View file

@ -29,55 +29,8 @@
-- --
------------------------------------------------------------------------------
package body System.Exp_Int is
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
-----------------
-- Exp_Integer --
-----------------
-- Note that negative exponents get a constraint error because the
-- subtype of the Right argument (the exponent) is Natural.
function Exp_Integer
(Left : Integer;
Right : Natural)
return Integer
is
Result : Integer := 1;
Factor : Integer := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing base values -1, 0, +1 since
-- the expander does this when the base is a literal, and other cases
-- will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
declare
pragma Unsuppress (All_Checks);
begin
Result := Result * Factor;
end;
end if;
Exp := Exp / 2;
exit when Exp = 0;
declare
pragma Unsuppress (All_Checks);
begin
Factor := Factor * Factor;
end;
end loop;
end if;
return Result;
end Exp_Integer;
end System.Exp_Int;
pragma No_Body;

11
gcc/ada/libgnat/s-expint.ads
View file

@ -31,12 +31,11 @@
-- Integer exponentiation (checks on)
package System.Exp_Int is
pragma Pure;
with System.Expont;
function Exp_Integer
(Left : Integer;
Right : Natural)
return Integer;
package System.Exp_Int is
function Exp_Integer is new Expont (Integer);
pragma Pure_Function (Exp_Integer);
end System.Exp_Int;

57
gcc/ada/libgnat/s-explli.adb
View file

@ -2,7 +2,7 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . E X P L L I --
-- S Y S T E M . E X P _ L L I --
-- --
-- B o d y --
-- --
@ -29,55 +29,8 @@
-- --
------------------------------------------------------------------------------
package body System.Exp_LLI is
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
---------------------------
-- Exp_Long_Long_Integer --
---------------------------
-- Note that negative exponents get a constraint error because the
-- subtype of the Right argument (the exponent) is Natural.
function Exp_Long_Long_Integer
(Left : Long_Long_Integer;
Right : Natural)
return Long_Long_Integer
is
Result : Long_Long_Integer := 1;
Factor : Long_Long_Integer := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing base values -1, 0, +1 since
-- the expander does this when the base is a literal, and other cases
-- will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
declare
pragma Unsuppress (All_Checks);
begin
Result := Result * Factor;
end;
end if;
Exp := Exp / 2;
exit when Exp = 0;
declare
pragma Unsuppress (All_Checks);
begin
Factor := Factor * Factor;
end;
end loop;
end if;
return Result;
end Exp_Long_Long_Integer;
end System.Exp_LLI;
pragma No_Body;

11
gcc/ada/libgnat/s-explli.ads
View file

@ -29,14 +29,13 @@
-- --
------------------------------------------------------------------------------
-- Long_Long_Integer exponentiation
-- Long_Long_Integer exponentiation (checks on)
with System.Expont;
package System.Exp_LLI is
pragma Pure;
function Exp_Long_Long_Integer
(Left : Long_Long_Integer;
Right : Natural)
return Long_Long_Integer;
function Exp_Long_Long_Integer is new Expont (Long_Long_Integer);
pragma Pure_Function (Exp_Long_Long_Integer);
end System.Exp_LLI;

41
gcc/ada/libgnat/s-expllli.ads Normal file
View file

@ -0,0 +1,41 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ L L L I --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Long_Long_Long_Integer exponentiation (checks on)
with System.Expont;
package System.Exp_LLLI is
function Exp_Long_Long_Long_Integer is new Expont (Long_Long_Long_Integer);
pragma Pure_Function (Exp_Long_Long_Long_Integer);
end System.Exp_LLLI;

48
gcc/ada/libgnat/s-explllu.ads Normal file
View file

@ -0,0 +1,48 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ L L L U --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- This function performs exponentiation of unsigned types with binary modulus
-- values exceeding that of System.Unsigned_Types.Long_Long_Unsigned.
-- The result is always full width, the caller must do a masking operation if
-- the modulus is less than 2 ** Long_Long_Long_Unsigned'Size.
with System.Exponu;
with System.Unsigned_Types;
package System.Exp_LLLU is
subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned;
function Exp_Long_Long_Long_Unsigned is
new Exponu (Long_Long_Long_Unsigned);
pragma Pure_Function (Exp_Long_Long_Long_Unsigned);
end System.Exp_LLLU;

48
gcc/ada/libgnat/s-expllu.adb
View file

@ -2,7 +2,7 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . X P _ B M L --
-- S Y S T E M . E X P _ L L U --
-- --
-- B o d y --
-- --
@ -29,46 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Exp_LLU is
----------------------------
-- Exp_Long_Long_Unsigned --
----------------------------
function Exp_Long_Long_Unsigned
(Left : Long_Long_Unsigned;
Right : Natural)
return Long_Long_Unsigned
is
Result : Long_Long_Unsigned := 1;
Factor : Long_Long_Unsigned := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing the cases of base values -1,0,+1
-- since the expander does this when the base is a literal, and other
-- cases will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
end if;
Exp := Exp / 2;
exit when Exp = 0;
Factor := Factor * Factor;
end loop;
end if;
return Result;
end Exp_Long_Long_Unsigned;
end System.Exp_LLU;
pragma No_Body;

18
gcc/ada/libgnat/s-expllu.ads
View file

@ -29,19 +29,19 @@
-- --
------------------------------------------------------------------------------
-- This function performs exponentiation of unsigned types (with binary
-- modulus values exceeding that of Unsigned_Types.Unsigned). The result
-- is always full width, the caller must do a masking operation if the
-- modulus is less than 2 ** (Long_Long_Unsigned'Size).
-- This function performs exponentiation of unsigned types with binary modulus
-- values exceeding that of System.Unsigned_Types.Unsigned.
-- The result is always full width, the caller must do a masking operation if
-- the modulus is less than 2 ** Long_Long_Unsigned'Size.
with System.Exponu;
with System.Unsigned_Types;
package System.Exp_LLU is
pragma Pure;
function Exp_Long_Long_Unsigned
(Left : System.Unsigned_Types.Long_Long_Unsigned;
Right : Natural)
return System.Unsigned_Types.Long_Long_Unsigned;
subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned;
function Exp_Long_Long_Unsigned is new Exponu (Long_Long_Unsigned);
pragma Pure_Function (Exp_Long_Long_Unsigned);
end System.Exp_LLU;

72
gcc/ada/libgnat/s-exponn.adb Normal file
View file

@ -0,0 +1,72 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . E X P O N N --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
function System.Exponn (Left : Int; Right : Natural) return Int is
-- Note that negative exponents get a constraint error because the
-- subtype of the Right argument (the exponent) is Natural.
Result : Int := 1;
Factor : Int := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing base values -1, 0, +1 since
-- the expander does this when the base is a literal, and other cases
-- will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
declare
pragma Suppress (Overflow_Check);
begin
Result := Result * Factor;
end;
end if;
Exp := Exp / 2;
exit when Exp = 0;
declare
pragma Suppress (Overflow_Check);
begin
Factor := Factor * Factor;
end;
end loop;
end if;
return Result;
end System.Exponn;

38
gcc/ada/libgnat/s-exponn.ads Normal file
View file

@ -0,0 +1,38 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . E X P O N N --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Signed integer exponentiation (checks off)
generic
type Int is range <>;
function System.Exponn (Left : Int; Right : Natural) return Int;

72
gcc/ada/libgnat/s-expont.adb Normal file
View file

@ -0,0 +1,72 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . E X P O N T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
function System.Expont (Left : Int; Right : Natural) return Int is
-- Note that negative exponents get a constraint error because the
-- subtype of the Right argument (the exponent) is Natural.
Result : Int := 1;
Factor : Int := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing base values -1, 0, +1 since
-- the expander does this when the base is a literal, and other cases
-- will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
declare
pragma Unsuppress (Overflow_Check);
begin
Result := Result * Factor;
end;
end if;
Exp := Exp / 2;
exit when Exp = 0;
declare
pragma Unsuppress (Overflow_Check);
begin
Factor := Factor * Factor;
end;
end loop;
end if;
return Result;
end System.Expont;

38
gcc/ada/libgnat/s-expont.ads Normal file
View file

@ -0,0 +1,38 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . E X P O N T --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Signed integer exponentiation (checks on)
generic
type Int is range <>;
function System.Expont (Left : Int; Right : Natural) return Int;

63
gcc/ada/libgnat/s-exponu.adb Normal file
View file

@ -0,0 +1,63 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . E X P O N U --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
function System.Exponu (Left : Int; Right : Natural) return Int is
-- Note that negative exponents get a constraint error because the
-- subtype of the Right argument (the exponent) is Natural.
Result : Int := 1;
Factor : Int := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing base values -1, 0, +1 since
-- the expander does this when the base is a literal, and other cases
-- will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
end if;
Exp := Exp / 2;
exit when Exp = 0;
Factor := Factor * Factor;
end loop;
end if;
return Result;
end System.Exponu;

38
gcc/ada/libgnat/s-exponu.ads Normal file
View file

@ -0,0 +1,38 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . E X P O N U --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Modular integer exponentiation
generic
type Int is mod <>;
function System.Exponu (Left : Int; Right : Natural) return Int;

45
gcc/ada/libgnat/s-expuns.adb
View file

@ -29,45 +29,8 @@
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
-- This package does not require a body, since it is an instantiation. We
-- provide a dummy file containing a No_Body pragma so that previous versions
-- of the body (which did exist) will not interfere.
package body System.Exp_Uns is
------------------
-- Exp_Unsigned --
------------------
function Exp_Unsigned
(Left : Unsigned;
Right : Natural)
return Unsigned
is
Result : Unsigned := 1;
Factor : Unsigned := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing the cases of base values -1,0,+1
-- since the expander does this when the base is a literal, and other
-- cases will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
end if;
Exp := Exp / 2;
exit when Exp = 0;
Factor := Factor * Factor;
end loop;
end if;
return Result;
end Exp_Unsigned;
end System.Exp_Uns;
pragma No_Body;

18
gcc/ada/libgnat/s-expuns.ads
View file

@ -29,19 +29,19 @@
-- --
------------------------------------------------------------------------------
-- This function performs exponentiation of unsigned types (with binary
-- modulus values up to and including that of Unsigned_Types.Unsigned).
-- The result is always full width, the caller must do a masking operation
-- the modulus is less than 2 ** (Unsigned'Size).
-- This function performs exponentiation of unsigned types with binary modulus
-- values up to and including that of System.Unsigned_Types.Unsigned.
-- The result is always full width, the caller must do a masking operation if
-- the modulus is less than 2 ** Unsigned'Size.
with System.Exponu;
with System.Unsigned_Types;
package System.Exp_Uns is
pragma Pure;
function Exp_Unsigned
(Left : System.Unsigned_Types.Unsigned;
Right : Natural)
return System.Unsigned_Types.Unsigned;
subtype Unsigned is Unsigned_Types.Unsigned;
function Exp_Unsigned is new Exponu (Unsigned);
pragma Pure_Function (Exp_Unsigned);
end System.Exp_Uns;

250
gcc/ada/libgnat/s-pack100.adb Normal file
View file

@ -0,0 +1,250 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 0 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_100 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_100;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
-- The following declarations are for the case where the address
-- passed to GetU_100 or SetU_100 is not guaranteed to be aligned.
-- These routines are used when the packed array is itself a
-- component of a packed record, and therefore may not be aligned.
type ClusterU is new Cluster;
for ClusterU'Alignment use 1;
type ClusterU_Ref is access ClusterU;
type Rev_ClusterU is new ClusterU
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_ClusterU_Ref is access Rev_ClusterU;
------------
-- Get_100 --
------------
function Get_100
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_100
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_100;
-------------
-- GetU_100 --
-------------
function GetU_100
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_100
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end GetU_100;
------------
-- Set_100 --
------------
procedure Set_100
(Arr : System.Address;
N : Natural;
E : Bits_100;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_100;
-------------
-- SetU_100 --
-------------
procedure SetU_100
(Arr : System.Address;
N : Natural;
E : Bits_100;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end SetU_100;
end System.Pack_100;

77
gcc/ada/libgnat/s-pack100.ads Normal file
View file

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 0 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 100
package System.Pack_100 is
pragma Preelaborate;
Bits : constant := 100;
type Bits_100 is mod 2 ** Bits;
for Bits_100'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_100
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_100 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_100
(Arr : System.Address;
N : Natural;
E : Bits_100;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
function GetU_100
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_100 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned. This version
-- is used when Arr may represent an unaligned address.
procedure SetU_100
(Arr : System.Address;
N : Natural;
E : Bits_100;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value. This version
-- is used when Arr may represent an unaligned address
end System.Pack_100;

157
gcc/ada/libgnat/s-pack101.adb Normal file
View file

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 1 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_101 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_101;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
------------
-- Get_101 --
------------
function Get_101
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_101
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_101;
------------
-- Set_101 --
------------
procedure Set_101
(Arr : System.Address;
N : Natural;
E : Bits_101;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_101;
end System.Pack_101;

60
gcc/ada/libgnat/s-pack101.ads Normal file
View file

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 1 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 101
package System.Pack_101 is
pragma Preelaborate;
Bits : constant := 101;
type Bits_101 is mod 2 ** Bits;
for Bits_101'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_101
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_101 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_101
(Arr : System.Address;
N : Natural;
E : Bits_101;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
end System.Pack_101;

250
gcc/ada/libgnat/s-pack102.adb Normal file
View file

@ -0,0 +1,250 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 2 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_102 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_102;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
-- The following declarations are for the case where the address
-- passed to GetU_102 or SetU_102 is not guaranteed to be aligned.
-- These routines are used when the packed array is itself a
-- component of a packed record, and therefore may not be aligned.
type ClusterU is new Cluster;
for ClusterU'Alignment use 1;
type ClusterU_Ref is access ClusterU;
type Rev_ClusterU is new ClusterU
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_ClusterU_Ref is access Rev_ClusterU;
------------
-- Get_102 --
------------
function Get_102
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_102
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_102;
-------------
-- GetU_102 --
-------------
function GetU_102
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_102
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end GetU_102;
------------
-- Set_102 --
------------
procedure Set_102
(Arr : System.Address;
N : Natural;
E : Bits_102;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_102;
-------------
-- SetU_102 --
-------------
procedure SetU_102
(Arr : System.Address;
N : Natural;
E : Bits_102;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end SetU_102;
end System.Pack_102;

77
gcc/ada/libgnat/s-pack102.ads Normal file
View file

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 2 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 102
package System.Pack_102 is
pragma Preelaborate;
Bits : constant := 102;
type Bits_102 is mod 2 ** Bits;
for Bits_102'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_102
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_102 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_102
(Arr : System.Address;
N : Natural;
E : Bits_102;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
function GetU_102
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_102 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned. This version
-- is used when Arr may represent an unaligned address.
procedure SetU_102
(Arr : System.Address;
N : Natural;
E : Bits_102;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value. This version
-- is used when Arr may represent an unaligned address
end System.Pack_102;

157
gcc/ada/libgnat/s-pack103.adb Normal file
View file

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 3 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_103 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_103;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
------------
-- Get_103 --
------------
function Get_103
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_103
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_103;
------------
-- Set_103 --
------------
procedure Set_103
(Arr : System.Address;
N : Natural;
E : Bits_103;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_103;
end System.Pack_103;

60
gcc/ada/libgnat/s-pack103.ads Normal file
View file

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 3 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 103
package System.Pack_103 is
pragma Preelaborate;
Bits : constant := 103;
type Bits_103 is mod 2 ** Bits;
for Bits_103'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_103
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_103 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_103
(Arr : System.Address;
N : Natural;
E : Bits_103;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
end System.Pack_103;

250
gcc/ada/libgnat/s-pack104.adb Normal file
View file

@ -0,0 +1,250 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 4 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_104 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_104;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
-- The following declarations are for the case where the address
-- passed to GetU_104 or SetU_104 is not guaranteed to be aligned.
-- These routines are used when the packed array is itself a
-- component of a packed record, and therefore may not be aligned.
type ClusterU is new Cluster;
for ClusterU'Alignment use 1;
type ClusterU_Ref is access ClusterU;
type Rev_ClusterU is new ClusterU
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_ClusterU_Ref is access Rev_ClusterU;
------------
-- Get_104 --
------------
function Get_104
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_104
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_104;
-------------
-- GetU_104 --
-------------
function GetU_104
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_104
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end GetU_104;
------------
-- Set_104 --
------------
procedure Set_104
(Arr : System.Address;
N : Natural;
E : Bits_104;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_104;
-------------
-- SetU_104 --
-------------
procedure SetU_104
(Arr : System.Address;
N : Natural;
E : Bits_104;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end SetU_104;
end System.Pack_104;

77
gcc/ada/libgnat/s-pack104.ads Normal file
View file

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 4 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 104
package System.Pack_104 is
pragma Preelaborate;
Bits : constant := 104;
type Bits_104 is mod 2 ** Bits;
for Bits_104'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_104
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_104 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_104
(Arr : System.Address;
N : Natural;
E : Bits_104;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
function GetU_104
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_104 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned. This version
-- is used when Arr may represent an unaligned address.
procedure SetU_104
(Arr : System.Address;
N : Natural;
E : Bits_104;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value. This version
-- is used when Arr may represent an unaligned address
end System.Pack_104;

157
gcc/ada/libgnat/s-pack105.adb Normal file
View file

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 5 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_105 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_105;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
------------
-- Get_105 --
------------
function Get_105
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_105
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_105;
------------
-- Set_105 --
------------
procedure Set_105
(Arr : System.Address;
N : Natural;
E : Bits_105;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_105;
end System.Pack_105;

60
gcc/ada/libgnat/s-pack105.ads Normal file
View file

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 5 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 105
package System.Pack_105 is
pragma Preelaborate;
Bits : constant := 105;
type Bits_105 is mod 2 ** Bits;
for Bits_105'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_105
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_105 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_105
(Arr : System.Address;
N : Natural;
E : Bits_105;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
end System.Pack_105;

250
gcc/ada/libgnat/s-pack106.adb Normal file
View file

@ -0,0 +1,250 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 6 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_106 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_106;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
-- The following declarations are for the case where the address
-- passed to GetU_106 or SetU_106 is not guaranteed to be aligned.
-- These routines are used when the packed array is itself a
-- component of a packed record, and therefore may not be aligned.
type ClusterU is new Cluster;
for ClusterU'Alignment use 1;
type ClusterU_Ref is access ClusterU;
type Rev_ClusterU is new ClusterU
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_ClusterU_Ref is access Rev_ClusterU;
------------
-- Get_106 --
------------
function Get_106
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_106
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_106;
-------------
-- GetU_106 --
-------------
function GetU_106
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_106
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end GetU_106;
------------
-- Set_106 --
------------
procedure Set_106
(Arr : System.Address;
N : Natural;
E : Bits_106;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_106;
-------------
-- SetU_106 --
-------------
procedure SetU_106
(Arr : System.Address;
N : Natural;
E : Bits_106;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end SetU_106;
end System.Pack_106;

77
gcc/ada/libgnat/s-pack106.ads Normal file
View file

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 6 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 106
package System.Pack_106 is
pragma Preelaborate;
Bits : constant := 106;
type Bits_106 is mod 2 ** Bits;
for Bits_106'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_106
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_106 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_106
(Arr : System.Address;
N : Natural;
E : Bits_106;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
function GetU_106
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_106 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned. This version
-- is used when Arr may represent an unaligned address.
procedure SetU_106
(Arr : System.Address;
N : Natural;
E : Bits_106;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value. This version
-- is used when Arr may represent an unaligned address
end System.Pack_106;

157
gcc/ada/libgnat/s-pack107.adb Normal file
View file

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 7 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_107 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_107;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
------------
-- Get_107 --
------------
function Get_107
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_107
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_107;
------------
-- Set_107 --
------------
procedure Set_107
(Arr : System.Address;
N : Natural;
E : Bits_107;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_107;
end System.Pack_107;

60
gcc/ada/libgnat/s-pack107.ads Normal file
View file

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 7 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 107
package System.Pack_107 is
pragma Preelaborate;
Bits : constant := 107;
type Bits_107 is mod 2 ** Bits;
for Bits_107'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_107
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_107 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_107
(Arr : System.Address;
N : Natural;
E : Bits_107;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
end System.Pack_107;

250
gcc/ada/libgnat/s-pack108.adb Normal file
View file

@ -0,0 +1,250 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 8 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_108 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_108;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
-- The following declarations are for the case where the address
-- passed to GetU_108 or SetU_108 is not guaranteed to be aligned.
-- These routines are used when the packed array is itself a
-- component of a packed record, and therefore may not be aligned.
type ClusterU is new Cluster;
for ClusterU'Alignment use 1;
type ClusterU_Ref is access ClusterU;
type Rev_ClusterU is new ClusterU
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_ClusterU_Ref is access Rev_ClusterU;
------------
-- Get_108 --
------------
function Get_108
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_108
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_108;
-------------
-- GetU_108 --
-------------
function GetU_108
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_108
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end GetU_108;
------------
-- Set_108 --
------------
procedure Set_108
(Arr : System.Address;
N : Natural;
E : Bits_108;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_108;
-------------
-- SetU_108 --
-------------
procedure SetU_108
(Arr : System.Address;
N : Natural;
E : Bits_108;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end SetU_108;
end System.Pack_108;

77
gcc/ada/libgnat/s-pack108.ads Normal file
View file

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 8 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 108
package System.Pack_108 is
pragma Preelaborate;
Bits : constant := 108;
type Bits_108 is mod 2 ** Bits;
for Bits_108'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_108
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_108 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_108
(Arr : System.Address;
N : Natural;
E : Bits_108;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
function GetU_108
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_108 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned. This version
-- is used when Arr may represent an unaligned address.
procedure SetU_108
(Arr : System.Address;
N : Natural;
E : Bits_108;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value. This version
-- is used when Arr may represent an unaligned address
end System.Pack_108;

157
gcc/ada/libgnat/s-pack109.adb Normal file
View file

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 9 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_109 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_109;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
------------
-- Get_109 --
------------
function Get_109
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_109
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_109;
------------
-- Set_109 --
------------
procedure Set_109
(Arr : System.Address;
N : Natural;
E : Bits_109;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_109;
end System.Pack_109;

60
gcc/ada/libgnat/s-pack109.ads Normal file
View file

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 0 9 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 109
package System.Pack_109 is
pragma Preelaborate;
Bits : constant := 109;
type Bits_109 is mod 2 ** Bits;
for Bits_109'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_109
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_109 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_109
(Arr : System.Address;
N : Natural;
E : Bits_109;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
end System.Pack_109;

250
gcc/ada/libgnat/s-pack110.adb Normal file
View file

@ -0,0 +1,250 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 0 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_110 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_110;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
-- The following declarations are for the case where the address
-- passed to GetU_110 or SetU_110 is not guaranteed to be aligned.
-- These routines are used when the packed array is itself a
-- component of a packed record, and therefore may not be aligned.
type ClusterU is new Cluster;
for ClusterU'Alignment use 1;
type ClusterU_Ref is access ClusterU;
type Rev_ClusterU is new ClusterU
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_ClusterU_Ref is access Rev_ClusterU;
------------
-- Get_110 --
------------
function Get_110
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_110
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_110;
-------------
-- GetU_110 --
-------------
function GetU_110
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_110
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end GetU_110;
------------
-- Set_110 --
------------
procedure Set_110
(Arr : System.Address;
N : Natural;
E : Bits_110;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_110;
-------------
-- SetU_110 --
-------------
procedure SetU_110
(Arr : System.Address;
N : Natural;
E : Bits_110;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end SetU_110;
end System.Pack_110;

77
gcc/ada/libgnat/s-pack110.ads Normal file
View file

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 0 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 110
package System.Pack_110 is
pragma Preelaborate;
Bits : constant := 110;
type Bits_110 is mod 2 ** Bits;
for Bits_110'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_110
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_110 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_110
(Arr : System.Address;
N : Natural;
E : Bits_110;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
function GetU_110
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_110 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned. This version
-- is used when Arr may represent an unaligned address.
procedure SetU_110
(Arr : System.Address;
N : Natural;
E : Bits_110;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value. This version
-- is used when Arr may represent an unaligned address
end System.Pack_110;

157
gcc/ada/libgnat/s-pack111.adb Normal file
View file

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 1 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_111 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_111;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
------------
-- Get_111 --
------------
function Get_111
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_111
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_111;
------------
-- Set_111 --
------------
procedure Set_111
(Arr : System.Address;
N : Natural;
E : Bits_111;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_111;
end System.Pack_111;

60
gcc/ada/libgnat/s-pack111.ads Normal file
View file

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 1 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 111
package System.Pack_111 is
pragma Preelaborate;
Bits : constant := 111;
type Bits_111 is mod 2 ** Bits;
for Bits_111'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_111
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_111 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_111
(Arr : System.Address;
N : Natural;
E : Bits_111;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
end System.Pack_111;

250
gcc/ada/libgnat/s-pack112.adb Normal file
View file

@ -0,0 +1,250 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 2 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_112 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_112;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
-- The following declarations are for the case where the address
-- passed to GetU_112 or SetU_112 is not guaranteed to be aligned.
-- These routines are used when the packed array is itself a
-- component of a packed record, and therefore may not be aligned.
type ClusterU is new Cluster;
for ClusterU'Alignment use 1;
type ClusterU_Ref is access ClusterU;
type Rev_ClusterU is new ClusterU
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_ClusterU_Ref is access Rev_ClusterU;
------------
-- Get_112 --
------------
function Get_112
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_112
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_112;
-------------
-- GetU_112 --
-------------
function GetU_112
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_112
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end GetU_112;
------------
-- Set_112 --
------------
procedure Set_112
(Arr : System.Address;
N : Natural;
E : Bits_112;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_112;
-------------
-- SetU_112 --
-------------
procedure SetU_112
(Arr : System.Address;
N : Natural;
E : Bits_112;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end SetU_112;
end System.Pack_112;

77
gcc/ada/libgnat/s-pack112.ads Normal file
View file

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 2 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 112
package System.Pack_112 is
pragma Preelaborate;
Bits : constant := 112;
type Bits_112 is mod 2 ** Bits;
for Bits_112'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_112
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_112 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_112
(Arr : System.Address;
N : Natural;
E : Bits_112;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
function GetU_112
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_112 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned. This version
-- is used when Arr may represent an unaligned address.
procedure SetU_112
(Arr : System.Address;
N : Natural;
E : Bits_112;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value. This version
-- is used when Arr may represent an unaligned address
end System.Pack_112;

157
gcc/ada/libgnat/s-pack113.adb Normal file
View file

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 3 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_113 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_113;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
------------
-- Get_113 --
------------
function Get_113
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_113
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_113;
------------
-- Set_113 --
------------
procedure Set_113
(Arr : System.Address;
N : Natural;
E : Bits_113;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_113;
end System.Pack_113;

60
gcc/ada/libgnat/s-pack113.ads Normal file
View file

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 3 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 113
package System.Pack_113 is
pragma Preelaborate;
Bits : constant := 113;
type Bits_113 is mod 2 ** Bits;
for Bits_113'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_113
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_113 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_113
(Arr : System.Address;
N : Natural;
E : Bits_113;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
end System.Pack_113;

250
gcc/ada/libgnat/s-pack114.adb Normal file
View file

@ -0,0 +1,250 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 4 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_114 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_114;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
-- The following declarations are for the case where the address
-- passed to GetU_114 or SetU_114 is not guaranteed to be aligned.
-- These routines are used when the packed array is itself a
-- component of a packed record, and therefore may not be aligned.
type ClusterU is new Cluster;
for ClusterU'Alignment use 1;
type ClusterU_Ref is access ClusterU;
type Rev_ClusterU is new ClusterU
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_ClusterU_Ref is access Rev_ClusterU;
------------
-- Get_114 --
------------
function Get_114
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_114
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_114;
-------------
-- GetU_114 --
-------------
function GetU_114
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_114
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end GetU_114;
------------
-- Set_114 --
------------
procedure Set_114
(Arr : System.Address;
N : Natural;
E : Bits_114;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_114;
-------------
-- SetU_114 --
-------------
procedure SetU_114
(Arr : System.Address;
N : Natural;
E : Bits_114;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end SetU_114;
end System.Pack_114;

77
gcc/ada/libgnat/s-pack114.ads Normal file
View file

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 4 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 114
package System.Pack_114 is
pragma Preelaborate;
Bits : constant := 114;
type Bits_114 is mod 2 ** Bits;
for Bits_114'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_114
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_114 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_114
(Arr : System.Address;
N : Natural;
E : Bits_114;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
function GetU_114
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_114 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned. This version
-- is used when Arr may represent an unaligned address.
procedure SetU_114
(Arr : System.Address;
N : Natural;
E : Bits_114;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value. This version
-- is used when Arr may represent an unaligned address
end System.Pack_114;

157
gcc/ada/libgnat/s-pack115.adb Normal file
View file

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 5 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_115 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_115;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
------------
-- Get_115 --
------------
function Get_115
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_115
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_115;
------------
-- Set_115 --
------------
procedure Set_115
(Arr : System.Address;
N : Natural;
E : Bits_115;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_115;
end System.Pack_115;

60
gcc/ada/libgnat/s-pack115.ads Normal file
View file

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 5 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 115
package System.Pack_115 is
pragma Preelaborate;
Bits : constant := 115;
type Bits_115 is mod 2 ** Bits;
for Bits_115'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_115
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_115 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_115
(Arr : System.Address;
N : Natural;
E : Bits_115;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
end System.Pack_115;

250
gcc/ada/libgnat/s-pack116.adb Normal file
View file

@ -0,0 +1,250 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 6 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_116 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_116;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
-- The following declarations are for the case where the address
-- passed to GetU_116 or SetU_116 is not guaranteed to be aligned.
-- These routines are used when the packed array is itself a
-- component of a packed record, and therefore may not be aligned.
type ClusterU is new Cluster;
for ClusterU'Alignment use 1;
type ClusterU_Ref is access ClusterU;
type Rev_ClusterU is new ClusterU
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_ClusterU_Ref is access Rev_ClusterU;
------------
-- Get_116 --
------------
function Get_116
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_116
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_116;
-------------
-- GetU_116 --
-------------
function GetU_116
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_116
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end GetU_116;
------------
-- Set_116 --
------------
procedure Set_116
(Arr : System.Address;
N : Natural;
E : Bits_116;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_116;
-------------
-- SetU_116 --
-------------
procedure SetU_116
(Arr : System.Address;
N : Natural;
E : Bits_116;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end SetU_116;
end System.Pack_116;

77
gcc/ada/libgnat/s-pack116.ads Normal file
View file

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 6 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 116
package System.Pack_116 is
pragma Preelaborate;
Bits : constant := 116;
type Bits_116 is mod 2 ** Bits;
for Bits_116'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_116
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_116 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_116
(Arr : System.Address;
N : Natural;
E : Bits_116;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
function GetU_116
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_116 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned. This version
-- is used when Arr may represent an unaligned address.
procedure SetU_116
(Arr : System.Address;
N : Natural;
E : Bits_116;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value. This version
-- is used when Arr may represent an unaligned address
end System.Pack_116;

157
gcc/ada/libgnat/s-pack117.adb Normal file
View file

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 7 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_117 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_117;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
------------
-- Get_117 --
------------
function Get_117
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_117
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_117;
------------
-- Set_117 --
------------
procedure Set_117
(Arr : System.Address;
N : Natural;
E : Bits_117;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_117;
end System.Pack_117;

60
gcc/ada/libgnat/s-pack117.ads Normal file
View file

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 7 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 117
package System.Pack_117 is
pragma Preelaborate;
Bits : constant := 117;
type Bits_117 is mod 2 ** Bits;
for Bits_117'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_117
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_117 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_117
(Arr : System.Address;
N : Natural;
E : Bits_117;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
end System.Pack_117;

250
gcc/ada/libgnat/s-pack118.adb Normal file
View file

@ -0,0 +1,250 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 8 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_118 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_118;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
-- The following declarations are for the case where the address
-- passed to GetU_118 or SetU_118 is not guaranteed to be aligned.
-- These routines are used when the packed array is itself a
-- component of a packed record, and therefore may not be aligned.
type ClusterU is new Cluster;
for ClusterU'Alignment use 1;
type ClusterU_Ref is access ClusterU;
type Rev_ClusterU is new ClusterU
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_ClusterU_Ref is access Rev_ClusterU;
------------
-- Get_118 --
------------
function Get_118
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_118
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_118;
-------------
-- GetU_118 --
-------------
function GetU_118
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_118
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end GetU_118;
------------
-- Set_118 --
------------
procedure Set_118
(Arr : System.Address;
N : Natural;
E : Bits_118;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_118;
-------------
-- SetU_118 --
-------------
procedure SetU_118
(Arr : System.Address;
N : Natural;
E : Bits_118;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end SetU_118;
end System.Pack_118;

77
gcc/ada/libgnat/s-pack118.ads Normal file
View file

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 8 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 118
package System.Pack_118 is
pragma Preelaborate;
Bits : constant := 118;
type Bits_118 is mod 2 ** Bits;
for Bits_118'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_118
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_118 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_118
(Arr : System.Address;
N : Natural;
E : Bits_118;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
function GetU_118
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_118 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned. This version
-- is used when Arr may represent an unaligned address.
procedure SetU_118
(Arr : System.Address;
N : Natural;
E : Bits_118;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value. This version
-- is used when Arr may represent an unaligned address
end System.Pack_118;

157
gcc/ada/libgnat/s-pack119.adb Normal file
View file

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 9 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_119 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_119;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
------------
-- Get_119 --
------------
function Get_119
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_119
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_119;
------------
-- Set_119 --
------------
procedure Set_119
(Arr : System.Address;
N : Natural;
E : Bits_119;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_119;
end System.Pack_119;

60
gcc/ada/libgnat/s-pack119.ads Normal file
View file

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 1 9 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 119
package System.Pack_119 is
pragma Preelaborate;
Bits : constant := 119;
type Bits_119 is mod 2 ** Bits;
for Bits_119'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_119
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_119 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_119
(Arr : System.Address;
N : Natural;
E : Bits_119;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
end System.Pack_119;

250
gcc/ada/libgnat/s-pack120.adb Normal file
View file

@ -0,0 +1,250 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 2 0 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_120 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_120;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
-- The following declarations are for the case where the address
-- passed to GetU_120 or SetU_120 is not guaranteed to be aligned.
-- These routines are used when the packed array is itself a
-- component of a packed record, and therefore may not be aligned.
type ClusterU is new Cluster;
for ClusterU'Alignment use 1;
type ClusterU_Ref is access ClusterU;
type Rev_ClusterU is new ClusterU
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_ClusterU_Ref is access Rev_ClusterU;
------------
-- Get_120 --
------------
function Get_120
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_120
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_120;
-------------
-- GetU_120 --
-------------
function GetU_120
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_120
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end GetU_120;
------------
-- Set_120 --
------------
procedure Set_120
(Arr : System.Address;
N : Natural;
E : Bits_120;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_120;
-------------
-- SetU_120 --
-------------
procedure SetU_120
(Arr : System.Address;
N : Natural;
E : Bits_120;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : ClusterU_Ref with Address => A'Address, Import;
RC : Rev_ClusterU_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end SetU_120;
end System.Pack_120;

77
gcc/ada/libgnat/s-pack120.ads Normal file
View file

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 2 0 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 120
package System.Pack_120 is
pragma Preelaborate;
Bits : constant := 120;
type Bits_120 is mod 2 ** Bits;
for Bits_120'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_120
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_120 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_120
(Arr : System.Address;
N : Natural;
E : Bits_120;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
function GetU_120
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_120 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned. This version
-- is used when Arr may represent an unaligned address.
procedure SetU_120
(Arr : System.Address;
N : Natural;
E : Bits_120;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value. This version
-- is used when Arr may represent an unaligned address
end System.Pack_120;

157
gcc/ada/libgnat/s-pack121.adb Normal file
View file

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 2 1 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Unsigned_Types;
package body System.Pack_121 is
subtype Bit_Order is System.Bit_Order;
Reverse_Bit_Order : constant Bit_Order :=
Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
subtype Ofs is System.Storage_Elements.Storage_Offset;
subtype Uns is System.Unsigned_Types.Unsigned;
subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
use type System.Storage_Elements.Storage_Offset;
use type System.Unsigned_Types.Unsigned;
type Cluster is record
E0, E1, E2, E3, E4, E5, E6, E7 : Bits_121;
end record;
for Cluster use record
E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
end record;
for Cluster'Size use Bits * 8;
for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
1 +
1 * Boolean'Pos (Bits mod 2 = 0) +
2 * Boolean'Pos (Bits mod 4 = 0));
-- Use maximum possible alignment, given the bit field size, since this
-- will result in the most efficient code possible for the field.
type Cluster_Ref is access Cluster;
type Rev_Cluster is new Cluster
with Bit_Order => Reverse_Bit_Order,
Scalar_Storage_Order => Reverse_Bit_Order;
type Rev_Cluster_Ref is access Rev_Cluster;
------------
-- Get_121 --
------------
function Get_121
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_121
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => return RC.E0;
when 1 => return RC.E1;
when 2 => return RC.E2;
when 3 => return RC.E3;
when 4 => return RC.E4;
when 5 => return RC.E5;
when 6 => return RC.E6;
when 7 => return RC.E7;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => return C.E0;
when 1 => return C.E1;
when 2 => return C.E2;
when 3 => return C.E3;
when 4 => return C.E4;
when 5 => return C.E5;
when 6 => return C.E6;
when 7 => return C.E7;
end case;
end if;
end Get_121;
------------
-- Set_121 --
------------
procedure Set_121
(Arr : System.Address;
N : Natural;
E : Bits_121;
Rev_SSO : Boolean)
is
A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
C : Cluster_Ref with Address => A'Address, Import;
RC : Rev_Cluster_Ref with Address => A'Address, Import;
begin
if Rev_SSO then
case N07 (Uns (N) mod 8) is
when 0 => RC.E0 := E;
when 1 => RC.E1 := E;
when 2 => RC.E2 := E;
when 3 => RC.E3 := E;
when 4 => RC.E4 := E;
when 5 => RC.E5 := E;
when 6 => RC.E6 := E;
when 7 => RC.E7 := E;
end case;
else
case N07 (Uns (N) mod 8) is
when 0 => C.E0 := E;
when 1 => C.E1 := E;
when 2 => C.E2 := E;
when 3 => C.E3 := E;
when 4 => C.E4 := E;
when 5 => C.E5 := E;
when 6 => C.E6 := E;
when 7 => C.E7 := E;
end case;
end if;
end Set_121;
end System.Pack_121;

60
gcc/ada/libgnat/s-pack121.ads Normal file
View file

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A C K _ 1 2 1 --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2020, 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. --
-- --
------------------------------------------------------------------------------
-- Handling of packed arrays with Component_Size = 121
package System.Pack_121 is
pragma Preelaborate;
Bits : constant := 121;
type Bits_121 is mod 2 ** Bits;
for Bits_121'Size use Bits;
-- In all subprograms below, Rev_SSO is set True if the array has the
-- non-default scalar storage order.
function Get_121
(Arr : System.Address;
N : Natural;
Rev_SSO : Boolean) return Bits_121 with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is extracted and returned.
procedure Set_121
(Arr : System.Address;
N : Natural;
E : Bits_121;
Rev_SSO : Boolean) with Inline;
-- Arr is the address of the packed array, N is the zero-based
-- subscript. This element is set to the given value.
end System.Pack_121;

Some files were not shown because too many files have changed in this diff Show more