aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/s-pack54.adb
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@gcc.gnu.org>2014-08-01 16:11:18 +0200
committerArnaud Charlet <charlet@gcc.gnu.org>2014-08-01 16:11:18 +0200
commit7b53649518674605dd757f4089c8a522e4272273 (patch)
treefdb5a56e6066a99a0a05b387130465d401aa5e1c /gcc/ada/s-pack54.adb
parent41d8ee1d52ca454571226a1083fcd66b169c5cda (diff)
downloadgcc-7b53649518674605dd757f4089c8a522e4272273.zip
gcc-7b53649518674605dd757f4089c8a522e4272273.tar.gz
gcc-7b53649518674605dd757f4089c8a522e4272273.tar.bz2
[multiple changes]
2014-08-01 Thomas Quinot <quinot@adacore.com> * freeze.adb: Minor reformatting. 2014-08-01 Thomas Quinot <quinot@adacore.com> * exp_ch3.adb (Default_Initialize_Object): Do not generate default initialization for an imported object. 2014-08-01 Olivier Hainque <hainque@adacore.com> * seh_init.c (__gnat_map_SEH): Cast argument of IsBadCodePtr to the expected FARPROC type instead of void *. * adaint.c (f2t): Expect __time64_t * as second argument, in line with other datastructures. (__gnat_file_time_name_attr): Adjust accordingly. (__gnat_check_OWNER_ACL): Declare pSD as PSECURITY_DESCRIPTOR, in line with uses. (__gnat_check_OWNER_ACL): Declare AccessMode parameter as ACCESS_MODE instead of DWORD, in line with callers and uses. (__gnat_set_executable): Add ATTRIBUTE_UNUSED on mode, unused on win32. Correct cast of "args" on call to spawnvp. (add_handle): Cast realloc calls into their destination types. (win32_wait): Remove declaration and initialization of unused variable. (__gnat_locate_exec_on_path): Cast alloca calls into their destination types. * initialize.c (append_arg, __gnat_initialize): Cast xmalloc calls into their destination types. 2014-08-01 Gary Dismukes <dismukes@adacore.com> * exp_ch4.adb (Expand_N_Type_Conversion): Expand range checks for conversions between floating-point subtypes when the target and source types are the same. 2014-08-01 Robert Dewar <dewar@adacore.com> * exp_aggr.adb: Minor reformatting. 2014-08-01 Eric Botcazou <ebotcazou@adacore.com> * sem_ch13.adb (Check_Indexing_Functions): Initialize Indexing_Found. 2014-08-01 Arnaud Charlet <charlet@adacore.com> * gnat1drv.adb (Gnat1drv): In gnatprove mode, we now write the ALI file before we call the backend (so that gnat2why can append to it). 2014-08-01 Thomas Quinot <quinot@adacore.com> * exp_pakd.adb (Expand_Bit_Packed_Element_Set, Expand_Packed_Element_Reference): Pass additional Rev_SSO parameter indicating whether the packed array type has reverse scalar storage order to the s-pack* Set/Get routines. * s-pack*.ad* (Get, Set, GetU, SetU): New formal Rev_SSO indicating reverse scalar storage order. 2014-08-01 Robert Dewar <dewar@adacore.com> * sem_ch3.adb (Check_Initialization): Set Do_Range_Check for initial component value in -gnatc or GNATprove mode. (Process_Discriminants): Same fix for default discriminant values. * sem_eval.adb (Test_In_Range): Improve accuracy of results by checking subtypes. 2014-08-01 Robert Dewar <dewar@adacore.com> * sinfo.ads: Minor comment clarification. From-SVN: r213471
Diffstat (limited to 'gcc/ada/s-pack54.adb')
-rw-r--r--gcc/ada/s-pack54.adb195
1 files changed, 141 insertions, 54 deletions
diff --git a/gcc/ada/s-pack54.adb b/gcc/ada/s-pack54.adb
index d21dbc0..5d02941 100644
--- a/gcc/ada/s-pack54.adb
+++ b/gcc/ada/s-pack54.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -31,10 +31,13 @@
with System.Storage_Elements;
with System.Unsigned_Types;
-with Ada.Unchecked_Conversion;
package body System.Pack_54 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;
@@ -68,8 +71,10 @@ package body System.Pack_54 is
type Cluster_Ref is access Cluster;
- function To_Ref is new
- Ada.Unchecked_Conversion (System.Address, Cluster_Ref);
+ 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_54 or SetU_54 is not guaranteed to be aligned.
@@ -81,83 +86,165 @@ package body System.Pack_54 is
type ClusterU_Ref is access ClusterU;
- function To_Ref is new
- Ada.Unchecked_Conversion (System.Address, ClusterU_Ref);
+ 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_54 --
------------
- function Get_54 (Arr : System.Address; N : Natural) return Bits_54 is
- C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
+ function Get_54
+ (Arr : System.Address;
+ N : Natural;
+ Rev_SSO : Boolean) return Bits_54
+ 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
- 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;
+ 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_54;
-------------
-- GetU_54 --
-------------
- function GetU_54 (Arr : System.Address; N : Natural) return Bits_54 is
- C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
+ function GetU_54
+ (Arr : System.Address;
+ N : Natural;
+ Rev_SSO : Boolean) return Bits_54
+ 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
- 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;
+ 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_54;
------------
-- Set_54 --
------------
- procedure Set_54 (Arr : System.Address; N : Natural; E : Bits_54) is
- C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
+ procedure Set_54
+ (Arr : System.Address;
+ N : Natural;
+ E : Bits_54;
+ 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
- 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;
+ 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_54;
-------------
-- SetU_54 --
-------------
- procedure SetU_54 (Arr : System.Address; N : Natural; E : Bits_54) is
- C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
+ procedure SetU_54
+ (Arr : System.Address;
+ N : Natural;
+ E : Bits_54;
+ 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
- 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;
+ 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_54;
end System.Pack_54;