diff options
| -rw-r--r-- | src/vhdl/vhdl-evaluation.adb | 444 | ||||
| -rw-r--r-- | src/vhdl/vhdl-evaluation.ads | 9 | ||||
| -rw-r--r-- | src/vhdl/vhdl-sem_expr.adb | 55 | ||||
| -rw-r--r-- | src/vhdl/vhdl-sem_expr.ads | 18 | ||||
| -rw-r--r-- | src/vhdl/vhdl-sem_names.adb | 25 | ||||
| -rw-r--r-- | src/vhdl/vhdl-sem_types.adb | 158 |
6 files changed, 473 insertions, 236 deletions
diff --git a/src/vhdl/vhdl-evaluation.adb b/src/vhdl/vhdl-evaluation.adb index 4c7c2fa49..6a9748269 100644 --- a/src/vhdl/vhdl-evaluation.adb +++ b/src/vhdl/vhdl-evaluation.adb @@ -335,21 +335,6 @@ package body Vhdl.Evaluation is return Get_Nth_Element (Enum_List, Boolean'Pos (Val)); end Build_Enumeration; - function Build_Constant_Range (Range_Expr : Iir; Origin : Iir) return Iir - is - Res : Iir; - begin - Res := Create_Iir (Iir_Kind_Range_Expression); - Location_Copy (Res, Origin); - Set_Type (Res, Get_Type (Range_Expr)); - Set_Left_Limit (Res, Get_Left_Limit (Range_Expr)); - Set_Right_Limit (Res, Get_Right_Limit (Range_Expr)); - Set_Direction (Res, Get_Direction (Range_Expr)); - Set_Range_Origin (Res, Origin); - Set_Expr_Staticness (Res, Locally); - return Res; - end Build_Constant_Range; - function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir is Orig_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); @@ -4209,6 +4194,17 @@ package body Vhdl.Evaluation is end if; end Eval_Expr_Check_If_Static; + function Int_In_Range (Val : Int64; + Dir : Direction_Type; L, R : Int64) return Boolean is + begin + case Dir is + when Dir_To => + return Val >= L and then Val <= R; + when Dir_Downto => + return Val <= L and then Val >= R; + end case; + end Int_In_Range; + function Eval_Int_In_Range (Val : Int64; Bound : Iir) return Boolean is L, R : Iir; @@ -4222,12 +4218,8 @@ package body Vhdl.Evaluation is then return True; end if; - case Get_Direction (Bound) is - when Dir_To => - return Val >= Eval_Pos (L) and then Val <= Eval_Pos (R); - when Dir_Downto => - return Val <= Eval_Pos (L) and then Val >= Eval_Pos (R); - end case; + return Int_In_Range + (Val, Get_Direction (Bound), Eval_Pos (L), Eval_Pos (R)); when others => Error_Kind ("eval_int_in_range", Bound); end case; @@ -4292,6 +4284,44 @@ package body Vhdl.Evaluation is return True; end Eval_Fp_In_Range; + function Eval_In_Range (Val : Iir; Dir : Direction_Type; L, R : Iir) + return Boolean + is + Vtype : constant Iir := Get_Type (Val); + begin + case Iir_Kinds_Scalar_Type_And_Subtype_Definition (Get_Kind (Vtype)) is + when Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition => + declare + Lv : constant Fp64 := Get_Fp_Value (L); + Rv : constant Fp64 := Get_Fp_Value (R); + V : constant Fp64 := Get_Fp_Value (Val); + begin + case Dir is + when Dir_To => + return V >= Lv and V <= Rv; + when Dir_Downto => + return V <= Lv and V >= Rv; + end case; + end; + when Iir_Kinds_Discrete_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + declare + Lv : constant Int64 := Eval_Pos (L); + Rv : constant Int64 := Eval_Pos (R); + V : constant Int64 := Eval_Pos (Val); + begin + case Dir is + when Dir_To => + return V >= Lv and V <= Rv; + when Dir_Downto => + return V <= Lv and V >= Rv; + end case; + end; + end case; + end Eval_In_Range; + -- Return FALSE if literal EXPR is not in SUB_TYPE bounds. function Eval_Is_In_Bound (Expr : Iir; Sub_Type : Iir; Overflow : Boolean := False) return Boolean @@ -4464,18 +4494,67 @@ package body Vhdl.Evaluation is pragma Unreferenced (Res); end Eval_Check_Bound; - function Eval_Is_Range_In_Bound - (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) - return Boolean + function Is_Null_Range (Dir : Direction_Type; L_Expr, R_Expr : Iir) + return Boolean + is + Ltype : constant Iir := Get_Type (L_Expr); + begin + case Iir_Kinds_Scalar_Type_And_Subtype_Definition (Get_Kind (Ltype)) is + when Iir_Kinds_Discrete_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + declare + L, R : Int64; + begin + L := Eval_Pos (L_Expr); + R := Eval_Pos (R_Expr); + case Dir is + when Dir_To => + return L > R; + when Dir_Downto => + return L < R; + end case; + end; + when Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition => + declare + L, R : Fp64; + begin + L := Get_Fp_Value (L_Expr); + R := Get_Fp_Value (R_Expr); + case Dir is + when Dir_To => + return L > R; + when Dir_Downto => + return L < R; + end case; + end; + end case; + end Is_Null_Range; + + -- Check range expression A_RANGE. + procedure Eval_Check_Range_In_Bound (A_Range : Iir; + Sub_Type : Iir; + Dir_Ok : out Boolean; + Left_Ok : out Boolean; + Right_Ok : out Boolean) is - Type_Range : Iir; Range_Constraint : constant Iir := Eval_Static_Range (A_Range); + L_Expr : constant Iir := Get_Left_Limit (Range_Constraint); + R_Expr : constant Iir := Get_Right_Limit (Range_Constraint); + Dir : constant Direction_Type := Get_Direction (Range_Constraint); + Type_Range : constant Iir := Get_Range_Constraint (Sub_Type); begin - Type_Range := Get_Range_Constraint (Sub_Type); - if not Any_Dir - and then Get_Direction (Type_Range) /= Get_Direction (Range_Constraint) + Dir_Ok := Get_Direction (Type_Range) = Dir; + + Left_Ok := True; + Right_Ok := True; + + -- In case of overflow, assume ok. + if Is_Overflow_Literal (L_Expr) + or else Is_Overflow_Literal (R_Expr) then - return True; + return; end if; case Get_Kind (Sub_Type) is @@ -4484,63 +4563,64 @@ package body Vhdl.Evaluation is | Iir_Kind_Enumeration_Subtype_Definition | Iir_Kind_Enumeration_Type_Definition => declare - L_Expr : constant Iir := Get_Left_Limit (Range_Constraint); - R_Expr : constant Iir := Get_Right_Limit (Range_Constraint); L, R : Int64; begin - if Is_Overflow_Literal (L_Expr) - or else Is_Overflow_Literal (R_Expr) - then - return False; - end if; -- Check for null range. L := Eval_Pos (L_Expr); R := Eval_Pos (R_Expr); - case Get_Direction (Range_Constraint) is + case Dir is when Dir_To => if L > R then - return True; + return; end if; when Dir_Downto => if L < R then - return True; + return; end if; end case; - return Eval_Int_In_Range (L, Type_Range) - and then Eval_Int_In_Range (R, Type_Range); + Left_Ok := Eval_Int_In_Range (L, Type_Range); + Right_Ok := Eval_Int_In_Range (R, Type_Range); end; when Iir_Kind_Floating_Subtype_Definition => declare L, R : Fp64; begin -- Check for null range. - L := Get_Fp_Value (Get_Left_Limit (Range_Constraint)); - R := Get_Fp_Value (Get_Right_Limit (Range_Constraint)); - case Get_Direction (Range_Constraint) is + L := Get_Fp_Value (L_Expr); + R := Get_Fp_Value (R_Expr); + case Dir is when Dir_To => if L > R then - return True; + return; end if; when Dir_Downto => if L < R then - return True; + return; end if; end case; - return Eval_Fp_In_Range (L, Type_Range) - and then Eval_Fp_In_Range (R, Type_Range); + Left_Ok := Eval_Fp_In_Range (L, Type_Range); + Right_Ok := Eval_Fp_In_Range (R, Type_Range); end; when others => - Error_Kind ("eval_is_range_in_bound", Sub_Type); + Error_Kind ("eval_check_range_in_bound", Sub_Type); end case; + end Eval_Check_Range_In_Bound; + + function Eval_Is_Range_In_Bound + (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) return Boolean + is + L_Ok, R_Ok, Dir_Ok : Boolean; + begin + Eval_Check_Range_In_Bound (A_Range, Sub_Type, Dir_Ok, L_Ok, R_Ok); + if not Any_Dir and then not Dir_Ok then + return True; + end if; - -- Should check L <= R or L >= R according to direction. - --return Eval_Is_In_Bound (Get_Left_Limit (A_Range), Sub_Type) - -- and then Eval_Is_In_Bound (Get_Right_Limit (A_Range), Sub_Type); + return L_Ok and R_Ok; end Eval_Is_Range_In_Bound; procedure Eval_Check_Range - (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) - is + (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) is begin if not Eval_Is_Range_In_Bound (A_Range, Sub_Type, Any_Dir) then Warning_Msg_Sem (Warnid_Runtime_Error, +A_Range, @@ -4630,62 +4710,40 @@ package body Vhdl.Evaluation is end case; end Eval_Pos; - function Eval_Static_Range (Rng : Iir) return Iir + procedure Eval_Range_Bounds (Rng : Iir; + Dir : out Direction_Type; + Left, Right : out Iir) is Expr : Iir; - Kind : Iir_Kind; begin Expr := Rng; loop - Kind := Get_Kind (Expr); - case Kind is + case Get_Kind (Expr) is when Iir_Kind_Range_Expression => - if Get_Expr_Staticness (Expr) /= Locally then - return Null_Iir; - end if; + Dir := Get_Direction (Expr); + Left := Get_Left_Limit (Expr); + Right := Get_Right_Limit (Expr); + return; - -- Normalize the range expression. - declare - Left : Iir; - Right : Iir; - begin - Left := Get_Left_Limit_Expr (Expr); - if Is_Valid (Left) then - Left := Eval_Expr_Keep_Orig (Left, False); - Set_Left_Limit_Expr (Expr, Left); - Set_Left_Limit (Expr, Left); - end if; - Right := Get_Right_Limit_Expr (Expr); - if Is_Valid (Right) then - Right := Eval_Expr_Keep_Orig (Right, False); - Set_Right_Limit_Expr (Expr, Right); - Set_Right_Limit (Expr, Right); - end if; - end; - return Expr; - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition => - Expr := Get_Range_Constraint (Expr); when Iir_Kind_Range_Array_Attribute | Iir_Kind_Reverse_Range_Array_Attribute => declare + Orig : constant Iir := Expr; Indexes_List : Iir_Flist; Prefix : Iir; - Res : Iir; Dim : Natural; begin Prefix := Get_Prefix (Expr); if Get_Kind (Prefix) /= Iir_Kind_Array_Subtype_Definition then + -- If the prefix is not a subtype, it's an object. + -- Get its type. Prefix := Get_Type (Prefix); end if; if Get_Kind (Prefix) /= Iir_Kind_Array_Subtype_Definition then -- Unconstrained object. - return Null_Iir; + raise Internal_Error; end if; Indexes_List := Get_Index_Subtype_List (Prefix); Dim := Eval_Attribute_Parameter_Or_1 (Expr); @@ -4696,26 +4754,112 @@ package body Vhdl.Evaluation is Dim := 1; end if; Expr := Get_Nth_Element (Indexes_List, Dim - 1); - if Kind = Iir_Kind_Reverse_Range_Array_Attribute then - Expr := Eval_Static_Range (Expr); - - Res := Create_Iir (Iir_Kind_Range_Expression); - Location_Copy (Res, Expr); - Set_Type (Res, Get_Type (Expr)); - case Get_Direction (Expr) is - when Dir_To => - Set_Direction (Res, Dir_Downto); - when Dir_Downto => - Set_Direction (Res, Dir_To); - end case; - Set_Left_Limit (Res, Get_Right_Limit (Expr)); - Set_Right_Limit (Res, Get_Left_Limit (Expr)); - Set_Range_Origin (Res, Rng); - Set_Expr_Staticness (Res, Get_Expr_Staticness (Expr)); - return Res; + + -- For reverse, recurse and reverse. + if Get_Kind (Orig) = Iir_Kind_Reverse_Range_Array_Attribute + then + declare + R_Dir : Direction_Type; + R_Left, R_Right : Iir; + begin + Eval_Range_Bounds (Expr, R_Dir, R_Left, R_Right); + case R_Dir is + when Dir_To => + Dir := Dir_Downto; + when Dir_Downto => + Dir := Dir_To; + end case; + Left := R_Right; + Right := R_Left; + return; + end; end if; + + -- For normal, just recurse. end; + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Expr := Get_Range_Constraint (Expr); + + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Base_Attribute + | Iir_Kind_Subtype_Attribute + | Iir_Kind_Element_Attribute => + Expr := Get_Type (Expr); + when Iir_Kind_Type_Declaration => + Expr := Get_Type_Definition (Expr); + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Expr := Get_Named_Entity (Expr); + when others => + Error_Kind ("eval_range_bounds", Expr); + end case; + end loop; + end Eval_Range_Bounds; + + function Eval_Range (Arange : Iir) return Iir + is + L, R : Iir; + Dir : Direction_Type; + Res : Iir; + begin + if Get_Kind (Arange) = Iir_Kind_Range_Expression then + -- Range expressions are always evaluated by + -- sem_simple_range_expression. + return Arange; + end if; + + -- ARANGE is a range attribute or a type mark. + Eval_Range_Bounds (Arange, Dir, L, R); + + L := Eval_Static_Expr (L); + R := Eval_Static_Expr (R); + + Res := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Res, Arange); + Set_Range_Origin (Res, Arange); + + case Get_Kind (Arange) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Set_Type (Res, Get_Parent_Type (Arange)); + when others => + Set_Type (Res, Get_Type (Arange)); + end case; + Set_Left_Limit (Res, L); + Set_Right_Limit (Res, R); + Set_Direction (Res, Dir); + Set_Expr_Staticness (Res, Locally); + return Res; + end Eval_Range; + + function Eval_Static_Range (Rng : Iir) return Iir + is + Expr : Iir; + Kind : Iir_Kind; + begin + Expr := Rng; + loop + Kind := Get_Kind (Expr); + case Kind is + when Iir_Kind_Range_Expression + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + if Get_Expr_Staticness (Expr) /= Locally then + return Null_Iir; + end if; + + return Eval_Range (Expr); + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Expr := Get_Range_Constraint (Expr); when Iir_Kind_Subtype_Declaration | Iir_Kind_Base_Attribute | Iir_Kind_Subtype_Attribute @@ -4732,18 +4876,90 @@ package body Vhdl.Evaluation is end loop; end Eval_Static_Range; - function Eval_Range (Arange : Iir) return Iir is - Res : Iir; + procedure Check_Range_Compatibility (Inner : Iir; Outer : Iir) + is + pragma Assert (Get_Kind (Inner) = Iir_Kind_Range_Expression); + pragma Assert (Get_Expr_Staticness (Inner) = Locally); + I_Dir : constant Direction_Type := Get_Direction (Inner); + I_L : constant Iir := Get_Left_Limit (Inner); + I_R : constant Iir := Get_Right_Limit (Inner); + O_L, O_R : Iir; + O_Dir : Direction_Type; + B : Iir; begin - Res := Eval_Static_Range (Arange); - if Res /= Arange - and then Get_Range_Origin (Res) /= Arange + Eval_Range_Bounds (Outer, O_Dir, O_L, O_R); + + -- Avoid cascade error in case of overflow. + if Is_Overflow_Literal (I_L) + or else Is_Overflow_Literal (I_R) + or else Is_Overflow_Literal (O_L) + or else Is_Overflow_Literal (O_R) then - return Build_Constant_Range (Res, Arange); - else - return Res; + return; end if; - end Eval_Range; + + -- LRM08 5.2 Scalar types + -- A range constraint is compatible with a subtype if each bound of the + -- range belongs to the subtype or if the range constraint defines a + -- null range. + -- + -- GHDL: Bounds of a null range don't have to be within the limits. + if Is_Null_Range (I_Dir, I_L, I_R) then + return; + end if; + if Is_Null_Range (O_Dir, O_L, O_R) then + Error_Msg_Sem (+Inner, "range incompatible with null-range"); + return; + end if; + + if not Eval_In_Range (I_L, O_Dir, O_L, O_R) then + -- Improve location of the message. + B := Get_Left_Limit_Expr (Inner); + if B = Null_Node then + B := Inner; + end if; + Warning_Msg_Sem (Warnid_Runtime_Error, +B, + "left bound incompatible with range"); + B := Build_Overflow (I_L, Get_Type (Inner)); + if Get_Left_Limit_Expr (Inner) = Null_Iir then + Set_Literal_Origin (B, Null_Iir); + end if; + Set_Left_Limit_Expr (Inner, B); + Set_Left_Limit (Inner, B); + Set_Expr_Staticness (Inner, None); + end if; + if not Eval_In_Range (I_R, O_Dir, O_L, O_R) then + -- Improve location of the message. + B := Get_Right_Limit_Expr (Inner); + if B = Null_Node then + B := Inner; + end if; + Warning_Msg_Sem (Warnid_Runtime_Error, +B, + "right bound incompatible with range"); + B := Build_Overflow (I_R, Get_Type (Inner)); + if Get_Right_Limit_Expr (Inner) = Null_Iir then + Set_Literal_Origin (B, Null_Iir); + end if; + Set_Right_Limit_Expr (Inner, B); + Set_Right_Limit (Inner, B); + Set_Expr_Staticness (Inner, None); + end if; + end Check_Range_Compatibility; + + procedure Check_Discrete_Range_Compatibility (Inner : Iir; Outer : Iir) is + begin + case Get_Kind (Inner) is + when Iir_Kind_Range_Expression => + Check_Range_Compatibility (Inner, Outer); + when Iir_Kinds_Discrete_Type_Definition => + Check_Discrete_Range_Compatibility + (Get_Range_Constraint (Inner), Outer); + when others => + -- Can this happen ? As INNER is locally static it should have + -- been transformed into a range. + Error_Kind ("check_discrete_range_compatibility", Inner); + end case; + end Check_Discrete_Range_Compatibility; function Eval_Range_If_Static (Arange : Iir) return Iir is begin diff --git a/src/vhdl/vhdl-evaluation.ads b/src/vhdl/vhdl-evaluation.ads index ffeaa04c5..aa4fcc4c7 100644 --- a/src/vhdl/vhdl-evaluation.ads +++ b/src/vhdl/vhdl-evaluation.ads @@ -102,6 +102,15 @@ package Vhdl.Evaluation is -- Return a locally static range expression with the origin set for ARANGE. function Eval_Range (Arange : Iir) return Iir; + -- Check that static range INNER is compatible (ie inside) with static + -- range OUTER. + -- Both INNER and OUTER must be ranges (ie range expression or attribute). + procedure Check_Range_Compatibility (Inner : Iir; Outer : Iir); + + -- Check that static discrete range INNER is compatible with static + -- discrete range OUTER. + procedure Check_Discrete_Range_Compatibility (Inner : Iir; Outer : Iir); + -- If ARANGE is a locally static range, return locally static range -- expression (with the origin set), else return ARANGE. function Eval_Range_If_Static (Arange : Iir) return Iir; diff --git a/src/vhdl/vhdl-sem_expr.adb b/src/vhdl/vhdl-sem_expr.adb index d605d3b46..2a27dba05 100644 --- a/src/vhdl/vhdl-sem_expr.adb +++ b/src/vhdl/vhdl-sem_expr.adb @@ -552,8 +552,7 @@ package body Vhdl.Sem_Expr is -- FIXME: avoid to run it on an already analyzed node, be careful -- with range_type_expr. function Sem_Simple_Range_Expression - (Expr: Iir_Range_Expression; A_Type: Iir; Any_Dir : Boolean) - return Iir_Range_Expression + (Expr: Iir_Range_Expression; A_Type: Iir) return Iir_Range_Expression is Base_Type: Iir; Left, Right: Iir; @@ -710,13 +709,6 @@ package body Vhdl.Sem_Expr is return Null_Iir; end if; - if Get_Expr_Staticness (Expr) = Locally - and then Get_Type_Staticness (Expr_Type) = Locally - and then Get_Kind (Expr_Type) in Iir_Kinds_Subtype_Definition - then - Eval_Check_Range (Expr, Expr_Type, Any_Dir); - end if; - return Expr; end Sem_Simple_Range_Expression; @@ -727,15 +719,14 @@ package body Vhdl.Sem_Expr is -- LRM93 3.2.1.1 -- FIXME: avoid to run it on an already analyzed node, be careful -- with range_type_expr. - function Sem_Range_Expression (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) - return Iir + function Sem_Range_Expression (Expr: Iir; A_Type: Iir) return Iir is Res : Iir; Res_Type : Iir; begin case Get_Kind (Expr) is when Iir_Kind_Range_Expression => - Res := Sem_Simple_Range_Expression (Expr, A_Type, Any_Dir); + Res := Sem_Simple_Range_Expression (Expr, A_Type); return Res; when Iir_Kinds_Denoting_Name @@ -781,21 +772,10 @@ package body Vhdl.Sem_Expr is return Null_Iir; end if; - Res := Eval_Range_If_Static (Res); - - if A_Type /= Null_Iir - and then Get_Type_Staticness (A_Type) = Locally - and then Get_Kind (A_Type) in Iir_Kinds_Subtype_Definition - then - if Get_Expr_Staticness (Res) = Locally then - Eval_Check_Range (Res, A_Type, Any_Dir); - end if; - end if; - return Res; + return Eval_Range_If_Static (Res); end Sem_Range_Expression; - function Sem_Discrete_Range (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) - return Iir + function Sem_Discrete_Range (Expr: Iir; A_Type: Iir) return Iir is Res : Iir; Res_Type : Iir; @@ -819,7 +799,7 @@ package body Vhdl.Sem_Expr is -- FIXME: override type of RES ? end if; else - Res := Sem_Range_Expression (Expr, A_Type, Any_Dir); + Res := Sem_Range_Expression (Expr, A_Type); if Res = Null_Iir then return Null_Iir; @@ -850,7 +830,7 @@ package body Vhdl.Sem_Expr is Res : Iir; Range_Type : Iir; begin - Res := Sem_Discrete_Range (Expr, Null_Iir, True); + Res := Sem_Discrete_Range (Expr, Null_Iir); if Res = Null_Iir then return Null_Iir; end if; @@ -871,7 +851,7 @@ package body Vhdl.Sem_Expr is -- FIXME: catch phys/phys. Set_Type (Res, Integer_Type_Definition); if Get_Expr_Staticness (Res) = Locally then - Eval_Check_Range (Res, Integer_Subtype_Definition, True); + Check_Range_Compatibility (Res, Integer_Subtype_Definition); end if; elsif Range_Type = Universal_Integer_Type_Definition then if Vhdl_Std >= Vhdl_08 then @@ -897,6 +877,9 @@ package body Vhdl.Sem_Expr is & "literal or attribute"); end if; Set_Type (Res, Integer_Type_Definition); + if Get_Expr_Staticness (Res) = Locally then + Check_Range_Compatibility (Res, Integer_Subtype_Definition); + end if; end if; return Res; end Sem_Discrete_Range_Integer; @@ -2734,7 +2717,7 @@ package body Vhdl.Sem_Expr is null; end case; if not Ok then - Error_Msg_Sem (+Choice, "%n out of index range", +Expr); + Error_Msg_Sem (+Choice, "choice is out of index range"); Has_Err := True; end if; Choice := Get_Chain (Choice); @@ -2955,10 +2938,11 @@ package body Vhdl.Sem_Expr is is Expr : Iir; Ent : Iir; + Static : Iir_Staticness; begin if Get_Kind (El) = Iir_Kind_Choice_By_Range then Expr := Get_Choice_Range (El); - Expr := Sem_Discrete_Range (Expr, Choice_Type, True); + Expr := Sem_Discrete_Range (Expr, Choice_Type); if Expr = Null_Iir then return False; end if; @@ -2966,13 +2950,16 @@ package body Vhdl.Sem_Expr is when Iir_Kind_Range_Expression | Iir_Kinds_Range_Attribute | Iir_Kinds_Denoting_Name => - Expr := Eval_Range_If_Static (Expr); - Set_Choice_Staticness (El, Get_Expr_Staticness (Expr)); + Static := Get_Expr_Staticness (Expr); when Iir_Kinds_Scalar_Subtype_Definition => - Set_Choice_Staticness (El, Get_Type_Staticness (Expr)); + Static := Get_Type_Staticness (Expr); when others => Error_Kind ("sem_sime_choice(1)", Expr); end case; + Set_Choice_Staticness (El, Static); + if Static = Locally then + Expr := Eval_Range (Expr); + end if; Set_Choice_Range (El, Expr); else Expr := Get_Choice_Expression (El); @@ -5345,7 +5332,7 @@ package body Vhdl.Sem_Expr is declare Res : Iir; begin - Res := Sem_Simple_Range_Expression (Expr, A_Type, True); + Res := Sem_Simple_Range_Expression (Expr, A_Type); return Create_Error_Expr (Res, A_Type); end; diff --git a/src/vhdl/vhdl-sem_expr.ads b/src/vhdl/vhdl-sem_expr.ads index b247d2d7e..19b817e67 100644 --- a/src/vhdl/vhdl-sem_expr.ads +++ b/src/vhdl/vhdl-sem_expr.ads @@ -114,19 +114,15 @@ package Vhdl.Sem_Expr is -- handled in this package. procedure Sem_Procedure_Call (Call : Iir_Procedure_Call; Stmt : Iir); - -- Analyze a range (ie a range attribute or a range expression). If - -- ANY_DIR is true, the range can't be a null range (slice vs subtype, - -- used in static evaluation). A_TYPE may be Null_Iir. + -- Analyze a range (ie a range attribute or a range expression). + -- A_TYPE may be Null_Iir. -- Return Null_Iir in case of error, or EXPR analyzed (and evaluated if -- possible). - function Sem_Range_Expression (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) - return Iir; - - -- Analyze a discrete range. If ANY_DIR is true, the range can't be a - -- null range (slice vs subtype -- used in static evaluation). A_TYPE may - -- be Null_Iir. Return Null_Iir in case of error. - function Sem_Discrete_Range (Expr: Iir; A_Type: Iir; Any_Dir: Boolean) - return Iir; + function Sem_Range_Expression (Expr: Iir; A_Type: Iir) return Iir; + + -- Analyze a discrete range. A_TYPE may be Null_Iir. + -- Return Null_Iir in case of error. + function Sem_Discrete_Range (Expr: Iir; A_Type: Iir) return Iir; -- Analyze a discrete range and convert to integer if both bounds are -- universal integer types, according to rules of LRM 3.2.1.1 diff --git a/src/vhdl/vhdl-sem_names.adb b/src/vhdl/vhdl-sem_names.adb index 800e6183f..b52e7e7ae 100644 --- a/src/vhdl/vhdl-sem_names.adb +++ b/src/vhdl/vhdl-sem_names.adb @@ -720,7 +720,6 @@ package body Vhdl.Sem_Names is end if; Index_Type := Get_Index_Type (Index_List, 0); - Prefix_Rng := Eval_Static_Range (Index_Type); -- LRM93 6.5 -- It is an error if either the bounds of the discrete range does not @@ -734,7 +733,7 @@ package body Vhdl.Sem_Names is -- The bounds of the discrete range [...] must be of the -- type of the index of the array. Suffix := Get_Suffix (Name); - Suffix := Sem_Discrete_Range (Suffix, Index_Type, False); + Suffix := Sem_Discrete_Range (Suffix, Index_Type); if Suffix = Null_Iir then return; end if; @@ -766,16 +765,22 @@ package body Vhdl.Sem_Names is if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition and then Get_Index_Constraint_Flag (Prefix_Type) and then Staticness = Locally - and then Prefix_Rng /= Null_Iir - and then Get_Direction (Suffix_Rng) /= Get_Direction (Prefix_Rng) + and then Get_Type_Staticness (Index_Type) = Locally then - if False and then Flags.Vhdl_Std = Vhdl_87 then - -- emit a warning for a null slice. - Warning_Msg_Sem (Warnid_Runtime_Error, +Name, - "direction mismatch results in a null slice"); + Prefix_Rng := Eval_Static_Range (Index_Type); + if Get_Direction (Suffix_Rng) /= Get_Direction (Prefix_Rng) then + if False and then Flags.Vhdl_Std = Vhdl_87 then + -- emit a warning for a null slice. + Warning_Msg_Sem (Warnid_Runtime_Error, +Name, + "direction mismatch results in a null slice"); + end if; + Error_Msg_Sem (+Name, "direction of the range mismatch"); + else + Check_Range_Compatibility (Suffix_Rng, Prefix_Rng); + -- May have changed in case of overflow. + Staticness := Get_Expr_Staticness (Suffix_Rng); end if; - Error_Msg_Sem (+Name, "direction of the range mismatch"); end if; -- LRM93 7.4.1 @@ -2769,7 +2774,7 @@ package body Vhdl.Sem_Names is Set_Index_List (Res, Create_Iir_Flist (1)); Set_Nth_Element (Get_Index_List (Res), 0, Actual); when Iir_Kind_Slice_Name => - Actual := Sem_Discrete_Range (Actual, Itype, False); + Actual := Sem_Discrete_Range (Actual, Itype); if Actual = Null_Iir then return Null_Iir; end if; diff --git a/src/vhdl/vhdl-sem_types.adb b/src/vhdl/vhdl-sem_types.adb index 43f887830..3481fb46c 100644 --- a/src/vhdl/vhdl-sem_types.adb +++ b/src/vhdl/vhdl-sem_types.adb @@ -150,6 +150,9 @@ package body Vhdl.Sem_Types is return Null_Iir; end if; + Left := Eval_Expr_If_Static (Left); + Right := Eval_Expr_If_Static (Right); + -- Emit error message for overflow and replace with a value to avoid -- error storm. if Get_Kind (Left) = Iir_Kind_Overflow_Literal then @@ -1259,7 +1262,7 @@ package body Vhdl.Sem_Types is declare Res : Iir; begin - Res := Sem_Discrete_Range (Def, Null_Iir, True); + Res := Sem_Discrete_Range (Def, Null_Iir); if Res = Null_Iir then return Null_Iir; end if; @@ -1296,6 +1299,7 @@ package body Vhdl.Sem_Types is is Sub_Type: Iir; Range_Type : Iir; + Rng : Iir; begin case Get_Kind (A_Range) is when Iir_Kind_Range_Expression @@ -1314,6 +1318,15 @@ package body Vhdl.Sem_Types is return Null_Iir; end case; + if Get_Expr_Staticness (A_Range) = Locally then + Rng := Eval_Range (A_Range); + if Get_Kind (Range_Type) in Iir_Kinds_Range_Type_Definition then + Check_Range_Compatibility (Rng, Range_Type); + end if; + else + Rng := A_Range; + end if; + case Get_Kind (Range_Type) is when Iir_Kind_Enumeration_Type_Definition | Iir_Kind_Enumeration_Subtype_Definition => @@ -1327,11 +1340,12 @@ package body Vhdl.Sem_Types is when others => raise Internal_Error; end case; - Location_Copy (Sub_Type, A_Range); - Set_Range_Constraint (Sub_Type, A_Range); + Location_Copy (Sub_Type, Rng); + Set_Range_Constraint (Sub_Type, Rng); Set_Parent_Type (Sub_Type, Get_Base_Type (Range_Type)); - Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (A_Range)); + Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (Rng)); Set_Signal_Type_Flag (Sub_Type, True); + return Sub_Type; end Range_To_Subtype_Indication; @@ -1630,6 +1644,8 @@ package body Vhdl.Sem_Types is Type_Index_List : Iir_Flist; Subtype_Index_List : Iir_Flist; Subtype_Index_List2 : Iir_Flist; + Static : Iir_Staticness; + Parent_Type : Iir; begin Index_Staticness := Locally; Type_Index_List := Get_Index_Subtype_Definition_List (Base_Def); @@ -1648,75 +1664,78 @@ package body Vhdl.Sem_Types is Set_Index_Constraint_Flag (Def, Get_Index_Constraint_Flag (Mark_Def)); Set_Index_Subtype_List (Def, Get_Index_Subtype_List (Mark_Def)); Index_Staticness := Get_Type_Staticness (Mark_Def); - else - if Get_Index_Constraint_Flag (Mark_Def) then - Error_Msg_Sem (+Def, "constrained array cannot be re-constrained"); - end if; - Type_Nbr_Dim := Get_Nbr_Elements (Type_Index_List); - Subtype_Nbr_Dim := Get_Nbr_Elements (Subtype_Index_List); - - if Subtype_Nbr_Dim /= Type_Nbr_Dim then - -- Number of dimension mismatch. Create an index with the right - -- length. - Subtype_Index_List2 := Create_Iir_Flist (Type_Nbr_Dim); - for I in 1 .. Natural'Min (Subtype_Nbr_Dim, Type_Nbr_Dim) loop - Set_Nth_Element - (Subtype_Index_List2, I - 1, - Get_Nth_Element (Subtype_Index_List, I - 1)); - end loop; + return; + end if; - if Subtype_Nbr_Dim < Type_Nbr_Dim then - Error_Msg_Sem - (+Def, - "subtype has less indexes than %n defined at %l", - (+Mark_Def, +Mark_Def)); + if Get_Index_Constraint_Flag (Mark_Def) then + Error_Msg_Sem (+Def, "constrained array cannot be re-constrained"); + end if; + Type_Nbr_Dim := Get_Nbr_Elements (Type_Index_List); + Subtype_Nbr_Dim := Get_Nbr_Elements (Subtype_Index_List); - -- Clear extra indexes. - for I in Subtype_Nbr_Dim + 1 .. Type_Nbr_Dim loop - Set_Nth_Element (Subtype_Index_List2, I - 1, Null_Iir); - end loop; - else - Error_Msg_Sem - (+Get_Nth_Element (Subtype_Index_List, Type_Nbr_Dim), - "subtype has more indexes than %n defined at %l", - (+Mark_Def, +Mark_Def)); + if Subtype_Nbr_Dim /= Type_Nbr_Dim then + -- Number of dimension mismatch. Create an index with the right + -- length. + Subtype_Index_List2 := Create_Iir_Flist (Type_Nbr_Dim); + for I in 1 .. Natural'Min (Subtype_Nbr_Dim, Type_Nbr_Dim) loop + Set_Nth_Element + (Subtype_Index_List2, I - 1, + Get_Nth_Element (Subtype_Index_List, I - 1)); + end loop; - -- Forget extra indexes. - end if; - Destroy_Iir_Flist (Subtype_Index_List); - Subtype_Index_List := Subtype_Index_List2; - end if; + if Subtype_Nbr_Dim < Type_Nbr_Dim then + Error_Msg_Sem (+Def, + "subtype has less indexes than %n defined at %l", + (+Mark_Def, +Mark_Def)); + + -- Clear extra indexes. + for I in Subtype_Nbr_Dim + 1 .. Type_Nbr_Dim loop + Set_Nth_Element (Subtype_Index_List2, I - 1, Null_Iir); + end loop; + else + Error_Msg_Sem (+Get_Nth_Element (Subtype_Index_List, Type_Nbr_Dim), + "subtype has more indexes than %n defined at %l", + (+Mark_Def, +Mark_Def)); - for I in 1 .. Type_Nbr_Dim loop - Type_Index := Get_Nth_Element (Type_Index_List, I - 1); - - if I <= Subtype_Nbr_Dim then - Subtype_Index := Get_Nth_Element (Subtype_Index_List, I - 1); - Subtype_Index := Sem_Discrete_Range - (Subtype_Index, Get_Index_Type (Type_Index), True); - if Subtype_Index /= Null_Iir then - Subtype_Index := - Range_To_Subtype_Indication (Subtype_Index); - Index_Staticness := Min - (Index_Staticness, - Get_Type_Staticness (Get_Type_Of_Subtype_Indication - (Subtype_Index))); + -- Forget extra indexes. + end if; + Destroy_Iir_Flist (Subtype_Index_List); + Subtype_Index_List := Subtype_Index_List2; + end if; + + for I in 1 .. Type_Nbr_Dim loop + Type_Index := Get_Nth_Element (Type_Index_List, I - 1); + + if I <= Subtype_Nbr_Dim then + Subtype_Index := Get_Nth_Element (Subtype_Index_List, I - 1); + Parent_Type := Get_Index_Type (Type_Index); + Subtype_Index := Sem_Discrete_Range (Subtype_Index, Parent_Type); + if Subtype_Index /= Null_Iir then + Subtype_Index := Range_To_Subtype_Indication (Subtype_Index); + Static := Get_Type_Staticness + (Get_Type_Of_Subtype_Indication (Subtype_Index)); + Index_Staticness := Min (Index_Staticness, Static); + if Static = Locally + and then Get_Type_Staticness (Parent_Type) = Locally + then + Check_Discrete_Range_Compatibility + (Subtype_Index, Parent_Type); end if; - else - Subtype_Index := Null_Iir; - end if; - if Subtype_Index = Null_Iir then - -- Create a fake subtype from type_index. - -- FIXME: It is too fake. - Subtype_Index := Type_Index; - Index_Staticness := None; end if; - Set_Nth_Element (Subtype_Index_List, I - 1, Subtype_Index); - end loop; + else + Subtype_Index := Null_Iir; + end if; + if Subtype_Index = Null_Iir then + -- Create a fake subtype from type_index. + -- FIXME: It is too fake. + Subtype_Index := Type_Index; + Index_Staticness := None; + end if; + Set_Nth_Element (Subtype_Index_List, I - 1, Subtype_Index); + end loop; - Set_Index_Subtype_List (Def, Subtype_Index_List); - Set_Index_Constraint_Flag (Def, True); - end if; + Set_Index_Subtype_List (Def, Subtype_Index_List); + Set_Index_Constraint_Flag (Def, True); end Sem_Array_Constraint_Indexes; -- DEF is an array_subtype_definition. @@ -2265,16 +2284,21 @@ package body Vhdl.Sem_Types is Location_Copy (Res, Def); Set_Parent_Type (Res, Type_Mark); Set_Resolution_Indication (Res, Get_Resolution_Indication (Def)); + A_Range := Get_Range_Constraint (Def); if A_Range = Null_Iir then A_Range := Get_Range_Constraint (Type_Mark); Set_Is_Ref (Res, True); else - A_Range := Sem_Range_Expression (A_Range, Type_Mark, True); + A_Range := Sem_Range_Expression (A_Range, Type_Mark); if A_Range = Null_Iir then -- Avoid error propagation. A_Range := Get_Range_Constraint (Type_Mark); Set_Is_Ref (Res, True); + elsif Get_Expr_Staticness (A_Range) = Locally then + A_Range := Eval_Range (A_Range); + Check_Range_Compatibility + (A_Range, Get_Range_Constraint (Type_Mark)); end if; end if; Set_Range_Constraint (Res, A_Range); |