-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2019, 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 2, or (at your option) any later ver- --
+-- 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util;
with Layout; use Layout;
+with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
-with Rtsfind; use Rtsfind;
+with Opt; use Opt;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
-- For big-endian machines, element zero is at the left hand end
-- (high order end) of a bit field.
- -- The shifts that are used to right justify a field therefore differ
- -- in the two cases. For the little-endian case, we can simply use the
- -- bit number (i.e. the element number * element size) as the count for
- -- a right shift. For the big-endian case, we have to subtract the shift
- -- count from an appropriate constant to use in the right shift. We use
- -- rotates instead of shifts (which is necessary in the store case to
- -- preserve other fields), and we expect that the backend will be able
- -- to change the right rotate into a left rotate, avoiding the subtract,
- -- if the architecture provides such an instruction.
-
- ----------------------------------------------
- -- 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. This table is used to obtain the entity for the
- -- proper routine.
-
- type E_Array is array (Int range 01 .. 63) 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
- -- entries from System.Unsigned, because we also use this table for
- -- certain special unchecked conversions in the big-endian case.
-
- Bits_Id : constant E_Array :=
- (01 => RE_Bits_1,
- 02 => RE_Bits_2,
- 03 => RE_Bits_03,
- 04 => RE_Bits_4,
- 05 => RE_Bits_05,
- 06 => RE_Bits_06,
- 07 => RE_Bits_07,
- 08 => RE_Unsigned_8,
- 09 => RE_Bits_09,
- 10 => RE_Bits_10,
- 11 => RE_Bits_11,
- 12 => RE_Bits_12,
- 13 => RE_Bits_13,
- 14 => RE_Bits_14,
- 15 => RE_Bits_15,
- 16 => RE_Unsigned_16,
- 17 => RE_Bits_17,
- 18 => RE_Bits_18,
- 19 => RE_Bits_19,
- 20 => RE_Bits_20,
- 21 => RE_Bits_21,
- 22 => RE_Bits_22,
- 23 => RE_Bits_23,
- 24 => RE_Bits_24,
- 25 => RE_Bits_25,
- 26 => RE_Bits_26,
- 27 => RE_Bits_27,
- 28 => RE_Bits_28,
- 29 => RE_Bits_29,
- 30 => RE_Bits_30,
- 31 => RE_Bits_31,
- 32 => RE_Unsigned_32,
- 33 => RE_Bits_33,
- 34 => RE_Bits_34,
- 35 => RE_Bits_35,
- 36 => RE_Bits_36,
- 37 => RE_Bits_37,
- 38 => RE_Bits_38,
- 39 => RE_Bits_39,
- 40 => RE_Bits_40,
- 41 => RE_Bits_41,
- 42 => RE_Bits_42,
- 43 => RE_Bits_43,
- 44 => RE_Bits_44,
- 45 => RE_Bits_45,
- 46 => RE_Bits_46,
- 47 => RE_Bits_47,
- 48 => RE_Bits_48,
- 49 => RE_Bits_49,
- 50 => RE_Bits_50,
- 51 => RE_Bits_51,
- 52 => RE_Bits_52,
- 53 => RE_Bits_53,
- 54 => RE_Bits_54,
- 55 => RE_Bits_55,
- 56 => RE_Bits_56,
- 57 => RE_Bits_57,
- 58 => RE_Bits_58,
- 59 => RE_Bits_59,
- 60 => RE_Bits_60,
- 61 => RE_Bits_61,
- 62 => RE_Bits_62,
- 63 => RE_Bits_63);
-
- -- 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 array whose component size is N. RE_Null is used as a null
- -- entry, for the cases where a library routine is not used.
-
- Get_Id : constant E_Array :=
- (01 => RE_Null,
- 02 => RE_Null,
- 03 => RE_Get_03,
- 04 => RE_Null,
- 05 => RE_Get_05,
- 06 => RE_Get_06,
- 07 => RE_Get_07,
- 08 => RE_Null,
- 09 => RE_Get_09,
- 10 => RE_Get_10,
- 11 => RE_Get_11,
- 12 => RE_Get_12,
- 13 => RE_Get_13,
- 14 => RE_Get_14,
- 15 => RE_Get_15,
- 16 => RE_Null,
- 17 => RE_Get_17,
- 18 => RE_Get_18,
- 19 => RE_Get_19,
- 20 => RE_Get_20,
- 21 => RE_Get_21,
- 22 => RE_Get_22,
- 23 => RE_Get_23,
- 24 => RE_Get_24,
- 25 => RE_Get_25,
- 26 => RE_Get_26,
- 27 => RE_Get_27,
- 28 => RE_Get_28,
- 29 => RE_Get_29,
- 30 => RE_Get_30,
- 31 => RE_Get_31,
- 32 => RE_Null,
- 33 => RE_Get_33,
- 34 => RE_Get_34,
- 35 => RE_Get_35,
- 36 => RE_Get_36,
- 37 => RE_Get_37,
- 38 => RE_Get_38,
- 39 => RE_Get_39,
- 40 => RE_Get_40,
- 41 => RE_Get_41,
- 42 => RE_Get_42,
- 43 => RE_Get_43,
- 44 => RE_Get_44,
- 45 => RE_Get_45,
- 46 => RE_Get_46,
- 47 => RE_Get_47,
- 48 => RE_Get_48,
- 49 => RE_Get_49,
- 50 => RE_Get_50,
- 51 => RE_Get_51,
- 52 => RE_Get_52,
- 53 => RE_Get_53,
- 54 => RE_Get_54,
- 55 => RE_Get_55,
- 56 => RE_Get_56,
- 57 => RE_Get_57,
- 58 => RE_Get_58,
- 59 => RE_Get_59,
- 60 => RE_Get_60,
- 61 => RE_Get_61,
- 62 => RE_Get_62,
- 63 => RE_Get_63);
-
- -- 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 be fully aligned. This only affects the even sizes, since for the
- -- odd sizes, we do not get any fixed alignment in any case.
-
- GetU_Id : constant E_Array :=
- (01 => RE_Null,
- 02 => RE_Null,
- 03 => RE_Get_03,
- 04 => RE_Null,
- 05 => RE_Get_05,
- 06 => RE_GetU_06,
- 07 => RE_Get_07,
- 08 => RE_Null,
- 09 => RE_Get_09,
- 10 => RE_GetU_10,
- 11 => RE_Get_11,
- 12 => RE_GetU_12,
- 13 => RE_Get_13,
- 14 => RE_GetU_14,
- 15 => RE_Get_15,
- 16 => RE_Null,
- 17 => RE_Get_17,
- 18 => RE_GetU_18,
- 19 => RE_Get_19,
- 20 => RE_GetU_20,
- 21 => RE_Get_21,
- 22 => RE_GetU_22,
- 23 => RE_Get_23,
- 24 => RE_GetU_24,
- 25 => RE_Get_25,
- 26 => RE_GetU_26,
- 27 => RE_Get_27,
- 28 => RE_GetU_28,
- 29 => RE_Get_29,
- 30 => RE_GetU_30,
- 31 => RE_Get_31,
- 32 => RE_Null,
- 33 => RE_Get_33,
- 34 => RE_GetU_34,
- 35 => RE_Get_35,
- 36 => RE_GetU_36,
- 37 => RE_Get_37,
- 38 => RE_GetU_38,
- 39 => RE_Get_39,
- 40 => RE_GetU_40,
- 41 => RE_Get_41,
- 42 => RE_GetU_42,
- 43 => RE_Get_43,
- 44 => RE_GetU_44,
- 45 => RE_Get_45,
- 46 => RE_GetU_46,
- 47 => RE_Get_47,
- 48 => RE_GetU_48,
- 49 => RE_Get_49,
- 50 => RE_GetU_50,
- 51 => RE_Get_51,
- 52 => RE_GetU_52,
- 53 => RE_Get_53,
- 54 => RE_GetU_54,
- 55 => RE_Get_55,
- 56 => RE_GetU_56,
- 57 => RE_Get_57,
- 58 => RE_GetU_58,
- 59 => RE_Get_59,
- 60 => RE_GetU_60,
- 61 => RE_Get_61,
- 62 => RE_GetU_62,
- 63 => RE_Get_63);
-
- -- 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 array whose component size is N. RE_Null is used as a null
- -- entry, for the cases where a library routine is not used.
-
- Set_Id : constant E_Array :=
- (01 => RE_Null,
- 02 => RE_Null,
- 03 => RE_Set_03,
- 04 => RE_Null,
- 05 => RE_Set_05,
- 06 => RE_Set_06,
- 07 => RE_Set_07,
- 08 => RE_Null,
- 09 => RE_Set_09,
- 10 => RE_Set_10,
- 11 => RE_Set_11,
- 12 => RE_Set_12,
- 13 => RE_Set_13,
- 14 => RE_Set_14,
- 15 => RE_Set_15,
- 16 => RE_Null,
- 17 => RE_Set_17,
- 18 => RE_Set_18,
- 19 => RE_Set_19,
- 20 => RE_Set_20,
- 21 => RE_Set_21,
- 22 => RE_Set_22,
- 23 => RE_Set_23,
- 24 => RE_Set_24,
- 25 => RE_Set_25,
- 26 => RE_Set_26,
- 27 => RE_Set_27,
- 28 => RE_Set_28,
- 29 => RE_Set_29,
- 30 => RE_Set_30,
- 31 => RE_Set_31,
- 32 => RE_Null,
- 33 => RE_Set_33,
- 34 => RE_Set_34,
- 35 => RE_Set_35,
- 36 => RE_Set_36,
- 37 => RE_Set_37,
- 38 => RE_Set_38,
- 39 => RE_Set_39,
- 40 => RE_Set_40,
- 41 => RE_Set_41,
- 42 => RE_Set_42,
- 43 => RE_Set_43,
- 44 => RE_Set_44,
- 45 => RE_Set_45,
- 46 => RE_Set_46,
- 47 => RE_Set_47,
- 48 => RE_Set_48,
- 49 => RE_Set_49,
- 50 => RE_Set_50,
- 51 => RE_Set_51,
- 52 => RE_Set_52,
- 53 => RE_Set_53,
- 54 => RE_Set_54,
- 55 => RE_Set_55,
- 56 => RE_Set_56,
- 57 => RE_Set_57,
- 58 => RE_Set_58,
- 59 => RE_Set_59,
- 60 => RE_Set_60,
- 61 => RE_Set_61,
- 62 => RE_Set_62,
- 63 => RE_Set_63);
-
- -- 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 be fully aligned. This only affects the even sizes, since for the
- -- odd sizes, we do not get any fixed alignment in any case.
-
- SetU_Id : constant E_Array :=
- (01 => RE_Null,
- 02 => RE_Null,
- 03 => RE_Set_03,
- 04 => RE_Null,
- 05 => RE_Set_05,
- 06 => RE_SetU_06,
- 07 => RE_Set_07,
- 08 => RE_Null,
- 09 => RE_Set_09,
- 10 => RE_SetU_10,
- 11 => RE_Set_11,
- 12 => RE_SetU_12,
- 13 => RE_Set_13,
- 14 => RE_SetU_14,
- 15 => RE_Set_15,
- 16 => RE_Null,
- 17 => RE_Set_17,
- 18 => RE_SetU_18,
- 19 => RE_Set_19,
- 20 => RE_SetU_20,
- 21 => RE_Set_21,
- 22 => RE_SetU_22,
- 23 => RE_Set_23,
- 24 => RE_SetU_24,
- 25 => RE_Set_25,
- 26 => RE_SetU_26,
- 27 => RE_Set_27,
- 28 => RE_SetU_28,
- 29 => RE_Set_29,
- 30 => RE_SetU_30,
- 31 => RE_Set_31,
- 32 => RE_Null,
- 33 => RE_Set_33,
- 34 => RE_SetU_34,
- 35 => RE_Set_35,
- 36 => RE_SetU_36,
- 37 => RE_Set_37,
- 38 => RE_SetU_38,
- 39 => RE_Set_39,
- 40 => RE_SetU_40,
- 41 => RE_Set_41,
- 42 => RE_SetU_42,
- 43 => RE_Set_43,
- 44 => RE_SetU_44,
- 45 => RE_Set_45,
- 46 => RE_SetU_46,
- 47 => RE_Set_47,
- 48 => RE_SetU_48,
- 49 => RE_Set_49,
- 50 => RE_SetU_50,
- 51 => RE_Set_51,
- 52 => RE_SetU_52,
- 53 => RE_Set_53,
- 54 => RE_SetU_54,
- 55 => RE_Set_55,
- 56 => RE_SetU_56,
- 57 => RE_Set_57,
- 58 => RE_SetU_58,
- 59 => RE_Set_59,
- 60 => RE_SetU_60,
- 61 => RE_Set_61,
- 62 => RE_SetU_62,
- 63 => RE_Set_63);
+ -- The shifts that are used to right justify a field therefore differ in
+ -- the two cases. For the little-endian case, we can simply use the bit
+ -- number (i.e. the element number * element size) as the count for a right
+ -- shift. For the big-endian case, we have to subtract the shift count from
+ -- an appropriate constant to use in the right shift. We use rotates
+ -- instead of shifts (which is necessary in the store case to preserve
+ -- other fields), and we expect that the backend will be able to change the
+ -- right rotate into a left rotate, avoiding the subtract, if the machine
+ -- architecture provides such an instruction.
-----------------------
-- Local Subprograms --
(Atyp : Entity_Id;
N : Node_Id;
Subscr : out Node_Id);
- -- Given a constrained array type Atyp, and an indexed component node
- -- N referencing an array object of this type, build an expression of
- -- type Standard.Integer representing the zero-based linear subscript
- -- value. This expression includes any required range checks.
+ -- Given a constrained array type Atyp, and an indexed component node N
+ -- referencing an array object of this type, build an expression of type
+ -- Standard.Integer representing the zero-based linear subscript value.
+ -- This expression includes any required range checks.
+
+ function Compute_Number_Components
+ (N : Node_Id;
+ Typ : Entity_Id) return Node_Id;
+ -- Build an expression that multiplies the length of the dimensions of the
+ -- array, used to control array equality checks.
procedure Convert_To_PAT_Type (Aexp : Node_Id);
-- Given an expression of a packed array type, builds a corresponding
-- expression whose type is the implementation type used to represent
-- the packed array. Aexp is analyzed and resolved on entry and on exit.
+ procedure Get_Base_And_Bit_Offset
+ (N : Node_Id;
+ Base : out Node_Id;
+ Offset : out Node_Id);
+ -- Given a node N for a name which involves a packed array reference,
+ -- return the base object of the reference and build an expression of
+ -- type Standard.Integer representing the zero-based offset in bits
+ -- from Base'Address to the first bit of the reference.
+
function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean;
-- There are two versions of the Set routines, the ones used when the
-- object is known to be sufficiently well aligned given the number of
Expr : Node_Id) return Node_Id;
-- The packed array code does unchecked conversions which in some cases
-- may involve non-discrete types with differing sizes. The semantics of
- -- such conversions is potentially endian dependent, and the effect we
- -- want here for such a conversion is to do the conversion in size as
+ -- such conversions is potentially endianness dependent, and the effect
+ -- we want here for such a conversion is to do the conversion in size as
-- though numeric items are involved, and we extend or truncate on the
-- left side. This happens naturally in the little-endian case, but in
-- the big endian case we can get left justification, when what we want
Shift : out Node_Id);
-- This procedure performs common processing on the N_Indexed_Component
-- parameter given as N, whose prefix is a reference to a packed array.
- -- This is used for the get and set when the component size is 1,2,4
+ -- This is used for the get and set when the component size is 1, 2, 4,
-- or for other component sizes when the packed array type is a modular
-- type (i.e. the cases that are handled with inline code).
--
--
-- Atyp is the constrained array type (the actual subtype has been
-- computed if necessary to obtain the constraints, but this is still
- -- the original array type, not the Packed_Array_Type value).
+ -- the original array type, not the Packed_Array_Impl_Type value).
--
-- Obj is the object which is to be indexed. It is always of type Atyp.
--
-- array type on the fly). Such actions are inserted into the tree
-- directly using Insert_Action.
+ function Revert_Storage_Order (N : Node_Id) return Node_Id;
+ -- Perform appropriate justification and byte ordering adjustments for N,
+ -- an element of a packed array type, when both the component type and
+ -- the enclosing packed array type have reverse scalar storage order.
+ -- On little-endian targets, the value is left justified before byte
+ -- swapping. The Etype of the returned expression is an integer type of
+ -- an appropriate power-of-2 size.
+
+ --------------------------
+ -- Revert_Storage_Order --
+ --------------------------
+
+ function Revert_Storage_Order (N : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+ T : constant Entity_Id := Etype (N);
+ T_Size : constant Uint := RM_Size (T);
+
+ Swap_RE : RE_Id;
+ Swap_F : Entity_Id;
+ Swap_T : Entity_Id;
+ -- Swapping function
+
+ Arg : Node_Id;
+ Adjusted : Node_Id;
+ Shift : Uint;
+
+ begin
+ if T_Size <= 8 then
+
+ -- Array component size is less than a byte: no swapping needed
+
+ Swap_F := Empty;
+ Swap_T := RTE (RE_Unsigned_8);
+
+ else
+ -- Select byte swapping function depending on array component size
+
+ if T_Size <= 16 then
+ Swap_RE := RE_Bswap_16;
+
+ elsif T_Size <= 32 then
+ Swap_RE := RE_Bswap_32;
+
+ else pragma Assert (T_Size <= 64);
+ Swap_RE := RE_Bswap_64;
+ end if;
+
+ Swap_F := RTE (Swap_RE);
+ Swap_T := Etype (Swap_F);
+
+ end if;
+
+ Shift := Esize (Swap_T) - T_Size;
+
+ Arg := RJ_Unchecked_Convert_To (Swap_T, N);
+
+ if not Bytes_Big_Endian and then Shift > Uint_0 then
+ Arg :=
+ Make_Op_Shift_Left (Loc,
+ Left_Opnd => Arg,
+ Right_Opnd => Make_Integer_Literal (Loc, Shift));
+ end if;
+
+ if Present (Swap_F) then
+ Adjusted :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Swap_F, Loc),
+ Parameter_Associations => New_List (Arg));
+ else
+ Adjusted := Arg;
+ end if;
+
+ Set_Etype (Adjusted, Swap_T);
+ return Adjusted;
+ end Revert_Storage_Order;
+
------------------------------
- -- Compute_Linear_Subcsript --
+ -- Compute_Linear_Subscript --
------------------------------
procedure Compute_Linear_Subscript
Attribute_Name => Name_Pos,
Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Styp, Loc),
- Attribute_Name => Name_First)))));
+ Prefix => New_Occurrence_Of (Styp, Loc),
+ Attribute_Name => Name_First)))));
end if;
Set_Paren_Count (Newsub, 1);
end loop;
end Compute_Linear_Subscript;
+ -------------------------------
+ -- Compute_Number_Components --
+ -------------------------------
+
+ function Compute_Number_Components
+ (N : Node_Id;
+ Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Len_Expr : Node_Id;
+
+ begin
+ Len_Expr :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Length,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Expressions => New_List (Make_Integer_Literal (Loc, 1)));
+
+ for J in 2 .. Number_Dimensions (Typ) loop
+ Len_Expr :=
+ Make_Op_Multiply (Loc,
+ Left_Opnd => Len_Expr,
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Length,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Expressions => New_List (Make_Integer_Literal (Loc, J))));
+ end loop;
+
+ return Len_Expr;
+ end Compute_Number_Components;
+
-------------------------
-- Convert_To_PAT_Type --
-------------------------
begin
Convert_To_Actual_Subtype (Aexp);
Act_ST := Underlying_Type (Etype (Aexp));
- Create_Packed_Array_Type (Act_ST);
+ Create_Packed_Array_Impl_Type (Act_ST);
-- Just replace the etype with the packed array type. This works because
-- the expression will not be further analyzed, and Gigi considers the
-- see Reset_Packed_Prefix. On the other hand, if the prefix is a simple
-- array reference, reanalysis can produce spurious type errors when the
-- PAT type is replaced again with the original type of the array. Same
- -- for the case of a dereference. The following is correct and minimal,
- -- but the handling of more complex packed expressions in actuals is
- -- confused. Probably the problem only remains for actuals in calls.
+ -- for the case of a dereference. Ditto for function calls: expansion
+ -- may introduce additional actuals which will trigger errors if call is
+ -- reanalyzed. The following is correct and minimal, but the handling of
+ -- more complex packed expressions in actuals is confused. Probably the
+ -- problem only remains for actuals in calls.
- Set_Etype (Aexp, Packed_Array_Type (Act_ST));
+ Set_Etype (Aexp, Packed_Array_Impl_Type (Act_ST));
if Is_Entity_Name (Aexp)
or else
(Nkind (Aexp) = N_Indexed_Component
and then Is_Entity_Name (Prefix (Aexp)))
- or else Nkind (Aexp) = N_Explicit_Dereference
+ or else Nkind_In (Aexp, N_Explicit_Dereference, N_Function_Call)
then
Set_Analyzed (Aexp);
end if;
end Convert_To_PAT_Type;
- ------------------------------
- -- Create_Packed_Array_Type --
- ------------------------------
+ -----------------------------------
+ -- Create_Packed_Array_Impl_Type --
+ -----------------------------------
- procedure Create_Packed_Array_Type (Typ : Entity_Id) is
+ procedure Create_Packed_Array_Impl_Type (Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
Ctyp : constant Entity_Id := Component_Type (Typ);
Csize : constant Uint := Component_Size (Typ);
PASize : Uint;
Decl : Node_Id;
PAT : Entity_Id;
- Len_Dim : Node_Id;
Len_Expr : Node_Id;
Len_Bits : Uint;
Bits_U1 : Node_Id;
-- the resulting type as an Itype in the packed array type field of
-- the original type, so that no explicit declaration is required.
- -- Note: the packed type is created in the scope of its parent
- -- type. There are at least some cases where the current scope
- -- is deeper, and so when this is the case, we temporarily reset
- -- the scope for the definition. This is clearly safe, since the
- -- first use of the packed array type will be the implicit
- -- reference from the corresponding unpacked type when it is
- -- elaborated.
+ -- Note: the packed type is created in the scope of its parent type.
+ -- There are at least some cases where the current scope is deeper,
+ -- and so when this is the case, we temporarily reset the scope
+ -- for the definition. This is clearly safe, since the first use
+ -- of the packed array type will be the implicit reference from
+ -- the corresponding unpacked type when it is elaborated.
if Is_Itype (Typ) then
Set_Parent (Decl, Associated_Node_For_Itype (Typ));
end if;
Set_Is_Itype (PAT, True);
- Set_Packed_Array_Type (Typ, PAT);
+ Set_Is_Packed_Array_Impl_Type (PAT, True);
+ Set_Packed_Array_Impl_Type (Typ, PAT);
Analyze (Decl, Suppress => All_Checks);
if Pushed_Scope then
Init_Alignment (PAT);
Set_Parent (PAT, Empty);
Set_Associated_Node_For_Itype (PAT, Typ);
- Set_Is_Packed_Array_Type (PAT, True);
Set_Original_Array_Type (PAT, Typ);
+ -- Propagate representation aspects
+
+ Set_Is_Atomic (PAT, Is_Atomic (Typ));
+ Set_Is_Independent (PAT, Is_Independent (Typ));
+ Set_Is_Volatile (PAT, Is_Volatile (Typ));
+ Set_Is_Volatile_Full_Access (PAT, Is_Volatile_Full_Access (Typ));
+ Set_Treat_As_Volatile (PAT, Treat_As_Volatile (Typ));
+
+ -- For a non-bit-packed array, propagate reverse storage order
+ -- flag from original base type to packed array base type.
+
+ if not Is_Bit_Packed_Array (Typ) then
+ Set_Reverse_Storage_Order
+ (Etype (PAT), Reverse_Storage_Order (Base_Type (Typ)));
+ end if;
+
-- We definitely do not want to delay freezing for packed array
- -- types. This is of particular importance for the itypes that
- -- are generated for record components depending on discriminants
- -- where there is no place to put the freeze node.
+ -- types. This is of particular importance for the itypes that are
+ -- generated for record components depending on discriminants where
+ -- there is no place to put the freeze node.
Set_Has_Delayed_Freeze (PAT, False);
Set_Has_Delayed_Freeze (Etype (PAT), False);
end if;
end Set_PB_Type;
- -- Start of processing for Create_Packed_Array_Type
+ -- Start of processing for Create_Packed_Array_Impl_Type
begin
-- If we already have a packed array type, nothing to do
- if Present (Packed_Array_Type (Typ)) then
+ if Present (Packed_Array_Impl_Type (Typ)) then
return;
end if;
if Present (Ancest)
and then Is_Array_Type (Ancest)
and then Is_Constrained (Ancest)
- and then Present (Packed_Array_Type (Ancest))
+ and then Present (Packed_Array_Impl_Type (Ancest))
then
- Set_Packed_Array_Type (Typ, Packed_Array_Type (Ancest));
+ Set_Packed_Array_Impl_Type (Typ, Packed_Array_Impl_Type (Ancest));
return;
end if;
end if;
-- Natural range Enum_Type'Pos (Enum_Type'First) ..
-- Enum_Type'Pos (Enum_Type'Last);
+ -- Note that tttP is created even if no index subtype is a non
+ -- standard enumeration, because we still need to remove padding
+ -- normally inserted for component alignment.
+
PAT :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), 'P'));
- Set_Packed_Array_Type (Typ, PAT);
-
declare
Indexes : constant List_Id := New_List;
Indx : Node_Id;
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (Indx_Typ, Loc),
Attribute_Name => Name_Pos,
- Expressions => New_List (
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (Indx_Typ, Loc),
Attribute_Name => Name_First))),
High_Bound =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (Indx_Typ, Loc),
Attribute_Name => Name_Pos,
- Expressions => New_List (
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (Indx_Typ, Loc),
Attribute_Name => Name_Last)))))));
Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => PAT,
- Type_Definition => Typedef);
+ Type_Definition => Typedef);
end;
- -- Set type as packed array type and install it
-
- Set_Is_Packed_Array_Type (PAT);
Install_PAT;
return;
-- a subtype that is equivalent to use Packed_Bytes{1,2,4} as needed.
elsif not Is_Constrained (Typ) then
+
+ -- When generating standard DWARF (i.e when GNAT_Encodings is
+ -- DWARF_GNAT_Encodings_Minimal), the ___XP suffix will be stripped
+ -- by the back-end but generate it anyway to ease compiler debugging.
+ -- This will help to distinguish implementation types from original
+ -- packed arrays.
+
PAT :=
Make_Defining_Identifier (Loc,
- Chars => Make_Packed_Array_Type_Name (Typ, Csize));
+ Chars => Make_Packed_Array_Impl_Type_Name (Typ, Csize));
- Set_Packed_Array_Type (Typ, PAT);
Set_PB_Type;
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => PAT,
Subtype_Indication => New_Occurrence_Of (PB_Type, Loc));
+
Install_PAT;
return;
-- The name of the packed array subtype is
- -- ttt___Xsss
+ -- ttt___XPsss
-- where sss is the component size in bits and ttt is the name of
-- the parent packed type.
else
PAT :=
Make_Defining_Identifier (Loc,
- Chars => Make_Packed_Array_Type_Name (Typ, Csize));
-
- Set_Packed_Array_Type (Typ, PAT);
+ Chars => Make_Packed_Array_Impl_Type_Name (Typ, Csize));
-- Build an expression for the length of the array in bits.
-- This is the product of the length of each of the dimensions
- declare
- J : Nat := 1;
-
- begin
- Len_Expr := Empty; -- suppress junk warning
-
- loop
- Len_Dim :=
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Length,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Expressions => New_List (
- Make_Integer_Literal (Loc, J)));
-
- if J = 1 then
- Len_Expr := Len_Dim;
-
- else
- Len_Expr :=
- Make_Op_Multiply (Loc,
- Left_Opnd => Len_Expr,
- Right_Opnd => Len_Dim);
- end if;
-
- J := J + 1;
- exit when J > Number_Dimensions (Typ);
- end loop;
- end;
+ Len_Expr := Compute_Number_Components (Typ, Typ);
-- Temporarily attach the length expression to the tree and analyze
-- and resolve it, so that we can test its value. We assume that the
-- discriminants, so we treat it as a default/per-object expression.
Set_Parent (Len_Expr, Typ);
- Analyze_Per_Use_Expression (Len_Expr, Standard_Long_Long_Integer);
+ Preanalyze_Spec_Expression (Len_Expr, Standard_Long_Long_Integer);
-- Use a modular type if possible. We can do this if we have
-- static bounds, and the length is small enough, and the length
(Len_Bits <= System_Word_Size
or else (Len_Bits <= System_Max_Binary_Modulus_Power
and then Support_Long_Shifts_On_Target))
-
- -- Also test for alignment given. If an alignment is given which
- -- is smaller than the natural modular alignment, force the array
- -- of bytes representation to accommodate the alignment.
-
- and then
- (No (Alignment_Clause (Typ))
- or else
- Alignment (Typ) >= ((Len_Bits + System_Storage_Unit)
- / System_Storage_Unit))
then
-- We can use the modular type, it has the form:
end if;
Install_PAT;
+
+ -- Propagate a given alignment to the modular type. This can
+ -- cause it to be under-aligned, but that's OK.
+
+ if Present (Alignment_Clause (Typ)) then
+ Set_Alignment (PAT, Alignment (Typ));
+ end if;
+
return;
end if;
end if;
Set_Must_Be_On_Byte_Boundary (Typ);
end if;
end if;
- end Create_Packed_Array_Type;
+ end Create_Packed_Array_Impl_Type;
-----------------------------------
-- Expand_Bit_Packed_Element_Set --
Ass_OK : constant Boolean := Assignment_OK (Lhs);
-- Used to preserve assignment OK status when assignment is rewritten
- Rhs : Node_Id := Expression (N);
+ Expr : Node_Id;
+
+ Rhs : Node_Id := Expression (N);
-- Initially Rhs is the right hand side value, it will be replaced
-- later by an appropriate unchecked conversion for the assignment.
- Obj : Node_Id;
- Atyp : Entity_Id;
- PAT : Entity_Id;
- Ctyp : Entity_Id;
- Csiz : Int;
- Cmask : Uint;
+ Obj : Node_Id;
+ Atyp : Entity_Id;
+ PAT : Entity_Id;
+ Ctyp : Entity_Id;
+ Csiz : Int;
+ Cmask : Uint;
Shift : Node_Id;
-- The expression for the shift value that is required
Shift_Used : Boolean := False;
- -- Set True if Shift has been used in the generated code at least
- -- once, so that it must be duplicated if used again
+ -- Set True if Shift has been used in the generated code at least once,
+ -- so that it must be duplicated if used again.
New_Lhs : Node_Id;
New_Rhs : Node_Id;
Obj := Relocate_Node (Prefix (Lhs));
Convert_To_Actual_Subtype (Obj);
Atyp := Etype (Obj);
- PAT := Packed_Array_Type (Atyp);
+ PAT := Packed_Array_Impl_Type (Atyp);
Ctyp := Component_Type (Atyp);
Csiz := UI_To_Int (Component_Size (Atyp));
+ -- We remove side effects, in case the rhs modifies the lhs, because we
+ -- are about to transform the rhs into an expression that first READS
+ -- the lhs, so we can do the necessary shifting and masking. Example:
+ -- "X(2) := F(...);" where F modifies X(3). Otherwise, the side effect
+ -- will be lost.
+
+ Remove_Side_Effects (Rhs);
+
-- We convert the right hand side to the proper subtype to ensure
-- that an appropriate range check is made (since the normal range
-- check from assignment will be lost in the transformations). This
begin
Decl :=
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
- Object_Definition => New_Occurrence_Of (Ctyp, Loc),
- Expression => New_Copy_Tree (Rhs));
+ Defining_Identifier => Make_Temporary (Loc, 'T', Rhs),
+ Object_Definition => New_Occurrence_Of (Ctyp, Loc),
+ Expression => New_Copy_Tree (Rhs));
Insert_Actions (N, New_List (Decl));
Rhs := New_Occurrence_Of (Defining_Identifier (Decl), Loc);
Rhs := Convert_To (Ctyp, Rhs);
Set_Parent (Rhs, N);
- Analyze_And_Resolve (Rhs, Ctyp);
+
+ -- If we are building the initialization procedure for a packed array,
+ -- and Initialize_Scalars is enabled, each component assignment is an
+ -- out-of-range value by design. Compile this value without checks,
+ -- because a call to the array init_proc must not raise an exception.
+
+ -- Condition is not consistent with description above, Within_Init_Proc
+ -- is True also when we are building the IP for a record or protected
+ -- type that has a packed array component???
+
+ if Within_Init_Proc
+ and then Initialize_Scalars
+ then
+ Analyze_And_Resolve (Rhs, Ctyp, Suppress => All_Checks);
+ else
+ Analyze_And_Resolve (Rhs, Ctyp);
+ end if;
+
+ -- If any of the indices has a nonstandard representation, introduce
+ -- the proper Rep_To_Pos conversion, which in turn will generate index
+ -- checks when needed. We do this on a copy of the index expression,
+ -- rather that rewriting the LHS altogether.
+
+ Expr := First (Expressions (Lhs));
+ while Present (Expr) loop
+ declare
+ Expr_Typ : constant Entity_Id := Etype (Expr);
+ Loc : constant Source_Ptr := Sloc (Expr);
+
+ Expr_Copy : Node_Id;
+
+ begin
+ if Is_Enumeration_Type (Expr_Typ)
+ and then Has_Non_Standard_Rep (Expr_Typ)
+ then
+ Expr_Copy :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Expr_Typ, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (Relocate_Node (Expr)));
+ Set_Parent (Expr_Copy, N);
+ Analyze_And_Resolve (Expr_Copy, Standard_Natural);
+ end if;
+ end;
+
+ Next (Expr);
+ end loop;
-- Case of component size 1,2,4 or any component size for the modular
-- case. These are the cases for which we can inline the code.
-- The statement to be generated is:
- -- Obj := atyp!((Obj and Mask1) or (shift_left (rhs, shift)))
+ -- Obj := atyp!((Obj and Mask1) or (shift_left (rhs, Shift)))
+
+ -- or in the case of a freestanding Reverse_Storage_Order object,
- -- where mask1 is obtained by shifting Cmask left Shift bits
+ -- Obj := Swap (atyp!((Swap (Obj) and Mask1)
+ -- or (shift_left (rhs, Shift))))
+
+ -- where Mask1 is obtained by shifting Cmask left Shift bits
-- and then complementing the result.
-- the "and Mask1" is omitted if rhs is constant and all 1 bits
Rhs_Val := Expr_Rep_Value (Rhs);
Rhs_Val_Known := True;
- -- The following test catches the case of an unchecked conversion
- -- of an integer literal. This results from optimizing aggregates
- -- of packed types.
+ -- The following test catches the case of an unchecked conversion of
+ -- an integer literal. This results from optimizing aggregates of
+ -- packed types.
elsif Nkind (Rhs) = N_Unchecked_Type_Conversion
and then Compile_Time_Known_Value (Expression (Rhs))
Rhs_Val_Known := False;
end if;
- -- Some special checks for the case where the right hand value
- -- is known at compile time. Basically we have to take care of
- -- the implicit conversion to the subtype of the component object.
+ -- Some special checks for the case where the right hand value is
+ -- known at compile time. Basically we have to take care of the
+ -- implicit conversion to the subtype of the component object.
if Rhs_Val_Known then
- -- If we have a biased component type then we must manually do
- -- the biasing, since we are taking responsibility in this case
- -- for constructing the exact bit pattern to be used.
+ -- If we have a biased component type then we must manually do the
+ -- biasing, since we are taking responsibility in this case for
+ -- constructing the exact bit pattern to be used.
if Has_Biased_Representation (Ctyp) then
Rhs_Val := Rhs_Val - Expr_Rep_Value (Type_Low_Bound (Ctyp));
end if;
- -- For a negative value, we manually convert the twos complement
+ -- For a negative value, we manually convert the two's complement
-- value to a corresponding unsigned value, so that the proper
-- field width is maintained. If we did not do this, we would
-- get too many leading sign bits later on.
end if;
end if;
- New_Lhs := Duplicate_Subexpr (Obj, True);
+ -- Now create copies removing side effects. Note that in some complex
+ -- cases, this may cause the fact that we have already set a packed
+ -- array type on Obj to get lost. So we save the type of Obj, and
+ -- make sure it is reset properly.
+
+ New_Lhs := Duplicate_Subexpr (Obj, Name_Req => True);
New_Rhs := Duplicate_Subexpr_No_Checks (Obj);
-- First we deal with the "and"
Rhs := Unchecked_Convert_To (RTE (Bits_Id (Csiz)), Rhs);
end if;
- -- Set Etype, since it can be referenced before the
- -- node is completely analyzed.
+ -- Set Etype, since it can be referenced before the node is
+ -- completely analyzed.
Set_Etype (Rhs, Etyp);
-- not a left justified conversion.
Rhs := RJ_Unchecked_Convert_To (Etype (Obj), Rhs);
-
end Fixup_Rhs;
begin
else
-- We have to convert the right hand side to Etype (Obj).
- -- A special case case arises if what we have now is a Val
+ -- A special case arises if what we have now is a Val
-- attribute reference whose expression type is Etype (Obj).
-- This happens for assignments of fields from the same
-- array. In this case we get the required right hand side
-- Note that Rhs_Val has already been normalized to
-- be an unsigned value with the proper number of bits.
- Rhs :=
- Make_Integer_Literal (Loc, Rhs_Val);
+ Rhs := Make_Integer_Literal (Loc, Rhs_Val);
-- Otherwise we need an unchecked conversion
if Nkind (New_Rhs) = N_Op_And then
Set_Paren_Count (New_Rhs, 1);
+ Set_Etype (New_Rhs, Etype (Left_Opnd (New_Rhs)));
end if;
New_Rhs :=
Set_nn : Entity_Id;
Subscr : Node_Id;
Atyp : Entity_Id;
+ Rev_SSO : Node_Id;
begin
if No (Bits_nn) then
Atyp := Etype (Obj);
Compute_Linear_Subscript (Atyp, Lhs, Subscr);
+ -- Set indication of whether the packed array has reverse SSO
+
+ Rev_SSO :=
+ New_Occurrence_Of
+ (Boolean_Literals (Reverse_Storage_Order (Atyp)), Loc);
+
-- Below we must make the assumption that Obj is
-- at least byte aligned, since otherwise its address
-- cannot be taken. The assumption holds since the
Name => New_Occurrence_Of (Set_nn, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => Obj),
+ Prefix => Obj,
+ Attribute_Name => Name_Address),
Subscr,
- Unchecked_Convert_To (Bits_nn,
- Convert_To (Ctyp, Rhs)))));
+ Unchecked_Convert_To (Bits_nn, Convert_To (Ctyp, Rhs)),
+ Rev_SSO)));
end;
end if;
procedure Expand_Packed_Address_Reference (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Ploc : Source_Ptr;
- Pref : Node_Id;
- Expr : Node_Id;
- Term : Node_Id;
- Atyp : Entity_Id;
- Subscr : Node_Id;
+ Base : Node_Id;
+ Offset : Node_Id;
begin
- Pref := Prefix (N);
- Expr := Empty;
-
- -- We build up an expression serially that has the form
+ -- We build an expression that has the form
-- outer_object'Address
-- + (linear-subscript * component_size for each array reference
-- + ...
-- + ...) / Storage_Unit;
- -- Some additional conversions are required to deal with the addition
- -- operation, which is not normally visible to generated code.
-
- loop
- Ploc := Sloc (Pref);
-
- if Nkind (Pref) = N_Indexed_Component then
- Convert_To_Actual_Subtype (Prefix (Pref));
- Atyp := Etype (Prefix (Pref));
- Compute_Linear_Subscript (Atyp, Pref, Subscr);
-
- Term :=
- Make_Op_Multiply (Ploc,
- Left_Opnd => Subscr,
- Right_Opnd =>
- Make_Attribute_Reference (Ploc,
- Prefix => New_Occurrence_Of (Atyp, Ploc),
- Attribute_Name => Name_Component_Size));
-
- elsif Nkind (Pref) = N_Selected_Component then
- Term :=
- Make_Attribute_Reference (Ploc,
- Prefix => Selector_Name (Pref),
- Attribute_Name => Name_Bit_Position);
-
- else
- exit;
- end if;
-
- Term := Convert_To (RTE (RE_Integer_Address), Term);
-
- if No (Expr) then
- Expr := Term;
-
- else
- Expr :=
- Make_Op_Add (Ploc,
- Left_Opnd => Expr,
- Right_Opnd => Term);
- end if;
-
- Pref := Prefix (Pref);
- end loop;
+ Get_Base_And_Bit_Offset (Prefix (N), Base, Offset);
Rewrite (N,
Unchecked_Convert_To (RTE (RE_Address),
Left_Opnd =>
Unchecked_Convert_To (RTE (RE_Integer_Address),
Make_Attribute_Reference (Loc,
- Prefix => Pref,
+ Prefix => Base,
Attribute_Name => Name_Address)),
Right_Opnd =>
- Make_Op_Divide (Loc,
- Left_Opnd => Expr,
- Right_Opnd =>
- Make_Integer_Literal (Loc, System_Storage_Unit)))));
+ Unchecked_Convert_To (RTE (RE_Integer_Address),
+ Make_Op_Divide (Loc,
+ Left_Opnd => Offset,
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, System_Storage_Unit))))));
Analyze_And_Resolve (N, RTE (RE_Address));
end Expand_Packed_Address_Reference;
+ ---------------------------------
+ -- Expand_Packed_Bit_Reference --
+ ---------------------------------
+
+ procedure Expand_Packed_Bit_Reference (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Base : Node_Id;
+ Offset : Node_Id;
+
+ begin
+ -- We build an expression that has the form
+
+ -- (linear-subscript * component_size for each array reference
+ -- + field'Bit_Position for each record field
+ -- + ...
+ -- + ...) mod Storage_Unit;
+
+ Get_Base_And_Bit_Offset (Prefix (N), Base, Offset);
+
+ Rewrite (N,
+ Unchecked_Convert_To (Standard_Natural,
+ Make_Op_Mod (Loc,
+ Left_Opnd => Offset,
+ Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit))));
+
+ Analyze_And_Resolve (N, Standard_Natural);
+ end Expand_Packed_Bit_Reference;
+
------------------------------------
-- Expand_Packed_Boolean_Operator --
------------------------------------
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
L : constant Node_Id := Relocate_Node (Left_Opnd (N));
- R : constant Node_Id := Relocate_Node (Right_Opnd (N));
+ R : Node_Id := Relocate_Node (Right_Opnd (N));
Ltyp : Entity_Id;
Rtyp : Entity_Id;
Ltyp := Etype (L);
Rtyp := Etype (R);
- -- First an odd and silly test. We explicitly check for the XOR
- -- case where the component type is True .. True, since this will
- -- raise constraint error. A special check is required since CE
- -- will not be required other wise (cf Expand_Packed_Not).
-
- -- No such check is required for AND and OR, since for both these
- -- cases False op False = False, and True op True = True.
+ -- Deal with silly case of XOR where the subcomponent has a range
+ -- True .. True where an exception must be raised.
if Nkind (N) = N_Op_Xor then
- declare
- CT : constant Entity_Id := Component_Type (Rtyp);
- BT : constant Entity_Id := Base_Type (CT);
-
- begin
- Insert_Action (N,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_And (Loc,
- Left_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (CT, Loc),
- Attribute_Name => Name_First),
-
- Right_Opnd =>
- Convert_To (BT,
- New_Occurrence_Of (Standard_True, Loc))),
-
- Right_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (CT, Loc),
- Attribute_Name => Name_Last),
-
- Right_Opnd =>
- Convert_To (BT,
- New_Occurrence_Of (Standard_True, Loc)))),
- Reason => CE_Range_Check_Failed));
- end;
+ R := Duplicate_Subexpr (R);
+ Silly_Boolean_Array_Xor_Test (N, R, Rtyp);
end if;
- -- Now that that silliness is taken care of, get packed array type
+ -- Now that silliness is taken care of, get packed array type
Convert_To_PAT_Type (L);
Convert_To_PAT_Type (R);
-- Result : Ltype;
- -- System.Bitops.Bit_And/Or/Xor
+ -- System.Bit_Ops.Bit_And/Or/Xor
-- (Left'Address,
-- Ltype'Length * Ltype'Component_Size;
-- Right'Address,
else
declare
- Result_Ent : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
-
- E_Id : RE_Id;
+ Result_Ent : constant Entity_Id := Make_Temporary (Loc, 'T');
+ E_Id : RE_Id;
begin
if Nkind (N) = N_Op_And then
Parameter_Associations => New_List (
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => L),
+ Prefix => L,
+ Attribute_Name => Name_Address),
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of
(Etype (First_Index (Ltyp)), Loc),
Attribute_Name => Name_Range_Length),
+
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Ltyp))),
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => R),
+ Prefix => R,
+ Attribute_Name => Name_Address),
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of
(Etype (First_Index (Rtyp)), Loc),
Attribute_Name => Name_Range_Length),
+
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Rtyp))),
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => New_Occurrence_Of (Result_Ent, Loc))))));
+ Prefix => New_Occurrence_Of (Result_Ent, Loc),
+ Attribute_Name => Name_Address)))));
Rewrite (N,
New_Occurrence_Of (Result_Ent, Loc));
Arg : Node_Id;
begin
+ -- If the node is an actual in a call, the prefix has not been fully
+ -- expanded, to account for the additional expansion for in-out actuals
+ -- (see expand_actuals for details). If the prefix itself is a packed
+ -- reference as well, we have to recurse to complete the transformation
+ -- of the prefix.
+
+ if Nkind (Prefix (N)) = N_Indexed_Component
+ and then not Analyzed (Prefix (N))
+ and then Is_Bit_Packed_Array (Etype (Prefix (Prefix (N))))
+ then
+ Expand_Packed_Element_Reference (Prefix (N));
+ end if;
+
+ -- The prefix may be rewritten below as a conversion. If it is a source
+ -- entity generate reference to it now, to prevent spurious warnings
+ -- about unused entities.
+
+ if Is_Entity_Name (Prefix (N))
+ and then Comes_From_Source (Prefix (N))
+ then
+ Generate_Reference (Entity (Prefix (N)), Prefix (N), 'r');
+ end if;
+
-- If not bit packed, we have the enumeration case, which is easily
-- dealt with (just adjust the subscripts of the indexed component)
Obj := Relocate_Node (Prefix (N));
Convert_To_Actual_Subtype (Obj);
Atyp := Etype (Obj);
- PAT := Packed_Array_Type (Atyp);
+ PAT := Packed_Array_Impl_Type (Atyp);
Ctyp := Component_Type (Atyp);
Csiz := UI_To_Int (Component_Size (Atyp));
Make_Op_And (Loc,
Left_Opnd => Make_Shift_Right (Obj, Shift),
Right_Opnd => Lit);
+ Set_Etype (Arg, Ctyp);
+
+ -- Component extraction is performed on a native endianness scalar
+ -- value: if Atyp has reverse storage order, then it has been byte
+ -- swapped, and if the component being extracted is itself of a
+ -- composite type with reverse storage order, then we need to swap
+ -- it back to its expected endianness after extraction.
- -- We neded to analyze this before we do the unchecked convert
+ if Reverse_Storage_Order (Atyp)
+ and then (Is_Record_Type (Ctyp) or else Is_Array_Type (Ctyp))
+ and then Reverse_Storage_Order (Ctyp)
+ then
+ Arg := Revert_Storage_Order (Arg);
+ end if;
+
+ -- We needed to analyze this before we do the unchecked convert
-- below, but we need it temporarily attached to the tree for
-- this analysis (hence the temporary Set_Parent call).
Set_Parent (Arg, Parent (N));
Analyze_And_Resolve (Arg);
- Rewrite (N,
- RJ_Unchecked_Convert_To (Ctyp, Arg));
+ Rewrite (N, RJ_Unchecked_Convert_To (Ctyp, Arg));
-- All other component sizes for non-modular case
-- where Subscr is the computed linear subscript
declare
- Get_nn : Entity_Id;
- Subscr : Node_Id;
+ Get_nn : Entity_Id;
+ Subscr : Node_Id;
+ Rev_SSO : constant Node_Id :=
+ New_Occurrence_Of
+ (Boolean_Literals (Reverse_Storage_Order (Atyp)), Loc);
begin
-- Acquire proper Get entity. We use the aligned or unaligned
Name => New_Occurrence_Of (Get_nn, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => Obj),
- Subscr))));
+ Prefix => Obj,
+ Attribute_Name => Name_Address),
+ Subscr,
+ Rev_SSO))));
end;
end if;
Analyze_And_Resolve (N, Ctyp, Suppress => All_Checks);
-
end Expand_Packed_Element_Reference;
----------------------
LLexpr :=
Make_Op_Multiply (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Length,
- Prefix => New_Occurrence_Of (Ltyp, Loc)),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Component_Size (Ltyp)));
+ Left_Opnd => Compute_Number_Components (N, Ltyp),
+ Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Ltyp)));
RLexpr :=
Make_Op_Multiply (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Length,
- Prefix => New_Occurrence_Of (Rtyp, Loc)),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Component_Size (Rtyp)));
+ Left_Opnd => Compute_Number_Components (N, Rtyp),
+ Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Rtyp)));
-- For the modular case, we transform the comparison to:
Name => New_Occurrence_Of (RTE (RE_Bit_Eq), Loc),
Parameter_Associations => New_List (
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => L),
+ Prefix => L,
+ Attribute_Name => Name_Address),
LLexpr,
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => R),
+ Prefix => R,
+ Attribute_Name => Name_Address),
RLexpr)));
end if;
Convert_To_Actual_Subtype (Opnd);
Rtyp := Etype (Opnd);
- -- First an odd and silly test. We explicitly check for the case
- -- where the 'First of the component type is equal to the 'Last of
- -- this component type, and if this is the case, we make sure that
- -- constraint error is raised. The reason is that the NOT is bound
- -- to cause CE in this case, and we will not otherwise catch it.
-
- -- Believe it or not, this was reported as a bug. Note that nearly
- -- always, the test will evaluate statically to False, so the code
- -- will be statically removed, and no extra overhead caused.
-
- declare
- CT : constant Entity_Id := Component_Type (Rtyp);
+ -- Deal with silly False..False and True..True subtype case
- begin
- Insert_Action (N,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (CT, Loc),
- Attribute_Name => Name_First),
-
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (CT, Loc),
- Attribute_Name => Name_Last)),
- Reason => CE_Range_Check_Failed));
- end;
+ Silly_Boolean_Array_Not_Test (N, Rtyp);
- -- Now that that silliness is taken care of, get packed array type
+ -- Now that the silliness is taken care of, get packed array type
Convert_To_PAT_Type (Opnd);
PAT := Etype (Opnd);
- -- For the case where the packed array type is a modular type,
- -- not A expands simply into:
+ -- For the case where the packed array type is a modular type, "not A"
+ -- expands simply into:
- -- rtyp!(PAT!(A) xor mask)
+ -- Rtyp!(PAT!(A) xor Mask)
- -- where PAT is the packed array type, and mask is a mask of all
- -- one bits of length equal to the size of this packed type and
- -- rtyp is the actual subtype of the operand
+ -- where PAT is the packed array type, Mask is a mask of all 1 bits of
+ -- length equal to the size of this packed type, and Rtyp is the actual
+ -- actual subtype of the operand.
Lit := Make_Integer_Literal (Loc, 2 ** RM_Size (PAT) - 1);
Set_Print_In_Hex (Lit);
-- Result : Typ;
- -- System.Bitops.Bit_Not
+ -- System.Bit_Ops.Bit_Not
-- (Opnd'Address,
- -- Typ'Length * Typ'Component_Size;
+ -- Typ'Length * Typ'Component_Size,
-- Result'Address);
- -- where Opnd is the Packed_Bytes{1,2,4} operand and the second
- -- argument is the length of the operand in bits. Then we replace
- -- the expression by a reference to Result.
+ -- where Opnd is the Packed_Bytes{1,2,4} operand and the second argument
+ -- is the length of the operand in bits. We then replace the expression
+ -- with a reference to Result.
else
declare
- Result_Ent : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
+ Result_Ent : constant Entity_Id := Make_Temporary (Loc, 'T');
begin
Insert_Actions (N, New_List (
-
Make_Object_Declaration (Loc,
Defining_Identifier => Result_Ent,
- Object_Definition => New_Occurrence_Of (Rtyp, Loc)),
+ Object_Definition => New_Occurrence_Of (Rtyp, Loc)),
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Bit_Not), Loc),
Parameter_Associations => New_List (
-
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => Opnd),
+ Prefix => Opnd,
+ Attribute_Name => Name_Address),
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of
(Etype (First_Index (Rtyp)), Loc),
Attribute_Name => Name_Range_Length),
+
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Rtyp))),
Make_Byte_Aligned_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => New_Occurrence_Of (Result_Ent, Loc))))));
+ Prefix => New_Occurrence_Of (Result_Ent, Loc),
+ Attribute_Name => Name_Address)))));
- Rewrite (N,
- New_Occurrence_Of (Result_Ent, Loc));
+ Rewrite (N, New_Occurrence_Of (Result_Ent, Loc));
end;
end if;
Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
-
end Expand_Packed_Not;
+ -----------------------------
+ -- Get_Base_And_Bit_Offset --
+ -----------------------------
+
+ procedure Get_Base_And_Bit_Offset
+ (N : Node_Id;
+ Base : out Node_Id;
+ Offset : out Node_Id)
+ is
+ Loc : Source_Ptr;
+ Term : Node_Id;
+ Atyp : Entity_Id;
+ Subscr : Node_Id;
+
+ begin
+ Base := N;
+ Offset := Empty;
+
+ -- We build up an expression serially that has the form
+
+ -- linear-subscript * component_size for each array reference
+ -- + field'Bit_Position for each record field
+ -- + ...
+
+ loop
+ Loc := Sloc (Base);
+
+ if Nkind (Base) = N_Indexed_Component then
+ Convert_To_Actual_Subtype (Prefix (Base));
+ Atyp := Etype (Prefix (Base));
+ Compute_Linear_Subscript (Atyp, Base, Subscr);
+
+ Term :=
+ Make_Op_Multiply (Loc,
+ Left_Opnd => Subscr,
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Atyp, Loc),
+ Attribute_Name => Name_Component_Size));
+
+ elsif Nkind (Base) = N_Selected_Component then
+ Term :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Selector_Name (Base),
+ Attribute_Name => Name_Bit_Position);
+
+ else
+ return;
+ end if;
+
+ if No (Offset) then
+ Offset := Term;
+
+ else
+ Offset :=
+ Make_Op_Add (Loc,
+ Left_Opnd => Offset,
+ Right_Opnd => Term);
+ end if;
+
+ Base := Prefix (Base);
+ end loop;
+ end Get_Base_And_Bit_Offset;
+
-------------------------------------
-- Involves_Packed_Array_Reference --
-------------------------------------
Source_Siz := UI_To_Int (RM_Size (Source_Typ));
Target_Siz := UI_To_Int (RM_Size (Target_Typ));
- -- First step, if the source type is not a discrete type, then we
- -- first convert to a modular type of the source length, since
- -- otherwise, on a big-endian machine, we get left-justification.
- -- We do it for little-endian machines as well, because there might
- -- be junk bits that are not cleared if the type is not numeric.
+ -- For a little-endian target type stored byte-swapped on a
+ -- big-endian machine, do not mask to Target_Siz bits.
- if Source_Siz /= Target_Siz
- and then not Is_Discrete_Type (Source_Typ)
+ if Bytes_Big_Endian
+ and then (Is_Record_Type (Target_Typ)
+ or else
+ Is_Array_Type (Target_Typ))
+ and then Reverse_Storage_Order (Target_Typ)
+ then
+ Source_Siz := Target_Siz;
+ end if;
+
+ -- First step, if the source type is not a discrete type, then we first
+ -- convert to a modular type of the source length, since otherwise, on
+ -- a big-endian machine, we get left-justification. We do it for little-
+ -- endian machines as well, because there might be junk bits that are
+ -- not cleared if the type is not numeric. This can be done only if the
+ -- source siz is different from 0 (i.e. known), otherwise we must trust
+ -- the type declarations (case of non-discrete components).
+
+ if Source_Siz /= 0
+ and then Source_Siz /= Target_Siz
+ and then not Is_Discrete_Type (Source_Typ)
then
Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src);
end if;
- -- In the big endian case, if the lengths of the two types differ,
- -- then we must worry about possible left justification in the
- -- conversion, and avoiding that is what this is all about.
+ -- In the big endian case, if the lengths of the two types differ, then
+ -- we must worry about possible left justification in the conversion,
+ -- and avoiding that is what this is all about.
if Bytes_Big_Endian and then Source_Siz /= Target_Siz then
-- Next step. If the target is not a discrete type, then we first
- -- convert to a modular type of the target length, since
- -- otherwise, on a big-endian machine, we get left-justification.
+ -- convert to a modular type of the target length, since otherwise,
+ -- on a big-endian machine, we get left-justification.
if not Is_Discrete_Type (Target_Typ) then
Src := Unchecked_Convert_To (RTE (Bits_Id (Target_Siz)), Src);
-- Setup_Enumeration_Packed_Array_Reference --
----------------------------------------------
- -- All we have to do here is to find the subscripts that correspond
- -- to the index positions that have non-standard enumeration types
- -- and insert a Pos attribute to get the proper subscript value.
+ -- All we have to do here is to find the subscripts that correspond to the
+ -- index positions that have non-standard enumeration types and insert a
+ -- Pos attribute to get the proper subscript value.
- -- Finally the prefix must be uncheck converted to the corresponding
- -- packed array type.
+ -- Finally the prefix must be uncheck-converted to the corresponding packed
+ -- array type.
- -- Note that the component type is unchanged, so we do not need to
- -- fiddle with the types (Gigi always automatically takes the packed
- -- array type if it is set, as it will be in this case).
+ -- Note that the component type is unchanged, so we do not need to fiddle
+ -- with the types (Gigi always automatically takes the packed array type if
+ -- it is set, as it will be in this case).
procedure Setup_Enumeration_Packed_Array_Reference (N : Node_Id) is
Pfx : constant Node_Id := Prefix (N);
Expr : Node_Id;
begin
- -- If the array is unconstrained, then we replace the array
- -- reference with its actual subtype. This actual subtype will
- -- have a packed array type with appropriate bounds.
+ -- If the array is unconstrained, then we replace the array reference
+ -- with its actual subtype. This actual subtype will have a packed array
+ -- type with appropriate bounds.
- if not Is_Constrained (Packed_Array_Type (Etype (Pfx))) then
+ if not Is_Constrained (Packed_Array_Impl_Type (Etype (Pfx))) then
Convert_To_Actual_Subtype (Pfx);
end if;
Rewrite (N,
Make_Indexed_Component (Sloc (N),
Prefix =>
- Unchecked_Convert_To (Packed_Array_Type (Etype (Pfx)), Pfx),
+ Unchecked_Convert_To (Packed_Array_Impl_Type (Etype (Pfx)), Pfx),
Expressions => Exprs));
Analyze_And_Resolve (N, Typ);
-
end Setup_Enumeration_Packed_Array_Reference;
-----------------------------------------
Cmask : out Uint;
Shift : out Node_Id)
is
- Loc : constant Source_Ptr := Sloc (N);
- PAT : Entity_Id;
- Otyp : Entity_Id;
- Csiz : Uint;
- Osiz : Uint;
+ Loc : constant Source_Ptr := Sloc (N);
+ PAT : Entity_Id;
+ Otyp : Entity_Id;
+ Csiz : Uint;
+ Osiz : Uint;
begin
Csiz := Component_Size (Atyp);
Compute_Linear_Subscript (Atyp, N, Shift);
- -- If the component size is not 1, then the subscript must be
- -- multiplied by the component size to get the shift count.
+ -- If the component size is not 1, then the subscript must be multiplied
+ -- by the component size to get the shift count.
if Csiz /= 1 then
Shift :=
Make_Op_Multiply (Loc,
- Left_Opnd => Make_Integer_Literal (Loc, Csiz),
+ Left_Opnd => Make_Integer_Literal (Loc, Csiz),
Right_Opnd => Shift);
end if;
- -- If we have the array case, then this shift count must be broken
- -- down into a byte subscript, and a shift within the byte.
+ -- If we have the array case, then this shift count must be broken down
+ -- into a byte subscript, and a shift within the byte.
if Is_Array_Type (PAT) then
Prefix => Obj,
Expressions => New_List (
Make_Op_Divide (Loc,
- Left_Opnd => Duplicate_Subexpr (Shift),
+ Left_Opnd => Duplicate_Subexpr (Shift),
Right_Opnd => Make_Integer_Literal (Loc, Osiz))));
Shift := New_Shift;
end;
- -- For the modular integer case, the object to be manipulated is
- -- the entire array, so Obj is unchanged. Note that we will reset
- -- its type to PAT before returning to the caller.
+ -- For the modular integer case, the object to be manipulated is the
+ -- entire array, so Obj is unchanged. Note that we will reset its type
+ -- to PAT before returning to the caller.
else
null;
-- Here we have the case of 2-bit fields
- -- For the little-endian case, we already have the proper shift
- -- count set, e.g. for element 2, the shift count is 2*2 = 4.
+ -- For the little-endian case, we already have the proper shift count
+ -- set, e.g. for element 2, the shift count is 2*2 = 4.
+
+ -- For the big endian case, we have to adjust the shift count, computing
+ -- it as (N - F) - Shift, where N is the number of bits in an element of
+ -- the array used to implement the packed array, F is the number of bits
+ -- in a source array element, and Shift is the count so far computed.
- -- For the big endian case, we have to adjust the shift count,
- -- computing it as (N - F) - shift, where N is the number of bits
- -- in an element of the array used to implement the packed array,
- -- F is the number of bits in a source level array element, and
- -- shift is the count so far computed.
+ -- We also have to adjust if the storage order is reversed
- if Bytes_Big_Endian then
+ if Bytes_Big_Endian xor Reverse_Storage_Order (Base_Type (Atyp)) then
Shift :=
Make_Op_Subtract (Loc,
Left_Opnd => Make_Integer_Literal (Loc, Osiz - Csiz),
projects / thirdparty / gcc.git / blobdiff