diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-06-06 10:22:41 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-06-06 10:22:41 +0000 |
commit | 00c403eea3414bfb665362a9316fb70b211996ad (patch) | |
tree | 7bee10dc496684afc4a3a6997b07500098601600 /gcc/ada/checks.adb | |
parent | 44e1eb01ce81c67b701e2f14cd7b4ef9fe5b4e00 (diff) | |
download | ppe42-gcc-00c403eea3414bfb665362a9316fb70b211996ad.tar.gz ppe42-gcc-00c403eea3414bfb665362a9316fb70b211996ad.zip |
2007-04-20 Javier Miranda <miranda@adacore.com>
Robert Dewar <dewar@adacore.com>
Ed Schonberg <schonberg@adacore.com>
* checks.ads, checks.adb (Apply_Address_Clause_Check): Handle case in
which the address-clause is applied to in-mode actuals (allowed by
13.1(22)).
(Apply_Discriminant_Check): Do not generate a check if the type is
constrained by a current instance.
(Activate_Division_Check): New procedure
(Activate_Overflow_Check): New procedure
(Activate_Range_Check): New procedure
Call these new Activate procedures instead of setting flags directly
(Apply_Array_Size_Check): Removed, no longer needed.
Code clean up: remove obsolete code related to GCC 2.
(Get_E_Length): Protect against bomb in case scope is standard
(Selected_Range_Checks): If the node to be checked is a conversion to
an unconstrained array type, and the expression is a slice, use the
bounds of the slice to construct the required constraint checks.
Improve NOT NULL error messages
(Apply_Constraint_Check): If the context is a null-excluding access
type, diagnose properly the literal null.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@125388 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/checks.adb')
-rw-r--r-- | gcc/ada/checks.adb | 427 |
1 files changed, 122 insertions, 305 deletions
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 53c534d9ad2..ca0549501c8 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -29,12 +29,14 @@ with Debug; use Debug; 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; @@ -336,6 +338,36 @@ package body Checks is 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 -- --------------------------------- @@ -674,12 +706,17 @@ package body Checks is 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 @@ -738,8 +775,11 @@ package body Checks is 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 @@ -859,266 +899,6 @@ package body Checks is 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 -- ---------------------------- @@ -1174,7 +954,9 @@ package body Checks is -- 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 @@ -1191,8 +973,14 @@ package body Checks is 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; @@ -1439,6 +1227,18 @@ package body Checks is 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 @@ -2166,15 +1966,14 @@ package body Checks is -- 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; --------------------------------- @@ -2258,6 +2057,7 @@ package body Checks is -- 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; @@ -2351,7 +2151,7 @@ package body Checks is 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) @@ -2838,8 +2638,7 @@ package body Checks is 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. @@ -2851,9 +2650,9 @@ package body Checks is 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; @@ -3498,7 +3297,7 @@ package body Checks is 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 @@ -3549,7 +3348,7 @@ package body Checks is 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"); @@ -3584,7 +3383,7 @@ package body Checks is -- 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; @@ -3600,7 +3399,7 @@ package body Checks is -- 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, @@ -3625,7 +3424,7 @@ package body Checks is exception when others => - Set_Do_Overflow_Check (N, True); + Activate_Overflow_Check (N); if Debug_Flag_CC then w (" exception occurred, overflow flag set"); @@ -3697,7 +3496,7 @@ package body Checks is 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 @@ -3712,7 +3511,7 @@ package body Checks is 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"); @@ -3752,7 +3551,7 @@ package body Checks is -- may be redundant. if not Is_Constrained (Atyp) then - Set_Do_Range_Check (N, True); + Activate_Range_Check (N); return; end if; @@ -3762,7 +3561,7 @@ package body Checks is 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; @@ -3786,7 +3585,7 @@ package body Checks is w (" target type not found, flag set"); end if; - Set_Do_Range_Check (N, True); + Activate_Range_Check (N); return; end if; @@ -3821,7 +3620,7 @@ package body Checks is w (" expression not of optimizable type, flag set"); end if; - Set_Do_Range_Check (N, True); + Activate_Range_Check (N); return; end if; @@ -3837,7 +3636,7 @@ package body Checks is -- 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, @@ -3853,7 +3652,7 @@ package body Checks is 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 @@ -3863,7 +3662,7 @@ package body Checks is exception when others => - Set_Do_Range_Check (N, True); + Activate_Range_Check (N); if Debug_Flag_CC then w (" exception occurred, range flag set"); @@ -5077,6 +4876,9 @@ package body Checks is -- 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; @@ -5508,7 +5310,7 @@ package body Checks is ------------------ 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; @@ -5529,12 +5331,12 @@ package body Checks is 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 @@ -6756,37 +6558,52 @@ package body Checks is 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 @@ -6796,7 +6613,7 @@ package body Checks is Evolve_Or_Else (Cond, Discrete_Range_Cond - (Opnd_Index, Etype (Targ_Index))); + (Opnd_Range, Etype (Targ_Index))); end if; end if; |