-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
with Opt; use Opt;
with Rtsfind; use Rtsfind;
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;
-- directly using Insert_Action.
------------------------------
- -- Compute_Linear_Subcsript --
+ -- Compute_Linear_Subscript --
------------------------------
procedure Compute_Linear_Subscript
-- 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;
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
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;
+ Silly_Boolean_Array_Xor_Test (N, Rtyp);
end if;
-- Now that that silliness is taken care of, get packed array type
-- Result : Ltype;
- -- System.Bitops.Bit_And/Or/Xor
+ -- System.Bit_Ops.Bit_And/Or/Xor
-- (Left'Address,
-- Ltype'Length * Ltype'Component_Size;
-- Right'Address,
Left_Opnd => Make_Shift_Right (Obj, Shift),
Right_Opnd => Lit);
- -- We neded to analyze this before we do the unchecked convert
+ -- 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).
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),
+ Silly_Boolean_Array_Not_Test (N, Rtyp);
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (CT, Loc),
- Attribute_Name => Name_Last)),
- Reason => CE_Range_Check_Failed));
- end;
-
- -- 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);
-- Result : Typ;
- -- System.Bitops.Bit_Not
+ -- System.Bit_Ops.Bit_Not
-- (Opnd'Address,
-- Typ'Length * Typ'Component_Size;
-- Result'Address);
OSDN Git Service
