-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, 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- --
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Ch2; use Exp_Ch2;
+with Exp_Ch11; use Exp_Ch11;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Elists; use Elists;
with Eval_Fat; use Eval_Fat;
with Freeze; use Freeze;
with Lib; use Lib;
+with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
end if;
end Accessibility_Checks_Suppressed;
+ -----------------------------
+ -- Activate_Division_Check --
+ -----------------------------
+
+ procedure Activate_Division_Check (N : Node_Id) is
+ begin
+ Set_Do_Division_Check (N, True);
+ Possible_Local_Raise (N, Standard_Constraint_Error);
+ end Activate_Division_Check;
+
+ -----------------------------
+ -- Activate_Overflow_Check --
+ -----------------------------
+
+ procedure Activate_Overflow_Check (N : Node_Id) is
+ begin
+ Set_Do_Overflow_Check (N, True);
+ Possible_Local_Raise (N, Standard_Constraint_Error);
+ end Activate_Overflow_Check;
+
+ --------------------------
+ -- Activate_Range_Check --
+ --------------------------
+
+ procedure Activate_Range_Check (N : Node_Id) is
+ begin
+ Set_Do_Range_Check (N, True);
+ Possible_Local_Raise (N, Standard_Constraint_Error);
+ end Activate_Range_Check;
+
---------------------------------
-- Alignment_Checks_Suppressed --
---------------------------------
else
-- If the original expression is a non-static constant, use the
-- name of the constant itself rather than duplicating its
- -- defining expression, which was extracted above..
+ -- defining expression, which was extracted above.
- if Is_Entity_Name (Expression (AC))
- and then Ekind (Entity (Expression (AC))) = E_Constant
- and then
- Nkind (Parent (Entity (Expression (AC)))) = N_Object_Declaration
+ -- Note: Expr is empty if the address-clause is applied to in-mode
+ -- actuals (allowed by 13.1(22)).
+
+ if not Present (Expr)
+ or else
+ (Is_Entity_Name (Expression (AC))
+ and then Ekind (Entity (Expression (AC))) = E_Constant
+ and then Nkind (Parent (Entity (Expression (AC))))
+ = N_Object_Declaration)
then
Expr := New_Copy_Tree (Expression (AC));
else
begin
-- Skip this if overflow checks are done in back end, or the overflow
-- flag is not set anyway, or we are not doing code expansion.
+ -- Special case CLI target, where arithmetic overflow checks can be
+ -- performed for integer and long_integer
if Backend_Overflow_Checks_On_Target
+ or else (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size)
or else not Do_Overflow_Check (N)
or else not Expander_Active
then
return;
end Apply_Arithmetic_Overflow_Check;
- ----------------------------
- -- Apply_Array_Size_Check --
- ----------------------------
-
- -- The situation is as follows. In GNAT 3 (GCC 2.x), the size in bits is
- -- computed in 32 bits without an overflow check. That's a real problem for
- -- Ada. So what we do in GNAT 3 is to approximate the size of an array by
- -- manually multiplying the element size by the number of elements, and
- -- comparing that against the allowed limits.
-
- -- In GNAT 5, the size in byte is still computed in 32 bits without an
- -- overflow check in the dynamic case, but the size in bits is computed in
- -- 64 bits. We assume that's good enough, and we do not bother to generate
- -- any front end test.
-
- procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Ctyp : constant Entity_Id := Component_Type (Typ);
- Ent : constant Entity_Id := Defining_Identifier (N);
- Decl : Node_Id;
- Lo : Node_Id;
- Hi : Node_Id;
- Lob : Uint;
- Hib : Uint;
- Siz : Uint;
- Xtyp : Entity_Id;
- Indx : Node_Id;
- Sizx : Node_Id;
- Code : Node_Id;
-
- Static : Boolean := True;
- -- Set false if any index subtye bound is non-static
-
- Umark : constant Uintp.Save_Mark := Uintp.Mark;
- -- We can throw away all the Uint computations here, since they are done
- -- only to generate boolean test results.
-
- Check_Siz : Uint;
- -- Size to check against
-
- function Is_Address_Or_Import (Decl : Node_Id) return Boolean;
- -- Determines if Decl is an address clause or Import/Interface pragma
- -- that references the defining identifier of the current declaration.
-
- --------------------------
- -- Is_Address_Or_Import --
- --------------------------
-
- function Is_Address_Or_Import (Decl : Node_Id) return Boolean is
- begin
- if Nkind (Decl) = N_At_Clause then
- return Chars (Identifier (Decl)) = Chars (Ent);
-
- elsif Nkind (Decl) = N_Attribute_Definition_Clause then
- return
- Chars (Decl) = Name_Address
- and then
- Nkind (Name (Decl)) = N_Identifier
- and then
- Chars (Name (Decl)) = Chars (Ent);
-
- elsif Nkind (Decl) = N_Pragma then
- if (Chars (Decl) = Name_Import
- or else
- Chars (Decl) = Name_Interface)
- and then Present (Pragma_Argument_Associations (Decl))
- then
- declare
- F : constant Node_Id :=
- First (Pragma_Argument_Associations (Decl));
- begin
- return
- Present (F)
- and then
- Present (Next (F))
- and then
- Nkind (Expression (Next (F))) = N_Identifier
- and then
- Chars (Expression (Next (F))) = Chars (Ent);
- end;
-
- else
- return False;
- end if;
-
- else
- return False;
- end if;
- end Is_Address_Or_Import;
-
- -- Start of processing for Apply_Array_Size_Check
-
- begin
- -- Do size check on local arrays. We only need this in the GCC 2 case,
- -- since in GCC 3, we expect the back end to properly handle things.
- -- This routine can be removed when we baseline GNAT 3.
-
- -- Shouldn't we remove GCC 2 crud at this stage ???
-
- if Opt.GCC_Version >= 3 then
- return;
- end if;
-
- -- No need for a check if not expanding
-
- if not Expander_Active then
- return;
- end if;
-
- -- No need for a check if checks are suppressed
-
- if Storage_Checks_Suppressed (Typ) then
- return;
- end if;
-
- -- It is pointless to insert this check inside an init proc, because
- -- that's too late, we have already built the object to be the right
- -- size, and if it's too large, too bad!
-
- if Inside_Init_Proc then
- return;
- end if;
-
- -- Look head for pragma interface/import or address clause applying to
- -- this entity. If found, we suppress the check entirely. For now we
- -- only look ahead 20 declarations to stop this becoming too slow Note
- -- that eventually this whole routine gets moved to gigi.
-
- Decl := N;
- for Ctr in 1 .. 20 loop
- Next (Decl);
- exit when No (Decl);
-
- if Is_Address_Or_Import (Decl) then
- return;
- end if;
- end loop;
-
- -- First step is to calculate the maximum number of elements. For this
- -- calculation, we use the actual size of the subtype if it is static,
- -- and if a bound of a subtype is non-static, we go to the bound of the
- -- base type.
-
- Siz := Uint_1;
- Indx := First_Index (Typ);
- while Present (Indx) loop
- Xtyp := Etype (Indx);
- Lo := Type_Low_Bound (Xtyp);
- Hi := Type_High_Bound (Xtyp);
-
- -- If any bound raises constraint error, we will never get this far,
- -- so there is no need to generate any kind of check.
-
- if Raises_Constraint_Error (Lo)
- or else
- Raises_Constraint_Error (Hi)
- then
- Uintp.Release (Umark);
- return;
- end if;
-
- -- Otherwise get bounds values
-
- if Is_Static_Expression (Lo) then
- Lob := Expr_Value (Lo);
- else
- Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
- Static := False;
- end if;
-
- if Is_Static_Expression (Hi) then
- Hib := Expr_Value (Hi);
- else
- Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
- Static := False;
- end if;
-
- Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0);
- Next_Index (Indx);
- end loop;
-
- -- Compute the limit against which we want to check. For subprograms,
- -- where the array will go on the stack, we use 8*2**24, which (in
- -- bits) is the size of a 16 megabyte array.
-
- if Is_Subprogram (Scope (Ent)) then
- Check_Siz := Uint_2 ** 27;
- else
- Check_Siz := Uint_2 ** 31;
- end if;
-
- -- If we have all static bounds and Siz is too large, then we know we
- -- have a storage error right now, so generate message
-
- if Static and then Siz >= Check_Siz then
- Insert_Action (N,
- Make_Raise_Storage_Error (Loc,
- Reason => SE_Object_Too_Large));
- Error_Msg_N ("?Storage_Error will be raised at run-time", N);
- Uintp.Release (Umark);
- return;
- end if;
-
- -- Case of component size known at compile time. If the array size is
- -- definitely in range, then we do not need a check.
-
- if Known_Esize (Ctyp)
- and then Siz * Esize (Ctyp) < Check_Siz
- then
- Uintp.Release (Umark);
- return;
- end if;
-
- -- Here if a dynamic check is required
-
- -- What we do is to build an expression for the size of the array, which
- -- is computed as the 'Size of the array component, times the size of
- -- each dimension.
-
- Uintp.Release (Umark);
-
- Sizx :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ctyp, Loc),
- Attribute_Name => Name_Size);
-
- Indx := First_Index (Typ);
- for J in 1 .. Number_Dimensions (Typ) loop
- if Sloc (Etype (Indx)) = Sloc (N) then
- Ensure_Defined (Etype (Indx), N);
- end if;
-
- Sizx :=
- Make_Op_Multiply (Loc,
- Left_Opnd => Sizx,
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Length,
- Expressions => New_List (
- Make_Integer_Literal (Loc, J))));
- Next_Index (Indx);
- end loop;
-
- -- Emit the check
-
- Code :=
- Make_Raise_Storage_Error (Loc,
- Condition =>
- Make_Op_Ge (Loc,
- Left_Opnd => Sizx,
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Intval => Check_Siz)),
- Reason => SE_Object_Too_Large);
-
- Set_Size_Check_Code (Defining_Identifier (N), Code);
- Insert_Action (N, Code, Suppress => All_Checks);
- end Apply_Array_Size_Check;
-
----------------------------
-- Apply_Constraint_Check --
----------------------------
-- No checks necessary if expression statically null
if Nkind (N) = N_Null then
- null;
+ if Can_Never_Be_Null (Typ) then
+ Install_Null_Excluding_Check (N);
+ end if;
-- No sliding possible on access to arrays
Apply_Discriminant_Check (N, Typ);
end if;
+ -- Apply the the 2005 Null_Excluding check. Note that we do not apply
+ -- this check if the constraint node is illegal, as shown by having
+ -- an error posted. This additional guard prevents cascaded errors
+ -- and compiler aborts on illegal programs involving Ada 2005 checks.
+
if Can_Never_Be_Null (Typ)
and then not Can_Never_Be_Null (Etype (N))
+ and then not Error_Posted (N)
then
Install_Null_Excluding_Check (N);
end if;
ItemS := Node (DconS);
ItemT := Node (DconT);
+ -- For a discriminated component type constrained by the
+ -- current instance of an enclosing type, there is no
+ -- applicable discriminant check.
+
+ if Nkind (ItemT) = N_Attribute_Reference
+ and then Is_Access_Type (Etype (ItemT))
+ and then Is_Entity_Name (Prefix (ItemT))
+ and then Is_Type (Entity (Prefix (ItemT)))
+ then
+ return;
+ end if;
+
exit when
not Is_OK_Static_Expression (ItemS)
or else
-- We do this by replacing the if statement by a null statement
elsif Do_Static or else not Checks_On then
+ Remove_Warning_Messages (R_Cno);
Rewrite (R_Cno, Make_Null_Statement (Loc));
end if;
else
Install_Static_Check (R_Cno, Loc);
end if;
-
end loop;
-
end Apply_Selected_Length_Checks;
---------------------------------
-- We do this by replacing the if statement by a null statement
elsif Do_Static or else not Checks_On then
+ Remove_Warning_Messages (R_Cno);
Rewrite (R_Cno, Make_Null_Statement (Loc));
end if;
and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
and then not Float_To_Int
then
- Set_Do_Overflow_Check (N);
+ Activate_Overflow_Check (N);
end if;
if not Range_Checks_Suppressed (Target_Type)
if not Is_Access_Type (Typ) then
Error_Msg_N
- ("null-exclusion must be applied to an access type",
- Error_Node);
+ ("`NOT NULL` allowed only for an access type", Error_Node);
-- Enforce legality rule RM 3.10(14/1): A null exclusion can only
-- be applied to a [sub]type that does not exclude null already.
and then not Is_Itype (Typ)
then
- Error_Msg_N
- ("null-exclusion cannot be applied to a null excluding type",
- Error_Node);
+ Error_Msg_NE
+ ("`NOT NULL` not allowed (& already excludes null)",
+ Error_Node, Typ);
end if;
end if;
w ("Enable_Overflow_Check for node ", Int (N));
Write_Str (" Source location = ");
wl (Sloc (N));
- pg (N);
+ pg (Union_Id (N));
end if;
-- Nothing to do if the range of the result is known OK. We skip this
or else not Is_Discrete_Type (Etype (N))
or else Num_Saved_Checks = Saved_Checks'Last
then
- Set_Do_Overflow_Check (N, True);
+ Activate_Overflow_Check (N);
if Debug_Flag_CC then
w ("Optimization off");
-- If check is not of form to optimize, then set flag and we are done
if not OK then
- Set_Do_Overflow_Check (N, True);
+ Activate_Overflow_Check (N);
return;
end if;
-- Here we will make a new entry for the new check
- Set_Do_Overflow_Check (N, True);
+ Activate_Overflow_Check (N);
Num_Saved_Checks := Num_Saved_Checks + 1;
Saved_Checks (Num_Saved_Checks) :=
(Killed => False,
exception
when others =>
- Set_Do_Overflow_Check (N, True);
+ Activate_Overflow_Check (N);
if Debug_Flag_CC then
w (" exception occurred, overflow flag set");
w ("Enable_Range_Check for node ", Int (N));
Write_Str (" Source location = ");
wl (Sloc (N));
- pg (N);
+ pg (Union_Id (N));
end if;
-- If not in optimizing mode, set flag and we are done. We are also done
or else not Is_Discrete_Type (Etype (N))
or else Num_Saved_Checks = Saved_Checks'Last
then
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
if Debug_Flag_CC then
w ("Optimization off");
-- may be redundant.
if not Is_Constrained (Atyp) then
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
return;
end if;
elsif Nkind (Prefix (P)) = N_Explicit_Dereference
and then not Is_Constrained (Atyp)
then
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
return;
end if;
w (" target type not found, flag set");
end if;
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
return;
end if;
w (" expression not of optimizable type, flag set");
end if;
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
return;
end if;
-- Here we will make a new entry for the new check
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
Num_Saved_Checks := Num_Saved_Checks + 1;
Saved_Checks (Num_Saved_Checks) :=
(Killed => False,
pid (Ofs);
w (" Check_Type = R");
w (" Target_Type = ", Int (Ttyp));
- pg (Ttyp);
+ pg (Union_Id (Ttyp));
end if;
-- If we get an exception, then something went wrong, probably because of
exception
when others =>
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
if Debug_Flag_CC then
w (" exception occurred, range flag set");
-- operand is within its declared range (an assumption that validity
-- checking is all about NOT assuming!)
+ -- Note: no need to worry about Possible_Local_Raise here, it will
+ -- already have been called if original node has Do_Range_Check set.
+
Set_Do_Range_Check (Exp, DRC);
end;
end Insert_Valid_Check;
------------------
function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
- Pt : constant Entity_Id := Scope (Scope (E));
+ SE : constant Entity_Id := Scope (E);
N : Node_Id;
E1 : Entity_Id := E;
Make_Integer_Literal (Loc,
Intval => String_Literal_Length (E1));
- elsif Ekind (Pt) = E_Protected_Type
- and then Has_Discriminants (Pt)
- and then Has_Completion (Pt)
+ elsif SE /= Standard_Standard
+ and then Ekind (Scope (SE)) = E_Protected_Type
+ and then Has_Discriminants (Scope (SE))
+ and then Has_Completion (Scope (SE))
and then not Inside_Init_Proc
then
-
-- If the type whose length is needed is a private component
-- constrained by a discriminant, we must expand the 'Length
-- attribute into an explicit computation, using the discriminal
declare
Opnd_Index : Node_Id;
Targ_Index : Node_Id;
+ Opnd_Range : Node_Id;
begin
Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node));
Targ_Index := First_Index (T_Typ);
- while Opnd_Index /= Empty loop
- if Nkind (Opnd_Index) = N_Range then
+
+ while Present (Opnd_Index) loop
+
+ -- If the index is a range, use its bounds. If it is an
+ -- entity (as will be the case if it is a named subtype
+ -- or an itype created for a slice) retrieve its range.
+
+ if Is_Entity_Name (Opnd_Index)
+ and then Is_Type (Entity (Opnd_Index))
+ then
+ Opnd_Range := Scalar_Range (Entity (Opnd_Index));
+ else
+ Opnd_Range := Opnd_Index;
+ end if;
+
+ if Nkind (Opnd_Range) = N_Range then
if Is_In_Range
- (Low_Bound (Opnd_Index), Etype (Targ_Index))
+ (Low_Bound (Opnd_Range), Etype (Targ_Index))
and then
Is_In_Range
- (High_Bound (Opnd_Index), Etype (Targ_Index))
+ (High_Bound (Opnd_Range), Etype (Targ_Index))
then
null;
-- If null range, no check needed
elsif
- Compile_Time_Known_Value (High_Bound (Opnd_Index))
+ Compile_Time_Known_Value (High_Bound (Opnd_Range))
and then
- Compile_Time_Known_Value (Low_Bound (Opnd_Index))
+ Compile_Time_Known_Value (Low_Bound (Opnd_Range))
and then
- Expr_Value (High_Bound (Opnd_Index)) <
- Expr_Value (Low_Bound (Opnd_Index))
+ Expr_Value (High_Bound (Opnd_Range)) <
+ Expr_Value (Low_Bound (Opnd_Range))
then
null;
elsif Is_Out_Of_Range
- (Low_Bound (Opnd_Index), Etype (Targ_Index))
+ (Low_Bound (Opnd_Range), Etype (Targ_Index))
or else
Is_Out_Of_Range
- (High_Bound (Opnd_Index), Etype (Targ_Index))
+ (High_Bound (Opnd_Range), Etype (Targ_Index))
then
Add_Check
(Compile_Time_Constraint_Error
Evolve_Or_Else
(Cond,
Discrete_Range_Cond
- (Opnd_Index, Etype (Targ_Index)));
+ (Opnd_Range, Etype (Targ_Index)));
end if;
end if;
projects / gcc.git / commitdiff