comparison gcc/ada/checks.adb @ 131:84e7813d76e9

gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
comparison
equal deleted inserted replaced
111:04ced10e8804 131:84e7813d76e9
4 -- -- 4 -- --
5 -- C H E C K S -- 5 -- C H E C K S --
6 -- -- 6 -- --
7 -- B o d y -- 7 -- B o d y --
8 -- -- 8 -- --
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- 9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
10 -- -- 10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under -- 11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- -- 12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- -- 13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
1456 T_Typ := Designated_Type (Typ); 1456 T_Typ := Designated_Type (Typ);
1457 else 1457 else
1458 T_Typ := Typ; 1458 T_Typ := Typ;
1459 end if; 1459 end if;
1460 1460
1461 -- If the expression is a function call that returns a limited object
1462 -- it cannot be copied. It is not clear how to perform the proper
1463 -- discriminant check in this case because the discriminant value must
1464 -- be retrieved from the constructed object itself.
1465
1466 if Nkind (N) = N_Function_Call
1467 and then Is_Limited_Type (Typ)
1468 and then Is_Entity_Name (Name (N))
1469 and then Returns_By_Ref (Entity (Name (N)))
1470 then
1471 return;
1472 end if;
1473
1461 -- Only apply checks when generating code and discriminant checks are 1474 -- Only apply checks when generating code and discriminant checks are
1462 -- not suppressed. In GNATprove mode, we do not apply the checks, but we 1475 -- not suppressed. In GNATprove mode, we do not apply the checks, but we
1463 -- still analyze the expression to possibly issue errors on SPARK code 1476 -- still analyze the expression to possibly issue errors on SPARK code
1464 -- when a run-time error can be detected at compile time. 1477 -- when a run-time error can be detected at compile time.
1465 1478
1858 ROK : Boolean) 1871 ROK : Boolean)
1859 is 1872 is
1860 pragma Assert (Do_Division_Check (N)); 1873 pragma Assert (Do_Division_Check (N));
1861 1874
1862 Loc : constant Source_Ptr := Sloc (N); 1875 Loc : constant Source_Ptr := Sloc (N);
1863 Right : constant Node_Id := Right_Opnd (N); 1876 Right : constant Node_Id := Right_Opnd (N);
1877 Opnd : Node_Id;
1864 1878
1865 begin 1879 begin
1866 if Expander_Active 1880 if Expander_Active
1867 and then not Backend_Divide_Checks_On_Target 1881 and then not Backend_Divide_Checks_On_Target
1868 and then Check_Needed (Right, Division_Check) 1882 and then Check_Needed (Right, Division_Check)
1883
1884 -- See if division by zero possible, and if so generate test. This
1885 -- part of the test is not controlled by the -gnato switch, since it
1886 -- is a Division_Check and not an Overflow_Check.
1887
1888 and then Do_Division_Check (N)
1869 then 1889 then
1870 -- See if division by zero possible, and if so generate test. This 1890 Set_Do_Division_Check (N, False);
1871 -- part of the test is not controlled by the -gnato switch, since 1891
1872 -- it is a Division_Check and not an Overflow_Check. 1892 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1873 1893 if Is_Floating_Point_Type (Etype (N)) then
1874 if Do_Division_Check (N) then 1894 Opnd := Make_Real_Literal (Loc, Ureal_0);
1875 Set_Do_Division_Check (N, False); 1895 else
1876 1896 Opnd := Make_Integer_Literal (Loc, 0);
1877 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1878 Insert_Action (N,
1879 Make_Raise_Constraint_Error (Loc,
1880 Condition =>
1881 Make_Op_Eq (Loc,
1882 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
1883 Right_Opnd => Make_Integer_Literal (Loc, 0)),
1884 Reason => CE_Divide_By_Zero));
1885 end if; 1897 end if;
1898
1899 Insert_Action (N,
1900 Make_Raise_Constraint_Error (Loc,
1901 Condition =>
1902 Make_Op_Eq (Loc,
1903 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
1904 Right_Opnd => Opnd),
1905 Reason => CE_Divide_By_Zero));
1886 end if; 1906 end if;
1887 end if; 1907 end if;
1888 end Apply_Division_Check; 1908 end Apply_Division_Check;
1889 1909
1890 ---------------------------------- 1910 ----------------------------------
2763 is 2783 is
2764 Parnt : constant Node_Id := Parent (Expr); 2784 Parnt : constant Node_Id := Parent (Expr);
2765 S_Typ : Entity_Id; 2785 S_Typ : Entity_Id;
2766 Arr : Node_Id := Empty; -- initialize to prevent warning 2786 Arr : Node_Id := Empty; -- initialize to prevent warning
2767 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning 2787 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning
2768 OK : Boolean := False; -- initialize to prevent warning
2769 2788
2770 Is_Subscr_Ref : Boolean; 2789 Is_Subscr_Ref : Boolean;
2771 -- Set true if Expr is a subscript 2790 -- Set true if Expr is a subscript
2772 2791
2773 Is_Unconstrained_Subscr_Ref : Boolean; 2792 Is_Unconstrained_Subscr_Ref : Boolean;
2993 begin 3012 begin
2994 if Compile_Time_Known_Value (Tlo) 3013 if Compile_Time_Known_Value (Tlo)
2995 and then Compile_Time_Known_Value (Thi) 3014 and then Compile_Time_Known_Value (Thi)
2996 then 3015 then
2997 declare 3016 declare
3017 OK : Boolean := False; -- initialize to prevent warning
2998 Hiv : constant Uint := Expr_Value (Thi); 3018 Hiv : constant Uint := Expr_Value (Thi);
2999 Lov : constant Uint := Expr_Value (Tlo); 3019 Lov : constant Uint := Expr_Value (Tlo);
3000 Hi : Uint; 3020 Hi : Uint := No_Uint;
3001 Lo : Uint; 3021 Lo : Uint := No_Uint;
3002 3022
3003 begin 3023 begin
3004 -- If range is null, we for sure have a constraint error (we 3024 -- If range is null, we for sure have a constraint error (we
3005 -- don't even need to look at the value involved, since all 3025 -- don't even need to look at the value involved, since all
3006 -- possible values will raise CE). 3026 -- possible values will raise CE).
3063 return; 3083 return;
3064 3084
3065 -- If definitely not in range, warn 3085 -- If definitely not in range, warn
3066 3086
3067 elsif Lov > Hi or else Hiv < Lo then 3087 elsif Lov > Hi or else Hiv < Lo then
3068 Bad_Value; 3088
3089 -- Ignore out of range values for System.Priority in
3090 -- CodePeer mode since the actual target compiler may
3091 -- provide a wider range.
3092
3093 if not CodePeer_Mode
3094 or else Target_Typ /= RTE (RE_Priority)
3095 then
3096 Bad_Value;
3097 end if;
3098
3069 return; 3099 return;
3070 3100
3071 -- Otherwise we don't know 3101 -- Otherwise we don't know
3072 3102
3073 else 3103 else
3516 then 3546 then
3517 if Float_To_Int 3547 if Float_To_Int
3518 and then not GNATprove_Mode 3548 and then not GNATprove_Mode
3519 then 3549 then
3520 Apply_Float_Conversion_Check (Expr, Target_Type); 3550 Apply_Float_Conversion_Check (Expr, Target_Type);
3551
3521 else 3552 else
3522 Apply_Scalar_Range_Check 3553 -- Conversions involving fixed-point types are expanded
3523 (Expr, Target_Type, Fixed_Int => Conv_OK); 3554 -- separately, and do not need a Range_Check flag, except
3555 -- in SPARK_Mode, where the explicit constraint check will
3556 -- not be generated.
3557
3558 if GNATprove_Mode
3559 or else not Is_Fixed_Point_Type (Expr_Type)
3560 then
3561 Apply_Scalar_Range_Check
3562 (Expr, Target_Type, Fixed_Int => Conv_OK);
3563
3564 else
3565 Set_Do_Range_Check (Expression (N), False);
3566 end if;
3524 3567
3525 -- If the target type has predicates, we need to indicate 3568 -- If the target type has predicates, we need to indicate
3526 -- the need for a check, even if Determine_Range finds that 3569 -- the need for a check, even if Determine_Range finds that
3527 -- the value is within bounds. This may be the case e.g for 3570 -- the value is within bounds. This may be the case e.g for
3528 -- a division with a constant denominator. 3571 -- a division with a constant denominator.
3745 Dref : Node_Id; 3788 Dref : Node_Id;
3746 Dval : Node_Id; 3789 Dval : Node_Id;
3747 3790
3748 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id; 3791 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id;
3749 3792
3750 ---------------------------------- 3793 --------------------------------
3751 -- Aggregate_Discriminant_Value -- 3794 -- Aggregate_Discriminant_Val --
3752 ---------------------------------- 3795 --------------------------------
3753 3796
3754 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is 3797 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is
3755 Assoc : Node_Id; 3798 Assoc : Node_Id;
3756 3799
3757 begin 3800 begin
4368 4411
4369 Lo_Left : Uint; 4412 Lo_Left : Uint;
4370 Hi_Left : Uint; 4413 Hi_Left : Uint;
4371 -- Lo and Hi bounds of left operand 4414 -- Lo and Hi bounds of left operand
4372 4415
4373 Lo_Right : Uint; 4416 Lo_Right : Uint := No_Uint;
4374 Hi_Right : Uint; 4417 Hi_Right : Uint := No_Uint;
4375 -- Lo and Hi bounds of right (or only) operand 4418 -- Lo and Hi bounds of right (or only) operand
4376 4419
4377 Bound : Node_Id; 4420 Bound : Node_Id;
4378 -- Temp variable used to hold a bound node 4421 -- Temp variable used to hold a bound node
4379 4422
4456 if No (Typ) 4499 if No (Typ)
4457 4500
4458 -- We don't deal with anything except discrete types 4501 -- We don't deal with anything except discrete types
4459 4502
4460 or else not Is_Discrete_Type (Typ) 4503 or else not Is_Discrete_Type (Typ)
4504
4505 -- Don't deal with enumerated types with non-standard representation
4506
4507 or else (Is_Enumeration_Type (Typ)
4508 and then Present (Enum_Pos_To_Rep (Base_Type (Typ))))
4461 4509
4462 -- Ignore type for which an error has been posted, since range in 4510 -- Ignore type for which an error has been posted, since range in
4463 -- this case may well be a bogosity deriving from the error. Also 4511 -- this case may well be a bogosity deriving from the error. Also
4464 -- ignore if error posted on the reference node. 4512 -- ignore if error posted on the reference node.
4465 4513
4907 4955
4908 Lo_Left : Ureal; 4956 Lo_Left : Ureal;
4909 Hi_Left : Ureal; 4957 Hi_Left : Ureal;
4910 -- Lo and Hi bounds of left operand 4958 -- Lo and Hi bounds of left operand
4911 4959
4912 Lo_Right : Ureal; 4960 Lo_Right : Ureal := No_Ureal;
4913 Hi_Right : Ureal; 4961 Hi_Right : Ureal := No_Ureal;
4914 -- Lo and Hi bounds of right (or only) operand 4962 -- Lo and Hi bounds of right (or only) operand
4915 4963
4916 Bound : Node_Id; 4964 Bound : Node_Id;
4917 -- Temp variable used to hold a bound node 4965 -- Temp variable used to hold a bound node
4918 4966
6725 ----------------------------- 6773 -----------------------------
6726 -- Convert_And_Check_Range -- 6774 -- Convert_And_Check_Range --
6727 ----------------------------- 6775 -----------------------------
6728 6776
6729 procedure Convert_And_Check_Range is 6777 procedure Convert_And_Check_Range is
6730 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); 6778 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
6779 Conv_Node : Node_Id;
6731 6780
6732 begin 6781 begin
6782 -- For enumeration types with non-standard representation this is a
6783 -- direct conversion from the enumeration type to the target integer
6784 -- type, which is treated by the back end as a normal integer type
6785 -- conversion, treating the enumeration type as an integer, which is
6786 -- exactly what we want. We set Conversion_OK to make sure that the
6787 -- analyzer does not complain about what otherwise might be an
6788 -- illegal conversion.
6789
6790 if Is_Enumeration_Type (Source_Base_Type)
6791 and then Present (Enum_Pos_To_Rep (Source_Base_Type))
6792 and then Is_Integer_Type (Target_Base_Type)
6793 then
6794 Conv_Node :=
6795 OK_Convert_To
6796 (Typ => Target_Base_Type,
6797 Expr => Duplicate_Subexpr (N));
6798
6799 -- Common case
6800
6801 else
6802 Conv_Node :=
6803 Make_Type_Conversion (Loc,
6804 Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
6805 Expression => Duplicate_Subexpr (N));
6806 end if;
6807
6733 -- We make a temporary to hold the value of the converted value 6808 -- We make a temporary to hold the value of the converted value
6734 -- (converted to the base type), and then do the test against this 6809 -- (converted to the base type), and then do the test against this
6735 -- temporary. The conversion itself is replaced by an occurrence of 6810 -- temporary. The conversion itself is replaced by an occurrence of
6736 -- Tnn and followed by the explicit range check. Note that checks 6811 -- Tnn and followed by the explicit range check. Note that checks
6737 -- are suppressed for this code, since we don't want a recursive 6812 -- are suppressed for this code, since we don't want a recursive
6743 Insert_Actions (N, New_List ( 6818 Insert_Actions (N, New_List (
6744 Make_Object_Declaration (Loc, 6819 Make_Object_Declaration (Loc,
6745 Defining_Identifier => Tnn, 6820 Defining_Identifier => Tnn,
6746 Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc), 6821 Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc),
6747 Constant_Present => True, 6822 Constant_Present => True,
6748 Expression => 6823 Expression => Conv_Node),
6749 Make_Type_Conversion (Loc,
6750 Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
6751 Expression => Duplicate_Subexpr (N))),
6752 6824
6753 Make_Raise_Constraint_Error (Loc, 6825 Make_Raise_Constraint_Error (Loc,
6754 Condition => 6826 Condition =>
6755 Make_Not_In (Loc, 6827 Make_Not_In (Loc,
6756 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 6828 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
6810 -- Force evaluation of the node, so that it does not get evaluated twice 6882 -- Force evaluation of the node, so that it does not get evaluated twice
6811 -- (once for the check, once for the actual reference). Such a double 6883 -- (once for the check, once for the actual reference). Such a double
6812 -- evaluation is always a potential source of inefficiency, and is 6884 -- evaluation is always a potential source of inefficiency, and is
6813 -- functionally incorrect in the volatile case. 6885 -- functionally incorrect in the volatile case.
6814 6886
6815 if not Is_Entity_Name (N) or else Treat_As_Volatile (Entity (N)) then 6887 -- We skip the evaluation of attribute references because, after these
6816 Force_Evaluation (N); 6888 -- runtime checks are generated, the expander may need to rewrite this
6889 -- node (for example, see Attribute_Max_Size_In_Storage_Elements in
6890 -- Expand_N_Attribute_Reference).
6891
6892 if Nkind (N) /= N_Attribute_Reference
6893 and then (not Is_Entity_Name (N)
6894 or else Treat_As_Volatile (Entity (N)))
6895 then
6896 Force_Evaluation (N, Mode => Strict);
6817 end if; 6897 end if;
6818 6898
6819 -- The easiest case is when Source_Base_Type and Target_Base_Type are 6899 -- The easiest case is when Source_Base_Type and Target_Base_Type are
6820 -- the same since in this case we can simply do a direct check of the 6900 -- the same since in this case we can simply do a direct check of the
6821 -- value of N against the bounds of Target_Type. 6901 -- value of N against the bounds of Target_Type.
7685 end Mark_Non_Null; 7765 end Mark_Non_Null;
7686 7766
7687 -- Start of processing for Install_Null_Excluding_Check 7767 -- Start of processing for Install_Null_Excluding_Check
7688 7768
7689 begin 7769 begin
7770 -- No need to add null-excluding checks when the tree may not be fully
7771 -- decorated.
7772
7773 if Serious_Errors_Detected > 0 then
7774 return;
7775 end if;
7776
7690 pragma Assert (Is_Access_Type (Typ)); 7777 pragma Assert (Is_Access_Type (Typ));
7691 7778
7692 -- No check inside a generic, check will be emitted in instance 7779 -- No check inside a generic, check will be emitted in instance
7693 7780
7694 if Inside_A_Generic then 7781 if Inside_A_Generic then
7839 Context : constant Node_Id := Parent (Subp_Body); 7926 Context : constant Node_Id := Parent (Subp_Body);
7840 Loc : constant Source_Ptr := Sloc (Subp_Body); 7927 Loc : constant Source_Ptr := Sloc (Subp_Body);
7841 Subp_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Body); 7928 Subp_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Body);
7842 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 7929 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
7843 7930
7844 Decls : List_Id; 7931 Decls : List_Id;
7845 Flag_Id : Entity_Id; 7932 Flag_Id : Entity_Id;
7846 Set_Ins : Node_Id; 7933 Set_Ins : Node_Id;
7847 Tag_Typ : Entity_Id; 7934 Set_Stmt : Node_Id;
7935 Tag_Typ : Entity_Id;
7848 7936
7849 -- Start of processing for Install_Primitive_Elaboration_Check 7937 -- Start of processing for Install_Primitive_Elaboration_Check
7850 7938
7851 begin 7939 begin
7852 -- Do not generate an elaboration check in compilation modes where 7940 -- Do not generate an elaboration check in compilation modes where
7876 -- they cannot be the target of a dispatching call. 7964 -- they cannot be the target of a dispatching call.
7877 7965
7878 elsif Nkind (Context) = N_Compilation_Unit then 7966 elsif Nkind (Context) = N_Compilation_Unit then
7879 return; 7967 return;
7880 7968
7881 -- Only nonabstract library-level source primitives are considered for 7969 -- Do not consider anything other than nonabstract library-level source
7882 -- this check. 7970 -- primitives.
7883 7971
7884 elsif not 7972 elsif not
7885 (Comes_From_Source (Subp_Id) 7973 (Comes_From_Source (Subp_Id)
7886 and then Is_Library_Level_Entity (Subp_Id) 7974 and then Is_Library_Level_Entity (Subp_Id)
7887 and then Is_Primitive (Subp_Id) 7975 and then Is_Primitive (Subp_Id)
7994 end if; 8082 end if;
7995 8083
7996 -- Generate: 8084 -- Generate:
7997 -- E := True; 8085 -- E := True;
7998 8086
7999 Insert_After_And_Analyze (Set_Ins, 8087 Set_Stmt :=
8000 Make_Assignment_Statement (Loc, 8088 Make_Assignment_Statement (Loc,
8001 Name => New_Occurrence_Of (Flag_Id, Loc), 8089 Name => New_Occurrence_Of (Flag_Id, Loc),
8002 Expression => New_Occurrence_Of (Standard_True, Loc))); 8090 Expression => New_Occurrence_Of (Standard_True, Loc));
8091
8092 -- Mark the assignment statement as elaboration code. This allows the
8093 -- early call region mechanism (see Sem_Elab) to properly ignore such
8094 -- assignments even though they are non-preelaborable code.
8095
8096 Set_Is_Elaboration_Code (Set_Stmt);
8097
8098 Insert_After_And_Analyze (Set_Ins, Set_Stmt);
8003 end Install_Primitive_Elaboration_Check; 8099 end Install_Primitive_Elaboration_Check;
8004 8100
8005 -------------------------- 8101 --------------------------
8006 -- Install_Static_Check -- 8102 -- Install_Static_Check --
8007 -------------------------- 8103 --------------------------
8360 end Reexpand; 8456 end Reexpand;
8361 8457
8362 -- Start of processing for Minimize_Eliminate_Overflows 8458 -- Start of processing for Minimize_Eliminate_Overflows
8363 8459
8364 begin 8460 begin
8461 -- Default initialize Lo and Hi since these are not guaranteed to be
8462 -- set otherwise.
8463
8464 Lo := No_Uint;
8465 Hi := No_Uint;
8466
8365 -- Case where we do not have a signed integer arithmetic operation 8467 -- Case where we do not have a signed integer arithmetic operation
8366 8468
8367 if not Is_Signed_Integer_Arithmetic_Op (N) then 8469 if not Is_Signed_Integer_Arithmetic_Op (N) then
8368 8470
8369 -- Use the normal Determine_Range routine to get the range. We 8471 -- Use the normal Determine_Range routine to get the range. We
9812 Exptyp : Entity_Id; 9914 Exptyp : Entity_Id;
9813 Cond : Node_Id := Empty; 9915 Cond : Node_Id := Empty;
9814 Do_Access : Boolean := False; 9916 Do_Access : Boolean := False;
9815 Wnode : Node_Id := Warn_Node; 9917 Wnode : Node_Id := Warn_Node;
9816 Ret_Result : Check_Result := (Empty, Empty); 9918 Ret_Result : Check_Result := (Empty, Empty);
9817 Num_Checks : Integer := 0; 9919 Num_Checks : Natural := 0;
9818 9920
9819 procedure Add_Check (N : Node_Id); 9921 procedure Add_Check (N : Node_Id);
9820 -- Adds the action given to Ret_Result if N is non-Empty 9922 -- Adds the action given to Ret_Result if N is non-Empty
9821 9923
9822 function Discrete_Range_Cond 9924 function Discrete_Range_Cond