-- --
-- B o d y --
-- --
--- $Revision: 1.125 $
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
+with Errout; use Errout;
with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util;
+with Layout; use Layout;
+with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
-with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
-- 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 : E_Array :=
+ Set_Id : constant E_Array :=
(01 => RE_Null,
02 => RE_Null,
03 => RE_Set_03,
-- 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 : E_Array :=
+ SetU_Id : constant E_Array :=
(01 => RE_Null,
02 => RE_Null,
03 => RE_Set_03,
-- expression whose type is the implementation type used to represent
-- the packed array. Aexp is analyzed and resolved on entry and on exit.
+ 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
+ -- bits, and the ones used when the object is not known to be aligned.
+ -- This routine is used to determine which set to use. Obj is a reference
+ -- to the object, and Csiz is the component size of the packed array.
+ -- True is returned if the alignment of object is known to be sufficient,
+ -- defined as 1 for odd bit sizes, 4 for bit sizes divisible by 4, and
+ -- 2 otherwise.
+
function Make_Shift_Left (N : Node_Id; S : Node_Id) return Node_Id;
-- Build a left shift node, checking for the case of a shift count of zero
function RJ_Unchecked_Convert_To
(Typ : Entity_Id;
- Expr : Node_Id)
- return Node_Id;
+ 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
-- On return:
--
-- Obj is the object containing the desired bit field. It is of type
- -- Unsigned or Long_Long_Unsigned, and is either the entire value,
- -- for the small static case, or the proper selected byte from the
- -- array in the large or dynamic case. This node is analyzed and
- -- resolved on return.
+ -- Unsigned, Long_Unsigned, or Long_Long_Unsigned, and is either the
+ -- entire value, for the small static case, or the proper selected byte
+ -- from the array in the large or dynamic case. This node is analyzed
+ -- and resolved on return.
--
-- Shift is a node representing the shift count to be used in the
-- rotate right instruction that positions the field for access.
Right_Opnd =>
Convert_To (Standard_Integer,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Styp, Loc),
+ Prefix => New_Occurrence_Of (Styp, Loc),
Attribute_Name => Name_First)));
-- For larger integer types, subtract first, then convert to
Left_Opnd => Newsub,
Right_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Styp, Loc),
+ Prefix => New_Occurrence_Of (Styp, Loc),
Attribute_Name => Name_First)));
end if;
Make_Op_Subtract (Loc,
Left_Opnd => Convert_To (Standard_Integer,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Styp, Loc),
+ Prefix => New_Occurrence_Of (Styp, Loc),
Attribute_Name => Name_Pos,
- Expressions => New_List (Newsub))),
+ Expressions => New_List (Newsub))),
Right_Opnd =>
Convert_To (Standard_Integer,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Styp, Loc),
+ Prefix => New_Occurrence_Of (Styp, Loc),
Attribute_Name => Name_Pos,
- Expressions => New_List (
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Styp, Loc),
+ Prefix => New_Occurrence_Of (Styp, Loc),
Attribute_Name => Name_First)))));
end if;
-- The PAT is always obtained from the actual subtype
- procedure Convert_To_PAT_Type (Aexp : Entity_Id) is
+ procedure Convert_To_PAT_Type (Aexp : Node_Id) is
Act_ST : Entity_Id;
begin
Act_ST := Underlying_Type (Etype (Aexp));
Create_Packed_Array_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 two types equivalent in any case.
+ -- Just replace the etype with the packed array type. This works because
+ -- the expression will not be further analyzed, and Gigi considers the
+ -- two types equivalent in any case.
+
+ -- This is not strictly the case ??? If the reference is an actual in
+ -- call, the expansion of the prefix is delayed, and must be reanalyzed,
+ -- 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.
Set_Etype (Aexp, Packed_Array_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
+ then
+ Set_Analyzed (Aexp);
+ end if;
end Convert_To_PAT_Type;
------------------------------
Ancest : Entity_Id;
PB_Type : Entity_Id;
- Esiz : Uint;
+ PASize : Uint;
Decl : Node_Id;
PAT : Entity_Id;
Len_Dim : Node_Id;
end if;
if Scope (Typ) /= Current_Scope then
- New_Scope (Scope (Typ));
+ Push_Scope (Scope (Typ));
Pushed_Scope := True;
end if;
Set_Is_Itype (PAT, True);
- Set_Is_Packed_Array_Type (PAT, True);
+ Set_Packed_Array_Type (Typ, PAT);
Analyze (Decl, Suppress => All_Checks);
if Pushed_Scope then
end if;
-- Set Esize and RM_Size to the actual size of the packed object
- -- Do not reset RM_Size if already set, as happens in the case
- -- of a modular type
+ -- Do not reset RM_Size if already set, as happens in the case of
+ -- a modular type.
- Set_Esize (PAT, Esiz);
+ if Unknown_Esize (PAT) then
+ Set_Esize (PAT, PASize);
+ end if;
if Unknown_RM_Size (PAT) then
- Set_RM_Size (PAT, Esiz);
+ Set_RM_Size (PAT, PASize);
end if;
+ Adjust_Esize_Alignment (PAT);
+
-- Set remaining fields of packed array type
- Init_Alignment (PAT);
- Set_Parent (PAT, Empty);
- Set_Packed_Array_Type (Typ, PAT);
+ 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);
-- We definitely do not want to delay freezing for packed array
-- types. This is of particular importance for the itypes that
Set_Has_Delayed_Freeze (PAT, False);
Set_Has_Delayed_Freeze (Etype (PAT), False);
+
+ -- If we did allocate a freeze node, then clear out the reference
+ -- since it is obsolete (should we delete the freeze node???)
+
+ Set_Freeze_Node (PAT, Empty);
+ Set_Freeze_Node (Etype (PAT), Empty);
end Install_PAT;
-----------------
procedure Set_PB_Type is
begin
-- If the user has specified an explicit alignment for the
- -- component, take it into account.
+ -- type or component, take it into account.
if Csize <= 2 or else Csize = 4 or else Csize mod 2 /= 0
+ or else Alignment (Typ) = 1
or else Component_Alignment (Typ) = Calign_Storage_Unit
then
PB_Type := RTE (RE_Packed_Bytes1);
- elsif Csize mod 4 /= 0 then
+ elsif Csize mod 4 /= 0
+ or else Alignment (Typ) = 2
+ then
PB_Type := RTE (RE_Packed_Bytes2);
else
-- If our immediate ancestor subtype is constrained, and it already
-- has a packed array type, then just share the same type, since the
- -- bounds must be the same.
+ -- bounds must be the same. If the ancestor is not an array type but
+ -- a private type, as can happen with multiple instantiations, create
+ -- a new packed type, to avoid privacy issues.
if Ekind (Typ) = E_Array_Subtype then
Ancest := Ancestor_Subtype (Typ);
if Present (Ancest)
+ and then Is_Array_Type (Ancest)
and then Is_Constrained (Ancest)
and then Present (Packed_Array_Type (Ancest))
then
-- type, since this size clearly belongs to the packed array type. The
-- size of the conceptual unpacked type is always set to unknown.
- Esiz := Esize (Typ);
+ PASize := RM_Size (Typ);
-- Case of an array where at least one index is of an enumeration
-- type with a non-standard representation, but the component size
Set_Packed_Array_Type (Typ, PAT);
declare
- Indexes : List_Id := New_List;
+ Indexes : constant List_Id := New_List;
Indx : Node_Id;
Indx_Typ : Entity_Id;
Enum_Case : Boolean;
Typedef :=
Make_Unconstrained_Array_Definition (Loc,
Subtype_Marks => Indexes,
- Subtype_Indication =>
- New_Occurrence_Of (Ctyp, Loc));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (Ctyp, Loc)));
else
Typedef :=
Make_Constrained_Array_Definition (Loc,
Discrete_Subtype_Definitions => Indexes,
- Subtype_Indication =>
- New_Occurrence_Of (Ctyp, Loc));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (Ctyp, Loc)));
end if;
Decl :=
Type_Definition => Typedef);
end;
+ -- Set type as packed array type and install it
+
+ Set_Is_Packed_Array_Type (PAT);
Install_PAT;
return;
- -- Case of bit-packing required for unconstrained array. We simply
- -- use Packed_Bytes{1,2,4} as appropriate, and we do not need to
- -- construct a special packed array type.
+ -- Case of bit-packing required for unconstrained array. We create
+ -- a subtype that is equivalent to use Packed_Bytes{1,2,4} as needed.
elsif not Is_Constrained (Typ) then
+ PAT :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_Packed_Array_Type_Name (Typ, Csize));
+
+ Set_Packed_Array_Type (Typ, PAT);
Set_PB_Type;
- Set_Packed_Array_Type (Typ, PB_Type);
- Set_Is_Packed_Array_Type (Packed_Array_Type (Typ), True);
+
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => PAT,
+ Subtype_Indication => New_Occurrence_Of (PB_Type, Loc));
+ Install_PAT;
return;
-- Remaining code is for the case of bit-packing for constrained array
-- Temporarily attach the length expression to the tree and analyze
-- and resolve it, so that we can test its value. We assume that the
- -- total length fits in type Integer.
+ -- total length fits in type Integer. This expression may involve
+ -- discriminants, so we treat it as a default/per-object expression.
Set_Parent (Len_Expr, Typ);
- Analyze_And_Resolve (Len_Expr, Standard_Integer);
+ Analyze_Per_Use_Expression (Len_Expr, Standard_Long_Long_Integer);
- -- Use a modular type if possible. We can do this if we are we
- -- have static bounds, and the length is small enough, and the
- -- length is not zero. We exclude the zero length case because the
- -- size of things is always at least one, and the zero length object
- -- would have an anomous size
+ -- Use a modular type if possible. We can do this if we have
+ -- static bounds, and the length is small enough, and the length
+ -- is not zero. We exclude the zero length case because the size
+ -- of things is always at least one, and the zero length object
+ -- would have an anomalous size.
if Compile_Time_Known_Value (Len_Expr) then
Len_Bits := Expr_Value (Len_Expr) * Csize;
+ -- Check for size known to be too large
+
+ if Len_Bits >
+ Uint_2 ** (Standard_Integer_Size - 1) * System_Storage_Unit
+ then
+ if System_Storage_Unit = 8 then
+ Error_Msg_N
+ ("packed array size cannot exceed " &
+ "Integer''Last bytes", Typ);
+ else
+ Error_Msg_N
+ ("packed array size cannot exceed " &
+ "Integer''Last storage units", Typ);
+ end if;
+
+ -- Reset length to arbitrary not too high value to continue
+
+ Len_Expr := Make_Integer_Literal (Loc, 65535);
+ Analyze_And_Resolve (Len_Expr, Standard_Long_Long_Integer);
+ end if;
+
-- We normally consider small enough to mean no larger than the
- -- value of System_Max_Binary_Modulus_Power, except that in
- -- No_Run_Time mode, we use the Word Size on machines for
- -- which double length shifts are not generated in line.
+ -- value of System_Max_Binary_Modulus_Power, checking that in the
+ -- case of values longer than word size, we have long shifts.
if Len_Bits > 0
and then
(Len_Bits <= System_Word_Size
or else (Len_Bits <= System_Max_Binary_Modulus_Power
- and then (not No_Run_Time
- or else
- Long_Shifts_Inlined_On_Target)))
+ 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:
-- subtype tttPn is btyp
- -- range 0 .. 2 ** (Esize (Typ) * Csize) - 1;
+ -- range 0 .. 2 ** ((Typ'Length (1)
+ -- * ... * Typ'Length (n)) * Csize) - 1;
+
+ -- The bounds are statically known, and btyp is one of the
+ -- unsigned types, depending on the length.
+
+ if Len_Bits <= Standard_Short_Short_Integer_Size then
+ Btyp := RTE (RE_Short_Short_Unsigned);
- -- Here Siz is 1, 2 or 4, as computed above, and btyp is either
- -- Unsigned or Long_Long_Unsigned depending on the length.
+ elsif Len_Bits <= Standard_Short_Integer_Size then
+ Btyp := RTE (RE_Short_Unsigned);
- if Len_Bits <= Standard_Integer_Size then
+ elsif Len_Bits <= Standard_Integer_Size then
Btyp := RTE (RE_Unsigned);
+
+ elsif Len_Bits <= Standard_Long_Integer_Size then
+ Btyp := RTE (RE_Long_Unsigned);
+
else
Btyp := RTE (RE_Long_Long_Unsigned);
end if;
Make_Integer_Literal (Loc, 0),
High_Bound => Lit))));
- if Esiz = Uint_0 then
- Esiz := Len_Bits;
+ if PASize = Uint_0 then
+ PASize := Len_Bits;
end if;
Install_PAT;
-- subtype tttPn is
-- System.Packed_Bytes{1,2,4} (0 .. (Bits + 7) / 8 - 1);
- -- Bits is the length of the array in bits.
+ -- Bits is the length of the array in bits
Set_PB_Type;
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (PB_Type, Loc),
Constraint =>
-
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Low_Bound =>
Make_Integer_Literal (Loc, 0),
- High_Bound => PAT_High)))));
+ High_Bound =>
+ Convert_To (Standard_Integer, PAT_High))))));
Install_PAT;
+
+ -- Currently the code in this unit requires that packed arrays
+ -- represented by non-modular arrays of bytes be on a byte
+ -- boundary for bit sizes handled by System.Pack_nn units.
+ -- That's because these units assume the array being accessed
+ -- starts on a byte boundary.
+
+ if Get_Id (UI_To_Int (Csize)) /= RE_Null then
+ Set_Must_Be_On_Byte_Boundary (Typ);
+ end if;
end if;
end Create_Packed_Array_Type;
PAT : Entity_Id;
Ctyp : Entity_Id;
Csiz : Int;
- Shift : Node_Id;
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
+
New_Lhs : Node_Id;
New_Rhs : Node_Id;
-- contains the value. Otherwise Rhs_Val_Known is set False, and
-- the Rhs_Val is undefined.
+ function Get_Shift return Node_Id;
+ -- Function used to get the value of Shift, making sure that it
+ -- gets duplicated if the function is called more than once.
+
+ ---------------
+ -- Get_Shift --
+ ---------------
+
+ function Get_Shift return Node_Id is
+ begin
+ -- If we used the shift value already, then duplicate it. We
+ -- set a temporary parent in case actions have to be inserted.
+
+ if Shift_Used then
+ Set_Parent (Shift, N);
+ return Duplicate_Subexpr_No_Checks (Shift);
+
+ -- If first time, use Shift unchanged, and set flag for first use
+
+ else
+ Shift_Used := True;
+ return Shift;
+ end if;
+ end Get_Shift;
+
+ -- Start of processing for Expand_Bit_Packed_Element_Set
+
begin
pragma Assert (Is_Bit_Packed_Array (Etype (Prefix (Lhs))));
-- conversion is analyzed immediately so that subsequent processing
-- can work with an analyzed Rhs (and e.g. look at its Etype)
+ -- If the right-hand side is a string literal, create a temporary for
+ -- it, constant-folding is not ready to wrap the bit representation
+ -- of a string literal.
+
+ if Nkind (Rhs) = N_String_Literal then
+ declare
+ Decl : Node_Id;
+ 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));
+
+ Insert_Actions (N, New_List (Decl));
+ Rhs := New_Occurrence_Of (Defining_Identifier (Decl), Loc);
+ end;
+ end if;
+
Rhs := Convert_To (Ctyp, Rhs);
Set_Parent (Rhs, N);
Analyze_And_Resolve (Rhs, Ctyp);
-- the "or ..." is omitted if rhs is constant and all 0 bits
- -- rhs is converted to the appropriate type.
+ -- rhs is converted to the appropriate type
-- The result is converted back to the array type, since
-- otherwise we lose knowledge of the packed nature.
end if;
New_Lhs := Duplicate_Subexpr (Obj, True);
- New_Rhs := Duplicate_Subexpr (Obj);
+ New_Rhs := Duplicate_Subexpr_No_Checks (Obj);
-- First we deal with the "and"
Mask1 :=
Make_Integer_Literal (Loc,
Modulus (Etype (Obj)) - 1 -
- (Cmask * (2 ** Expr_Value (Shift))));
+ (Cmask * (2 ** Expr_Value (Get_Shift))));
Set_Print_In_Hex (Mask1);
else
Set_Print_In_Hex (Lit);
Mask1 :=
Make_Op_Not (Loc,
- Right_Opnd => Make_Shift_Left (Lit, Shift));
+ Right_Opnd => Make_Shift_Left (Lit, Get_Shift));
end if;
New_Rhs :=
begin
if Rhs_Val_Known
- and then Compile_Time_Known_Value (Shift)
+ and then Compile_Time_Known_Value (Get_Shift)
then
Or_Rhs :=
Make_Integer_Literal (Loc,
- Rhs_Val * (2 ** Expr_Value (Shift)));
+ Rhs_Val * (2 ** Expr_Value (Get_Shift)));
Set_Print_In_Hex (Or_Rhs);
else
Fixup_Rhs;
end if;
- Or_Rhs := Make_Shift_Left (Rhs, Shift);
+ Or_Rhs := Make_Shift_Left (Rhs, Get_Shift);
end if;
if Nkind (New_Rhs) = N_Op_And then
-- Set_nn (Arr'address, Subscr, Bits_nn!(Rhs))
- -- where Subscr is the computed linear subscript.
+ -- where Subscr is the computed linear subscript
declare
Bits_nn : constant Entity_Id := RTE (Bits_Id (Csiz));
Atyp : Entity_Id;
begin
+ if No (Bits_nn) then
+
+ -- Error, most likely High_Integrity_Mode restriction
+
+ return;
+ end if;
+
-- Acquire proper Set entity. We use the aligned or unaligned
-- case as appropriate.
- if Must_Be_Aligned (Obj) then
+ if Known_Aligned_Enough (Obj, Csiz) then
Set_nn := RTE (Set_Id (Csiz));
else
Set_nn := RTE (SetU_Id (Csiz));
Atyp := Etype (Obj);
Compute_Linear_Subscript (Atyp, Lhs, Subscr);
+ -- 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
+ -- only arrays that can be misaligned are small packed
+ -- arrays which are implemented as a modular type, and
+ -- that is not the case here.
+
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Set_nn, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
- Prefix => Obj),
+ Prefix => Obj),
Subscr,
Unchecked_Convert_To (Bits_nn,
Convert_To (Ctyp, Rhs)))));
Left_Opnd => Subscr,
Right_Opnd =>
Make_Attribute_Reference (Ploc,
- Prefix => New_Occurrence_Of (Atyp, 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),
+ Prefix => Selector_Name (Pref),
Attribute_Name => Name_Bit_Position);
else
Left_Opnd =>
Unchecked_Convert_To (RTE (RE_Integer_Address),
Make_Attribute_Reference (Loc,
- Prefix => Pref,
+ Prefix => Pref,
Attribute_Name => Name_Address)),
Right_Opnd =>
Right_Opnd =>
Convert_To (BT,
- New_Occurrence_Of (Standard_True, Loc))))));
+ New_Occurrence_Of (Standard_True, Loc)))),
+ Reason => CE_Range_Check_Failed));
end;
end if;
-- convert to the base type, since this would be unconstrained, and
-- hence not have a corresponding packed array type set.
- if Is_Modular_Integer_Type (PAT) then
+ -- Note that both operands must be modular for this code to be used
+
+ if Is_Modular_Integer_Type (PAT)
+ and then
+ Is_Modular_Integer_Type (Etype (R))
+ then
declare
P : Node_Id;
P := Make_Op_Xor (Loc, L, R);
end if;
- Rewrite (N, Unchecked_Convert_To (Rtyp, P));
+ Rewrite (N, Unchecked_Convert_To (Ltyp, P));
end;
-- For the array case, we insert the actions
-- operands in bits. Then we replace the expression by a reference
-- to Result.
+ -- Note that if we are mixing a modular and array operand, everything
+ -- works fine, since we ensure that the modular representation has the
+ -- same physical layout as the array representation (that's what the
+ -- left justified modular stuff in the big-endian case is about).
+
else
declare
Result_Ent : constant Entity_Id :=
Name => New_Occurrence_Of (RTE (E_Id), Loc),
Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
+ Make_Byte_Aligned_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
- Prefix => L),
+ Prefix => L),
Make_Op_Multiply (Loc,
Left_Opnd =>
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Ltyp))),
- Make_Attribute_Reference (Loc,
+ Make_Byte_Aligned_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
- Prefix => R),
+ Prefix => R),
Make_Op_Multiply (Loc,
Left_Opnd =>
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Rtyp))),
- Make_Attribute_Reference (Loc,
+ Make_Byte_Aligned_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
Prefix => New_Occurrence_Of (Result_Ent, Loc))))));
return;
end if;
- -- Remaining processing is for the bit-packed case.
+ -- Remaining processing is for the bit-packed case
Obj := Relocate_Node (Prefix (N));
Convert_To_Actual_Subtype (Obj);
Left_Opnd => Make_Shift_Right (Obj, Shift),
Right_Opnd => Lit);
+ -- We neded 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,
-- Component_Type!(Get_nn (Arr'address, Subscr))
- -- where Subscr is the computed linear subscript.
+ -- where Subscr is the computed linear subscript
declare
Get_nn : Entity_Id;
-- Acquire proper Get entity. We use the aligned or unaligned
-- case as appropriate.
- if Must_Be_Aligned (Obj) then
+ if Known_Aligned_Enough (Obj, Csiz) then
Get_nn := RTE (Get_Id (Csiz));
else
Get_nn := RTE (GetU_Id (Csiz));
Compute_Linear_Subscript (Atyp, N, Subscr);
+ -- Below we make the assumption that Obj is at least byte
+ -- aligned, since otherwise its address cannot be taken.
+ -- The assumption holds since the only arrays that can be
+ -- misaligned are small packed arrays which are implemented
+ -- as a modular type, and that is not the case here.
+
Rewrite (N,
Unchecked_Convert_To (Ctyp,
Make_Function_Call (Loc,
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
- Prefix => Obj),
+ Prefix => Obj),
Subscr))));
end;
end if;
Left_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Length,
- Prefix => New_Occurrence_Of (Ltyp, Loc)),
+ Prefix => New_Occurrence_Of (Ltyp, Loc)),
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Ltyp)));
Left_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Length,
- Prefix => New_Occurrence_Of (Rtyp, Loc)),
+ Prefix => New_Occurrence_Of (Rtyp, Loc)),
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Rtyp)));
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Bit_Eq), Loc),
Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
+ Make_Byte_Aligned_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
- Prefix => L),
+ Prefix => L),
LLexpr,
- Make_Attribute_Reference (Loc,
+ Make_Byte_Aligned_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
- Prefix => R),
+ Prefix => R),
RLexpr)));
end if;
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
- Attribute_Name => Name_Last))));
+ Attribute_Name => Name_Last)),
+ Reason => CE_Range_Check_Failed));
end;
-- Now that that silliness is taken care of, get packed array type
-- one bits of length equal to the size of this packed type and
-- rtyp is the actual subtype of the operand
- Lit := Make_Integer_Literal (Loc, 2 ** Esize (PAT) - 1);
+ Lit := Make_Integer_Literal (Loc, 2 ** RM_Size (PAT) - 1);
Set_Print_In_Hex (Lit);
if not Is_Array_Type (PAT) then
Name => New_Occurrence_Of (RTE (RE_Bit_Not), Loc),
Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
+ Make_Byte_Aligned_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
- Prefix => Opnd),
+ Prefix => Opnd),
Make_Op_Multiply (Loc,
Left_Opnd =>
Right_Opnd =>
Make_Integer_Literal (Loc, Component_Size (Rtyp))),
- Make_Attribute_Reference (Loc,
+ Make_Byte_Aligned_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
Prefix => New_Occurrence_Of (Result_Ent, Loc))))));
end if;
end Involves_Packed_Array_Reference;
+ --------------------------
+ -- Known_Aligned_Enough --
+ --------------------------
+
+ function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean is
+ Typ : constant Entity_Id := Etype (Obj);
+
+ function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean;
+ -- If the component is in a record that contains previous packed
+ -- components, consider it unaligned because the back-end might
+ -- choose to pack the rest of the record. Lead to less efficient code,
+ -- but safer vis-a-vis of back-end choices.
+
+ --------------------------------
+ -- In_Partially_Packed_Record --
+ --------------------------------
+
+ function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean is
+ Rec_Type : constant Entity_Id := Scope (Comp);
+ Prev_Comp : Entity_Id;
+
+ begin
+ Prev_Comp := First_Entity (Rec_Type);
+ while Present (Prev_Comp) loop
+ if Is_Packed (Etype (Prev_Comp)) then
+ return True;
+
+ elsif Prev_Comp = Comp then
+ return False;
+ end if;
+
+ Next_Entity (Prev_Comp);
+ end loop;
+
+ return False;
+ end In_Partially_Packed_Record;
+
+ -- Start of processing for Known_Aligned_Enough
+
+ begin
+ -- Odd bit sizes don't need alignment anyway
+
+ if Csiz mod 2 = 1 then
+ return True;
+
+ -- If we have a specified alignment, see if it is sufficient, if not
+ -- then we can't possibly be aligned enough in any case.
+
+ elsif Known_Alignment (Etype (Obj)) then
+ -- Alignment required is 4 if size is a multiple of 4, and
+ -- 2 otherwise (e.g. 12 bits requires 4, 10 bits requires 2)
+
+ if Alignment (Etype (Obj)) < 4 - (Csiz mod 4) then
+ return False;
+ end if;
+ end if;
+
+ -- OK, alignment should be sufficient, if object is aligned
+
+ -- If object is strictly aligned, then it is definitely aligned
+
+ if Strict_Alignment (Typ) then
+ return True;
+
+ -- Case of subscripted array reference
+
+ elsif Nkind (Obj) = N_Indexed_Component then
+
+ -- If we have a pointer to an array, then this is definitely
+ -- aligned, because pointers always point to aligned versions.
+
+ if Is_Access_Type (Etype (Prefix (Obj))) then
+ return True;
+
+ -- Otherwise, go look at the prefix
+
+ else
+ return Known_Aligned_Enough (Prefix (Obj), Csiz);
+ end if;
+
+ -- Case of record field
+
+ elsif Nkind (Obj) = N_Selected_Component then
+
+ -- What is significant here is whether the record type is packed
+
+ if Is_Record_Type (Etype (Prefix (Obj)))
+ and then Is_Packed (Etype (Prefix (Obj)))
+ then
+ return False;
+
+ -- Or the component has a component clause which might cause
+ -- the component to become unaligned (we can't tell if the
+ -- backend is doing alignment computations).
+
+ elsif Present (Component_Clause (Entity (Selector_Name (Obj)))) then
+ return False;
+
+ elsif In_Partially_Packed_Record (Entity (Selector_Name (Obj))) then
+ return False;
+
+ -- In all other cases, go look at prefix
+
+ else
+ return Known_Aligned_Enough (Prefix (Obj), Csiz);
+ end if;
+
+ elsif Nkind (Obj) = N_Type_Conversion then
+ return Known_Aligned_Enough (Expression (Obj), Csiz);
+
+ -- For a formal parameter, it is safer to assume that it is not
+ -- aligned, because the formal may be unconstrained while the actual
+ -- is constrained. In this situation, a small constrained packed
+ -- array, represented in modular form, may be unaligned.
+
+ elsif Is_Entity_Name (Obj) then
+ return not Is_Formal (Entity (Obj));
+ else
+
+ -- If none of the above, must be aligned
+ return True;
+ end if;
+ end Known_Aligned_Enough;
+
---------------------
-- Make_Shift_Left --
---------------------
function RJ_Unchecked_Convert_To
(Typ : Entity_Id;
- Expr : Node_Id)
- return Node_Id
+ Expr : Node_Id) return Node_Id
is
Source_Typ : constant Entity_Id := Etype (Expr);
Target_Typ : constant Entity_Id := Typ;
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.
+
+ if 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.
if Bytes_Big_Endian and then Source_Siz /= Target_Siz then
- -- 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.
-
- if not Is_Discrete_Type (Source_Typ) then
- Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src);
- end if;
-
-- 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.
-- 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.
then
Rewrite (Expr,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Expr_Typ, Loc),
+ Prefix => New_Occurrence_Of (Expr_Typ, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (Relocate_Node (Expr))));
Analyze_And_Resolve (Expr, Standard_Natural);
Shift : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (N);
- Ctyp : Entity_Id;
PAT : Entity_Id;
Otyp : Entity_Id;
Csiz : Uint;
Osiz : Uint;
begin
- Ctyp := Component_Type (Atyp);
Csiz := Component_Size (Atyp);
Convert_To_PAT_Type (Obj);
- PAT := Etype (Obj);
+ PAT := Etype (Obj);
Cmask := 2 ** Csiz - 1;
if Is_Array_Type (PAT) then
Otyp := Component_Type (PAT);
- Osiz := Esize (Otyp);
+ Osiz := Component_Size (PAT);
else
Otyp := PAT;
OSDN Git Service
