From 694a4d2744f252b326121c37c2271133e0ec535f Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Mon, 21 Jul 2014 07:47:19 +0200 Subject: Add overflow literal. --- disp_tree.adb | 25 ++- disp_vhdl.adb | 204 ++++++++++++++++++--- errorout.adb | 2 + evaluation.adb | 141 ++++++++------ iirs.adb | 4 + iirs.ads | 31 +++- iirs_utils.adb | 14 ++ iirs_utils.ads | 3 + libraries.adb | 66 ++----- parse.adb | 5 - sem_decls.adb | 4 +- sem_expr.adb | 11 +- sem_stmts.adb | 2 +- sem_types.adb | 11 +- testsuite/vests/testsuite.sh | 5 + .../analyzer_failure/non_compliant.exp | 10 +- translate/ghdldrv/ghdllocal.adb | 84 +++++---- translate/ghdldrv/ghdllocal.ads | 4 + translate/ghdldrv/ghdlprint.adb | 51 +++++- translate/ghdldrv/ghdlrun.adb | 2 - translate/grt/grt-lib.adb | 7 - translate/grt/grt-lib.ads | 3 - translate/trans_decls.ads | 1 - translate/translation.adb | 119 ++++++------ xrefs.adb | 6 +- 25 files changed, 522 insertions(+), 293 deletions(-) diff --git a/disp_tree.adb b/disp_tree.adb index 460bd17b4..a68d2d0ee 100644 --- a/disp_tree.adb +++ b/disp_tree.adb @@ -708,6 +708,8 @@ package body Disp_Tree is if Flat_Decl then return; end if; + Header ("entity_name:"); + Disp_Tree (Get_Entity_Name (Tree), Ntab, True); Header ("entity:"); Disp_Tree_Flat (Get_Entity (Tree), Ntab); Header ("declaration_chain:"); @@ -860,12 +862,18 @@ package body Disp_Tree is Disp_Tree (Get_Name (Tree), Ntab); Header ("associated:"); Disp_Tree (Get_Associated (Tree), Ntab, True); + Header ("same_alternative_flag: ", False); + Disp_Flag (Get_Same_Alternative_Flag (Tree)); when Iir_Kind_Choice_By_Others => Header ("associated"); Disp_Tree (Get_Associated (Tree), Ntab, True); + Header ("same_alternative_flag: ", False); + Disp_Flag (Get_Same_Alternative_Flag (Tree)); when Iir_Kind_Choice_By_None => Header ("associated"); Disp_Tree (Get_Associated (Tree), Ntab, True); + Header ("same_alternative_flag: ", False); + Disp_Flag (Get_Same_Alternative_Flag (Tree)); when Iir_Kind_Choice_By_Range => Header ("staticness: ", False); Disp_Choice_Staticness (Tree); @@ -873,6 +881,8 @@ package body Disp_Tree is Disp_Tree (Get_Expression (Tree), Ntab); Header ("associated"); Disp_Tree (Get_Associated (Tree), Ntab, True); + Header ("same_alternative_flag: ", False); + Disp_Flag (Get_Same_Alternative_Flag (Tree)); when Iir_Kind_Choice_By_Expression => Header ("expression:"); Disp_Tree (Get_Expression (Tree), Ntab); @@ -880,6 +890,8 @@ package body Disp_Tree is Disp_Choice_Staticness (Tree); Header ("associated"); Disp_Tree (Get_Associated (Tree), Ntab, True); + Header ("same_alternative_flag: ", False); + Disp_Flag (Get_Same_Alternative_Flag (Tree)); when Iir_Kind_Signal_Interface_Declaration => if Flat_Decl then @@ -1395,10 +1407,6 @@ package body Disp_Tree is Disp_Tree (Get_Base_Type (Tree), Ntab, True); Header ("type mark:"); Disp_Tree (Get_Type_Mark (Tree), Ntab, True); - Header ("designated type:"); - Disp_Tree_Flat (Get_Designated_Type (Tree), Ntab); - Header ("resolution function:"); - Disp_Tree_Flat (Get_Resolution_Function (Tree), Ntab); when Iir_Kind_Incomplete_Type_Definition => Header ("staticness: ", False); @@ -1805,7 +1813,7 @@ package body Disp_Tree is when Iir_Kind_Selected_Name => Header ("prefix:"); Disp_Tree (Get_Prefix (Tree), Ntab, True); - Header ("identifier: ", False); + Header ("suffix_identifier: ", False); Disp_Ident (Get_Suffix_Identifier (Tree)); when Iir_Kind_Attribute_Name => @@ -1978,6 +1986,13 @@ package body Disp_Tree is Disp_Tree (Get_Type (Tree), Ntab, True); Header ("origin:"); Disp_Tree (Get_Literal_Origin (Tree), Ntab, True); + when Iir_Kind_Overflow_Literal => + Header ("staticness:", false); + Disp_Expr_Staticness (Tree); + Header ("type:"); + Disp_Tree_Flat (Get_Type (Tree), Ntab); + Header ("origin:"); + Disp_Tree (Get_Literal_Origin (Tree), Ntab, True); when Iir_Kind_Proxy => Header ("proxy:"); diff --git a/disp_vhdl.adb b/disp_vhdl.adb index 844bb7afb..a20e3754f 100644 --- a/disp_vhdl.adb +++ b/disp_vhdl.adb @@ -66,6 +66,7 @@ package body Disp_Vhdl is procedure Disp_Subprogram_Declaration (Subprg: Iir); procedure Disp_Binding_Indication (Bind : Iir; Indent : Count); procedure Disp_Subtype_Indication (Def : Iir; Full_Decl : Boolean := False); + procedure Disp_Parametered_Attribute (Name : String; Expr : Iir); procedure Disp_Ident (Id: Name_Id) is begin @@ -148,7 +149,10 @@ package body Disp_Vhdl is | Iir_Kind_Unit_Declaration | Iir_Kind_Nature_Declaration | Iir_Kind_Terminal_Declaration - | Iir_Kinds_Quantity_Declaration => + | Iir_Kinds_Quantity_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Character_Literal + | Iir_Kinds_Process_Statement => Disp_Identifier (Decl); when Iir_Kind_Anonymous_Type_Declaration => Put ('<'); @@ -178,20 +182,25 @@ package body Disp_Vhdl is end case; end Disp_Name_Of; - procedure Disp_Range (Decl: Iir) is + procedure Disp_Range (Rng : Iir) is begin - if Get_Kind (Decl) = Iir_Kind_Range_Expression then - Disp_Expression (Get_Left_Limit (Decl)); - if Get_Direction (Decl) = Iir_To then - Put (" to "); - else - Put (" downto "); - end if; - Disp_Expression (Get_Right_Limit (Decl)); - else - Disp_Subtype_Indication (Decl); - -- Disp_Name_Of (Get_Type_Declarator (Decl)); - end if; + case Get_Kind (Rng) is + when Iir_Kind_Range_Expression => + Disp_Expression (Get_Left_Limit (Rng)); + if Get_Direction (Rng) = Iir_To then + Put (" to "); + else + Put (" downto "); + end if; + Disp_Expression (Get_Right_Limit (Rng)); + when Iir_Kind_Range_Array_Attribute => + Disp_Parametered_Attribute ("range", Rng); + when Iir_Kind_Reverse_Range_Array_Attribute => + Disp_Parametered_Attribute ("reverse_range", Rng); + when others => + Disp_Subtype_Indication (Rng); + -- Disp_Name_Of (Get_Type_Declarator (Decl)); + end case; end Disp_Range; procedure Disp_Name (Name: Iir) is @@ -215,10 +224,13 @@ package body Disp_Vhdl is | Iir_Kind_Unit_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kinds_Interface_Declaration | Iir_Kind_Variable_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration - | Iir_Kind_Terminal_Declaration => + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Group_Template_Declaration => Disp_Name_Of (Name); when others => Error_Kind ("disp_name", Name); @@ -438,6 +450,8 @@ package body Disp_Vhdl is if Get_Kind (Base_Type) = Iir_Kind_Floating_Type_Definition then Disp_Tolerance_Opt (Def); end if; + when Iir_Kind_Access_Type_Definition => + Disp_Type (Get_Type_Mark (Def)); when Iir_Kind_Array_Type_Definition => Disp_Array_Element_Constraint (Def, Type_Mark); when Iir_Kind_Record_Type_Definition => @@ -534,6 +548,9 @@ package body Disp_Vhdl is Disp_Int64 (Get_Value (Lit)); when Iir_Kind_Physical_Fp_Literal => Disp_Fp64 (Get_Fp_Value (Lit)); + when Iir_Kind_Unit_Declaration => + Disp_Identifier (Lit); + return; when others => Error_Kind ("disp_physical_literal", Lit); end case; @@ -737,7 +754,8 @@ package body Disp_Vhdl is | Iir_Kind_Integer_Type_Definition => raise Program_Error; when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition => + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition => Disp_Subtype_Indication (A_Type); when Iir_Kind_Array_Subtype_Definition => Disp_Subtype_Indication (A_Type); @@ -1197,23 +1215,67 @@ package body Disp_Vhdl is Put_Line (";"); end Disp_Attribute_Declaration; + procedure Disp_Attribute_Value (Attr : Iir) is + begin + Disp_Name_Of (Get_Designated_Entity (Attr)); + Put ("'"); + Disp_Identifier + (Get_Attribute_Designator (Get_Attribute_Specification (Attr))); + end Disp_Attribute_Value; + procedure Disp_Entity_Kind (Tok : Tokens.Token_Type) is begin Put (Tokens.Image (Tok)); end Disp_Entity_Kind; + procedure Disp_Signature (Sig : Iir) + is + List : Iir_List; + El : Iir; + begin + Disp_Name (Get_Prefix (Sig)); + Put (" ["); + List := Get_Type_Marks_List (Sig); + if List /= Null_Iir_List then + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if I /= 0 then + Put (", "); + end if; + Disp_Name (El); + end loop; + end if; + El := Get_Return_Type (Sig); + if El /= Null_Iir then + Put (" return "); + Disp_Type (El); + end if; + Put ("]"); + end Disp_Signature; + procedure Disp_Entity_Name_List (List : Iir_List) is El : Iir; begin - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - if I /= 0 then - Put (", "); - end if; - Disp_Name_Of (El); - end loop; + if List = Iir_List_All then + Put ("all"); + elsif List = Iir_List_Others then + Put ("others"); + else + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if I /= 0 then + Put (", "); + end if; + if Get_Kind (El) = Iir_Kind_Signature then + Disp_Signature (El); + else + Disp_Name_Of (El); + end if; + end loop; + end if; end Disp_Entity_Name_List; procedure Disp_Attribute_Specification (Attr : Iir_Attribute_Specification) @@ -1243,6 +1305,45 @@ package body Disp_Vhdl is Put_Line ("end protected body;"); end Disp_Protected_Type_Body; + procedure Disp_Group_Template_Declaration (Decl : Iir) + is + Ent : Iir; + begin + Put ("group "); + Disp_Identifier (Decl); + Put (" is ("); + Ent := Get_Entity_Class_Entry_Chain (Decl); + loop + Disp_Entity_Kind (Get_Entity_Class (Ent)); + Ent := Get_Chain (Ent); + exit when Ent = Null_Iir; + Put (", "); + end loop; + Put_Line (");"); + end Disp_Group_Template_Declaration; + + procedure Disp_Group_Declaration (Decl : Iir) + is + List : Iir_List; + El : Iir; + begin + Put ("group "); + Disp_Identifier (Decl); + Put (" : "); + Disp_Name (Get_Group_Template_Name (Decl)); + Put (" ("); + List := Get_Group_Constituent_List (Decl); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if I /= 0 then + Put (", "); + end if; + Disp_Name_Of (El); + end loop; + Put_Line (");"); + end Disp_Group_Declaration; + procedure Disp_Declaration_Chain (Parent : Iir; Indent: Count) is Decl: Iir; @@ -1298,6 +1399,10 @@ package body Disp_Vhdl is Disp_Attribute_Specification (Decl); when Iir_Kinds_Signal_Attribute => null; + when Iir_Kind_Group_Template_Declaration => + Disp_Group_Template_Declaration (Decl); + when Iir_Kind_Group_Declaration => + Disp_Group_Declaration (Decl); when others => Error_Kind ("disp_declaration_chain", Decl); end case; @@ -1701,6 +1806,18 @@ package body Disp_Vhdl is Put_Line ("end process;"); end Disp_Process_Statement; + procedure Disp_Conversion (Conv : Iir) is + begin + case Get_Kind (Conv) is + when Iir_Kind_Function_Call => + Disp_Function_Name (Get_Implementation (Conv)); + when Iir_Kind_Type_Conversion => + Disp_Name_Of (Get_Type_Mark (Conv)); + when others => + Error_Kind ("disp_conversion", Conv); + end case; + end Disp_Conversion; + procedure Disp_Association_Chain (Chain : Iir) is El: Iir; @@ -1723,7 +1840,7 @@ package body Disp_Vhdl is if Get_Kind (El) = Iir_Kind_Association_Element_By_Expression then Conv := Get_Out_Conversion (El); if Conv /= Null_Iir then - Disp_Function_Name (Conv); + Disp_Conversion (Conv); Put (" ("); end if; else @@ -1742,7 +1859,7 @@ package body Disp_Vhdl is else Conv := Get_In_Conversion (El); if Conv /= Null_Iir then - Disp_Function_Name (Conv); + Disp_Conversion (Conv); Put (" ("); end if; Disp_Expression (Get_Actual (El)); @@ -1874,8 +1991,11 @@ package body Disp_Vhdl is Assoc: Iir; Expr : Iir; begin - Put ("("); Indent := Col; + if Indent > 70 then + Indent := 3; + end if; + Put ("("); Assoc := Get_Association_Choices_Chain (Aggr); loop Expr := Get_Associated (Assoc); @@ -2002,8 +2122,18 @@ package body Disp_Vhdl is end if; when Iir_Kind_Unit_Declaration => Disp_Name_Of (Expr); + when Iir_Kind_Character_Literal => + Disp_Identifier (Expr); when Iir_Kind_Enumeration_Literal => Disp_Name_Of (Expr); + when Iir_Kind_Overflow_Literal => + Orig := Get_Literal_Origin (Expr); + if Orig /= Null_Iir then + Disp_Expression (Orig); + else + Put ("*OVERFLOW*"); + end if; + when Iir_Kind_Object_Alias_Declaration => Disp_Name_Of (Expr); when Iir_Kind_Aggregate => @@ -2011,7 +2141,15 @@ package body Disp_Vhdl is when Iir_Kind_Null_Literal => Put ("null"); when Iir_Kind_Simple_Aggregate => - Disp_Simple_Aggregate (Expr); + Orig := Get_Literal_Origin (Expr); + if Orig /= Null_Iir then + Disp_Expression (Orig); + else + Disp_Simple_Aggregate (Expr); + end if; + + when Iir_Kind_Attribute_Value => + Disp_Attribute_Value (Expr); when Iir_Kind_Element_Declaration => Disp_Name_Of (Expr); @@ -2087,6 +2225,8 @@ package body Disp_Vhdl is when Iir_Kind_Stable_Attribute => Disp_Parametered_Attribute ("stable", Expr); + when Iir_Kind_Quiet_Attribute => + Disp_Parametered_Attribute ("quiet", Expr); when Iir_Kind_Delayed_Attribute => Disp_Parametered_Attribute ("delayed", Expr); when Iir_Kind_Transaction_Attribute => @@ -2098,6 +2238,12 @@ package body Disp_Vhdl is when Iir_Kind_Active_Attribute => Disp_Expression (Get_Prefix (Expr)); Put ("'active"); + when Iir_Kind_Driving_Attribute => + Disp_Expression (Get_Prefix (Expr)); + Put ("'driving"); + when Iir_Kind_Driving_Value_Attribute => + Disp_Expression (Get_Prefix (Expr)); + Put ("'driving_value"); when Iir_Kind_Last_Value_Attribute => Disp_Expression (Get_Prefix (Expr)); Put ("'last_value"); @@ -2136,6 +2282,8 @@ package body Disp_Vhdl is when Iir_Kind_Image_Attribute => Disp_Parametered_Attribute ("image", Expr); + when Iir_Kind_Value_Attribute => + Disp_Parametered_Attribute ("value", Expr); when Iir_Kind_Simple_Name_Attribute => Disp_Name_Of (Get_Prefix (Expr)); Put ("'simple_name"); diff --git a/errorout.adb b/errorout.adb index 88b78b22f..588162bc6 100644 --- a/errorout.adb +++ b/errorout.adb @@ -390,6 +390,8 @@ package body Errorout is return "record element constraint"; when Iir_Kind_Null_Literal => return "null literal"; + when Iir_Kind_Overflow_Literal => + return Disp_Node (Get_Literal_Origin (Node)); when Iir_Kind_Aggregate => return "aggregate"; when Iir_Kind_Unit_Declaration => diff --git a/evaluation.adb b/evaluation.adb index 0e5557a8b..a30b1bf37 100644 --- a/evaluation.adb +++ b/evaluation.adb @@ -167,6 +167,18 @@ package body Evaluation is return Res; end Build_Simple_Aggregate; + function Build_Overflow (Origin : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Overflow_Literal); + Location_Copy (Res, Origin); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Overflow; + function Build_Constant (Val : Iir; Origin : Iir) return Iir is Res : Iir; @@ -222,8 +234,8 @@ package body Evaluation is Res := Create_Iir (Iir_Kind_Simple_Aggregate); Set_Simple_Aggregate_List (Res, Get_Simple_Aggregate_List (Val)); - when Iir_Kind_Error => - return Val; + when Iir_Kind_Overflow_Literal => + Res := Create_Iir (Iir_Kind_Overflow_Literal); when others => Error_Kind ("build_constant", Val); @@ -286,9 +298,7 @@ package body Evaluation is begin -- The left limit must be locally static in order to compute the right -- limit. - if Get_Type_Staticness (A_Type) /= Locally then - raise Internal_Error; - end if; + pragma Assert (Get_Type_Staticness (A_Type) = Locally); Index_Constraint := Get_Range_Constraint (A_Type); Constraint := Create_Iir (Iir_Kind_Range_Expression); @@ -306,9 +316,7 @@ package body Evaluation is is Res : Iir; begin - if Get_Type_Staticness (A_Type) /= Locally then - raise Internal_Error; - end if; + pragma Assert (Get_Type_Staticness (A_Type) = Locally); case Get_Kind (A_Type) is when Iir_Kind_Enumeration_Type_Definition => @@ -438,6 +446,11 @@ package body Evaluation is Func : Iir_Predefined_Functions; begin + if Get_Kind (Operand) = Iir_Kind_Overflow_Literal then + -- Propagate overflow. + return Build_Overflow (Orig); + end if; + Func := Get_Implicit_Definition (Get_Implementation (Orig)); case Func is when Iir_Predefined_Integer_Negation => @@ -499,8 +512,9 @@ package body Evaluation is end case; exception when Constraint_Error => - Error_Msg_Sem ("arithmetic overflow in static expression", Orig); - return Orig; + -- Can happen for absolute. + Warning_Msg_Sem ("arithmetic overflow in static expression", Orig); + return Build_Overflow (Orig); end Eval_Monadic_Operator; function Eval_Dyadic_Bit_Array_Operator @@ -517,8 +531,8 @@ package body Evaluation is begin Len := Get_String_Length (Left); if Len /= Get_String_Length (Right) then - Error_Msg_Sem ("length of left and right operands mismatch", Expr); - return Left; + Warning_Msg_Sem ("length of left and right operands mismatch", Expr); + return Build_Overflow (Expr); else Id := Start; case Func is @@ -620,7 +634,7 @@ package body Evaluation is is begin if Get_Value (Val) = 0 then - Error_Msg_Sem ("division by 0", Expr); + Warning_Msg_Sem ("division by 0", Expr); return False; else return True; @@ -880,10 +894,10 @@ package body Evaluation is pragma Unsuppress (Overflow_Check); Func : Iir_Predefined_Functions; begin - if Get_Kind (Left) = Iir_Kind_Error - or else Get_Kind (Right) = Iir_Kind_Error + if Get_Kind (Left) = Iir_Kind_Overflow_Literal + or else Get_Kind (Right) = Iir_Kind_Overflow_Literal then - return Create_Error_Expr (Orig, Get_Type (Orig)); + return Build_Overflow (Orig); end if; Func := Get_Implicit_Definition (Get_Implementation (Orig)); @@ -899,21 +913,21 @@ package body Evaluation is return Build_Integer (Get_Value (Left) / Get_Value (Right), Orig); else - return Null_Iir; + return Build_Overflow (Orig); end if; when Iir_Predefined_Integer_Mod => if Check_Integer_Division_By_Zero (Orig, Right) then return Build_Integer (Get_Value (Left) mod Get_Value (Right), Orig); else - return Null_Iir; + return Build_Overflow (Orig); end if; when Iir_Predefined_Integer_Rem => if Check_Integer_Division_By_Zero (Orig, Right) then return Build_Integer (Get_Value (Left) rem Get_Value (Right), Orig); else - return Null_Iir; + return Build_Overflow (Orig); end if; when Iir_Predefined_Integer_Exp => return Build_Integer @@ -969,8 +983,8 @@ package body Evaluation is (Get_Fp_Value (Left) * Get_Fp_Value (Right), Orig); when Iir_Predefined_Floating_Div => if Get_Fp_Value (Right) = 0.0 then - Error_Msg_Sem ("right operand of division is 0", Orig); - return Build_Floating (0.0, Orig); + Warning_Msg_Sem ("right operand of division is 0", Orig); + return Build_Overflow (Orig); else return Build_Floating (Get_Fp_Value (Left) / Get_Fp_Value (Right), Orig); @@ -1290,8 +1304,8 @@ package body Evaluation is end case; exception when Constraint_Error => - Error_Msg_Sem ("arithmetic overflow in static expression", Orig); - return Null_Iir; + Warning_Msg_Sem ("arithmetic overflow in static expression", Orig); + return Build_Overflow (Orig); end Eval_Dyadic_Operator; -- Evaluate any array attribute, return the type for the prefix. @@ -1467,42 +1481,43 @@ package body Evaluation is function Build_Enumeration_Value (Val : String; Enum, Expr : Iir) return Iir is - Value : String(Val'range); - List : constant Iir_List := Get_Enumeration_Literal_List(Enum); + Value : String (Val'range); + List : constant Iir_List := Get_Enumeration_Literal_List (Enum); begin - for i in Val'range loop - Value(i) := Ada.Characters.Handling.To_Lower (Val(i)); + for I in Val'range loop + Value (I) := Ada.Characters.Handling.To_Lower (Val (I)); end loop; - for i in 0 .. Get_Nbr_Elements(List) - 1 loop - if Value = Image_Identifier(Get_Nth_Element(List, i)) then - return Build_Discrete(Iir_Int64(i), Expr); + for I in 0 .. Get_Nbr_Elements (List) - 1 loop + if Value = Image_Identifier (Get_Nth_Element (List, I)) then + return Build_Enumeration (Iir_Index32 (I), Expr); end if; end loop; - Error_Msg_Sem ("value """ & Value & """ not in enumeration", Expr); - return Null_Iir; + Warning_Msg_Sem ("value """ & Value & """ not in enumeration", Expr); + return Build_Overflow (Expr); end Build_Enumeration_Value; function Eval_Physical_Image (Phys, Expr: Iir) return Iir - -- reduces to the base unit (e.g. femtoseconds) is - Value : constant String := Iir_Int64'image( - Get_Physical_Literal_Value(Phys)); - Unit : constant Iir := Get_Primary_Unit (Get_Base_Type (Get_Type(Phys))); + -- Reduces to the base unit (e.g. femtoseconds). + Value : constant String := + Iir_Int64'Image (Get_Physical_Literal_Value (Phys)); + Unit : constant Iir := + Get_Primary_Unit (Get_Base_Type (Get_Type (Phys))); UnitName : constant String := Image_Identifier (Unit); Image_Id : constant String_Id := Str_Table.Start; Length : Nat32 := Value'Length + UnitName'Length + 1; begin - for i in Value'range loop + for I in Value'range loop -- Suppress the Ada +ve integer'image leading space - if i > Value'first or else Value(i) /= ' ' then - Str_Table.Append(Value(i)); + if I > Value'first or else Value (I) /= ' ' then + Str_Table.Append (Value (I)); else Length := Length - 1; end if; end loop; - Str_Table.Append(' '); - for i in UnitName'range loop - Str_Table.Append(UnitName(i)); + Str_Table.Append (' '); + for I in UnitName'range loop + Str_Table.Append (UnitName (I)); end loop; Str_Table.Finish; @@ -1551,9 +1566,9 @@ package body Evaluation is Unit := Get_Chain (Unit); end loop; if Unit = Null_Iir then - Error_Msg_Sem ("Unit """ & UnitName (Sep + 1 .. UnitName'Last) + Warning_Msg_Sem ("Unit """ & UnitName (Sep + 1 .. UnitName'Last) & """ not in physical type", Expr); - return Null_Iir; + return Build_Overflow (Expr); end if; Mult := Get_Value (Get_Physical_Unit_Value (Unit)); @@ -1578,8 +1593,8 @@ package body Evaluation is when Iir_Kind_Enumeration_Literal => P := Iir_Int64 (Get_Enum_Pos (Expr)) + N; if P < 0 then - Error_Msg_Sem ("static constant violates bounds", Expr); - return Expr; + Warning_Msg_Sem ("static constant violates bounds", Expr); + return Build_Overflow (Expr); else return Build_Enumeration (Iir_Index32 (P), Expr); end if; @@ -1645,7 +1660,9 @@ package body Evaluation is if Eval_Discrete_Type_Length (Conv_Index_Type) /= Eval_Discrete_Type_Length (Val_Index_Type) then - Error_Msg_Sem ("non matching length in type convertion", Conv); + Warning_Msg_Sem + ("non matching length in type conversion", Conv); + return Build_Overflow (Conv); end if; return Res; when Iir_Kind_Array_Type_Definition => @@ -1721,7 +1738,8 @@ package body Evaluation is | Iir_Kind_Enumeration_Literal | Iir_Kind_Floating_Point_Literal | Iir_Kind_String_Literal - | Iir_Kind_Bit_String_Literal => + | Iir_Kind_Bit_String_Literal + | Iir_Kind_Overflow_Literal => return Expr; when Iir_Kind_Physical_Int_Literal => if Get_Unit_Name (Expr) @@ -1814,9 +1832,9 @@ package body Evaluation is and then not Eval_Int_In_Range (Val, Get_Range_Constraint (Expr_Type)) then - Error_Msg_Sem + Warning_Msg_Sem ("static argument out of the type range", Expr); - Val := 0; + return Build_Overflow (Expr); end if; if Get_Kind (Get_Base_Type (Get_Type (Expr))) = Iir_Kind_Physical_Type_Definition @@ -1857,8 +1875,9 @@ package body Evaluation is Param := Eval_Static_Expr (Param); Set_Parameter (Expr, Param); if Get_Kind (Param) /= Iir_Kind_String_Literal then - Error_Msg_Sem ("'value argument not a string", Expr); - return Null_Iir; -- or Expr? + -- FIXME: Isn't it an implementation restriction. + Warning_Msg_Sem ("'value argument not a string", Expr); + return Build_Overflow (Expr); else -- what type are we converting the string to? Param_Type := Get_Base_Type (Get_Type (Expr)); @@ -2194,6 +2213,9 @@ package body Evaluation is if Get_Kind (Expr) = Iir_Kind_Error then return True; end if; + if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then + return False; + end if; case Get_Kind (Sub_Type) is when Iir_Kind_Integer_Subtype_Definition => @@ -2235,9 +2257,13 @@ package body Evaluation is end case; end Eval_Is_In_Bound; - procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir) - is + procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir) is begin + if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then + -- Nothing to check, and a message was already generated. + return; + end if; + if not Eval_Is_In_Bound (Expr, Sub_Type) then Error_Msg_Sem ("static constant violates bounds", Expr); end if; @@ -2307,10 +2333,6 @@ package body Evaluation is -- 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); - exception - when Node_Error => - -- Avoid error storms. - return True; end Eval_Is_Range_In_Bound; procedure Eval_Check_Range @@ -2382,8 +2404,6 @@ package body Evaluation is return Get_Physical_Value (Expr); when Iir_Kind_Unit_Declaration => return Get_Value (Get_Physical_Unit_Value (Expr)); - when Iir_Kind_Error => - raise Node_Error; when others => Error_Kind ("eval_pos", Expr); end case; @@ -2513,7 +2533,6 @@ package body Evaluation is -- end if; end Eval_Simple_Name; - function Compare_String_Literals (L, R : Iir) return Compare_Type is type Str_Info is record diff --git a/iirs.adb b/iirs.adb index 7de512390..539a1d672 100644 --- a/iirs.adb +++ b/iirs.adb @@ -334,6 +334,7 @@ package body Iirs is | Iir_Kind_Null_Literal | Iir_Kind_String_Literal | Iir_Kind_Simple_Aggregate + | Iir_Kind_Overflow_Literal | Iir_Kind_Proxy | Iir_Kind_Waveform_Element | Iir_Kind_Conditional_Waveform @@ -1262,6 +1263,7 @@ package body Iirs is | Iir_Kind_Physical_Fp_Literal | Iir_Kind_Bit_String_Literal | Iir_Kind_Simple_Aggregate + | Iir_Kind_Overflow_Literal | Iir_Kind_Enumeration_Literal => null; when others => @@ -2309,6 +2311,7 @@ package body Iirs is | Iir_Kind_Physical_Fp_Literal | Iir_Kind_Bit_String_Literal | Iir_Kind_Simple_Aggregate + | Iir_Kind_Overflow_Literal | Iir_Kind_Attribute_Value | Iir_Kind_Record_Element_Constraint | Iir_Kind_Disconnection_Specification @@ -5856,6 +5859,7 @@ package body Iirs is | Iir_Kind_Physical_Fp_Literal | Iir_Kind_Bit_String_Literal | Iir_Kind_Simple_Aggregate + | Iir_Kind_Overflow_Literal | Iir_Kind_Attribute_Value | Iir_Kind_Range_Expression | Iir_Kind_Unit_Declaration diff --git a/iirs.ads b/iirs.ads index 34e86891d..21e05a40e 100644 --- a/iirs.ads +++ b/iirs.ads @@ -300,6 +300,16 @@ package Iirs is -- List of elements -- Get/Set_Simple_Aggregate_List (Field3) + -- Iir_Kind_Overflow_Literal (Short) + -- This node can only be generated by evaluation to represent an error: out + -- of range, division by zero... + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Literal_Origin (Field2) + -- + -- Get/Set_Expr_Staticness (State1) + ------------ -- Tuples -- ------------ @@ -557,10 +567,10 @@ package Iirs is -- -- Get/Set_Type (Field1) -- - -- Get/Set_Prefix (Field3) - -- -- Get/Set_Selected_Element (Field2) -- + -- Get/Set_Prefix (Field3) + -- -- Get/Set_Base_Name (Field5) -- -- Get/Set_Expr_Staticness (State1) @@ -2565,10 +2575,10 @@ package Iirs is -- -- Get/Set_Type (Field1) -- - -- Get/Set_Prefix (Field3) - -- -- Get/Set_Suffix (Field2) -- + -- Get/Set_Prefix (Field3) + -- -- Get/Set_Base_Name (Field5) -- -- Get/Set_Expr_Staticness (State1) @@ -2583,11 +2593,11 @@ package Iirs is -- Always returns null_iir. -- Get/Set_Type (Field1) -- + -- Get/Set_Association_Chain (Field2) + -- -- Get/Set_Prefix (Field3) -- -- Get/Set_Named_Entity (Field4) - -- - -- Get/Set_Association_Chain (Field2) ---------------- -- attributes -- @@ -2595,12 +2605,12 @@ package Iirs is -- Iir_Kind_Attribute_Name (Short) -- + -- Get/Set_Type (Field1) + -- -- Get/Set_Attribute_Identifier (Field2) -- -- Get/Set_Prefix (Field3) -- - -- Get/Set_Type (Field1) - -- -- Get/Set_Named_Entity (Field4) -- -- Get/Set_Signature (Field5) @@ -2731,11 +2741,11 @@ package Iirs is -- -- Get/Set_Type (Field1) -- - -- Get/Set_Prefix (Field3) - -- -- Only for Iir_Kind_Simple_Name_Attribute: -- Get/Set_Simple_Name_Identifier (Field2) -- + -- Get/Set_Prefix (Field3) + -- -- Get/Set_Base_Name (Field5) -- -- Get/Set_Expr_Staticness (State1) @@ -2790,6 +2800,7 @@ package Iirs is Iir_Kind_Physical_Fp_Literal, Iir_Kind_Bit_String_Literal, Iir_Kind_Simple_Aggregate, + Iir_Kind_Overflow_Literal, -- Tuple, Iir_Kind_Proxy, diff --git a/iirs_utils.adb b/iirs_utils.adb index e62596419..8bbaf9b16 100644 --- a/iirs_utils.adb +++ b/iirs_utils.adb @@ -652,6 +652,20 @@ package body Iirs_Utils is end case; end Get_Block_From_Block_Specification; + function Get_Entity_Identifier_Of_Architecture (Arch : Iir) return Name_Id + is + Name : constant Iir := Get_Entity_Name (Arch); + begin + case Get_Kind (Name) is + when Iir_Kind_Simple_Name => + return Get_Identifier (Name); + when Iir_Kind_Selected_Name => + return Get_Suffix_Identifier (Name); + when others => + Error_Kind ("get_entity_identifier_of_architecture", Name); + end case; + end Get_Entity_Identifier_Of_Architecture; + function Get_String_Type_Bound_Type (Sub_Type : Iir) return Iir is begin if Get_Kind (Sub_Type) /= Iir_Kind_Array_Subtype_Definition then diff --git a/iirs_utils.ads b/iirs_utils.ads index b628aec8d..fb3e1b45f 100644 --- a/iirs_utils.ads +++ b/iirs_utils.ads @@ -101,6 +101,9 @@ package Iirs_Utils is function Get_Block_From_Block_Specification (Block_Spec : Iir) return Iir; + -- Return the identifier of the entity for architecture ARCH. + function Get_Entity_Identifier_Of_Architecture (Arch : Iir) return Name_Id; + -- Return the bound type of a string type, ie the type of the (first) -- dimension of a one-dimensional array type. function Get_String_Type_Bound_Type (Sub_Type : Iir) return Iir; diff --git a/libraries.adb b/libraries.adb index 2976464a3..e37689ca6 100644 --- a/libraries.adb +++ b/libraries.adb @@ -20,7 +20,7 @@ with GNAT.Table; with GNAT.OS_Lib; with Errorout; use Errorout; with Scanner; -with Iirs_Utils; +with Iirs_Utils; use Iirs_Utils; with Parse; with Back_End; with Name_Table; use Name_Table; @@ -147,7 +147,7 @@ package body Libraries is Id := Get_Identifier (Lib_Unit); when Iir_Kind_Architecture_Body => -- Architectures are put with the entity identifier. - Id := Get_Identifier (Get_Entity (Lib_Unit)); + Id := Get_Entity_Identifier_Of_Architecture (Lib_Unit); when others => Error_Kind ("get_Hash_Id_For_Unit", Lib_Unit); end case; @@ -268,7 +268,6 @@ package body Libraries is is use Scanner; use Tokens; - use Iirs_Utils; File : Source_File_Entry; @@ -506,7 +505,7 @@ package body Libraries is if Get_Kind (Library_Unit) = Iir_Kind_Architecture_Body then Scan_Expect (Tok_Of); Scan_Expect (Tok_Identifier); - Set_Entity (Library_Unit, Current_Text); + Set_Entity_Name (Library_Unit, Current_Text); end if; -- Scan position. @@ -673,49 +672,6 @@ package body Libraries is Set_Visible_Flag (Work_Library, True); end Load_Work_Library; --- procedure Unload_Library (Library : Iir_Library_Declaration) --- is --- File : Iir_Design_File; --- Unit : Iir_Design_Unit; --- begin --- loop --- File := Get_Design_File_Chain (Library); --- exit when File = Null_Iir; --- Set_Design_File_Chain (Library, Get_Chain (File)); - --- loop --- Unit := Get_Design_Unit_Chain (File); --- exit when Unit = Null_Iir; --- Set_Design_Unit_Chain (File, Get_Chain (Unit)); - --- -- Units should not be loaded. --- if Get_Loaded_Flag (Unit) then --- raise Internal_Error; --- end if; - --- -- Free dependences list. --- end loop; --- end loop; --- end Unload_Library; - --- procedure Unload_All_Libraries --- is --- Library : Iir_Library_Declaration; --- begin --- if Get_Identifier (Std_Library) /= Name_Std then --- raise Internal_Error; --- end if; --- if Std_Library /= Libraries_Chain then --- raise Internal_Error; --- end if; --- loop --- Library := Get_Chain (Libraries_Chain); --- exit when Library = Null_Iir; --- Set_Chain (Libraries_Chain, Get_Chain (Libraries_Chain)); --- Unload_Library (Library); --- end loop; --- end Unload_All_Libraries; - -- Get or create a library from an identifier. function Get_Library (Ident: Name_Id; Loc : Location_Type) return Iir_Library_Declaration @@ -791,8 +747,8 @@ package body Libraries is if Unit_Kind = Iir_Kind_Architecture_Body and then Library_Unit_Kind = Iir_Kind_Architecture_Body then - Entity_Name1 := Get_Identifier (Get_Entity (Unit)); - Entity_Name2 := Get_Identifier (Get_Entity (Library_Unit)); + Entity_Name1 := Get_Entity_Identifier_Of_Architecture (Unit); + Entity_Name2 := Get_Entity_Identifier_Of_Architecture (Library_Unit); if Entity_Name1 /= Entity_Name2 then return False; end if; @@ -1123,7 +1079,6 @@ package body Libraries is -- Save the file map of library LIBRARY. procedure Save_Library (Library: Iir_Library_Declaration) is use GNAT.OS_Lib; - use Iirs_Utils; Temp_Name : String_Access; FD : File_Descriptor; Success : Boolean; @@ -1223,7 +1178,8 @@ package body Libraries is WR ("architecture "); WR (Image_Identifier (Library_Unit)); WR (" of "); - WR (Image_Identifier (Get_Entity (Library_Unit))); + WR (Image (Get_Entity_Identifier_Of_Architecture + (Library_Unit))); when Iir_Kind_Package_Declaration | Iir_Kind_Package_Instantiation_Declaration => WR ("package "); @@ -1327,7 +1283,8 @@ package body Libraries is Library_Unit := Get_Library_Unit (Design_Unit); if Get_Kind (Library_Unit) = Iir_Kind_Architecture_Body - and then Get_Identifier (Get_Entity (Library_Unit)) = Entity_Id + and then + Get_Entity_Identifier_Of_Architecture (Library_Unit) = Entity_Id then if Res = Null_Iir then Res := Design_Unit; @@ -1616,7 +1573,6 @@ package body Libraries is Design_Unit: Iir_Design_Unit; Library_Unit: Iir; Primary_Ident: Name_Id; - Ident: Name_Id; Lib_Prim : Iir; begin Lib_Prim := Get_Library (Get_Design_File (Primary)); @@ -1634,8 +1590,8 @@ package body Libraries is -- The entity field can be either an identifier (if the -- library unit was not loaded) or an access to the entity -- unit. - Ident := Get_Identifier (Get_Entity (Library_Unit)); - if Ident = Primary_Ident + if (Get_Entity_Identifier_Of_Architecture (Library_Unit) + = Primary_Ident) and then Get_Identifier (Library_Unit) = Name then return Design_Unit; diff --git a/parse.adb b/parse.adb index 51e04e0a8..22a536ca8 100644 --- a/parse.adb +++ b/parse.adb @@ -3435,11 +3435,6 @@ package body Parse is Location_Copy (A_Choice, Expr1); Set_Expression (A_Choice, Parse_Range_Right (Expr1)); return A_Choice; --- elsif Get_Kind (Expr1) in Iir_Kinds_Name then --- A_Choice := Create_Iir (Iir_Kind_Choice_By_Name); --- Location_Copy (A_Choice, Expr1); --- Set_Name (A_Choice, Parse_Range_Type_Expression (Expr1)); --- return A_Choice; else A_Choice := Create_Iir (Iir_Kind_Choice_By_Expression); Location_Copy (A_Choice, Expr1); diff --git a/sem_decls.adb b/sem_decls.adb index 6b299f59a..da485f8da 100644 --- a/sem_decls.adb +++ b/sem_decls.adb @@ -1987,8 +1987,8 @@ package body Sem_Decls is /= Eval_Discrete_Type_Length (Get_Nth_Element (Get_Index_Subtype_List (Name_Type), 0)) then - Error_Msg_Sem ("number of elements not matching in type and name", - Alias); + Error_Msg_Sem + ("number of elements not matching in type and name", Alias); end if; end if; diff --git a/sem_expr.adb b/sem_expr.adb index 11caf3545..47764bf12 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -2062,7 +2062,11 @@ package body Sem_Expr is end if; Expr := Eval_Expr (Expr); Set_Expression (Choice, Expr); - if Eval_Discrete_Type_Length + if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then + Error_Msg_Sem + ("bound error during evaluation of choice expression", Expr); + Has_Length_Error := True; + elsif Eval_Discrete_Type_Length (Get_String_Type_Bound_Type (Get_Type (Expr))) /= Sel_Length then Has_Length_Error := True; @@ -2769,6 +2773,8 @@ package body Sem_Expr is Set_Name (N_El, Aggr_El); Set_Associated (N_El, Get_Associated (Ass)); Set_Chain (N_El, Get_Chain (Ass)); + Set_Same_Alternative_Flag (N_El, Get_Same_Alternative_Flag (Ass)); + Xref_Ref (Expr, Aggr_El); Free_Old_Iir (Ass); Add_Match (N_El, Aggr_El); @@ -3563,7 +3569,8 @@ package body Sem_Expr is | Iir_Kind_Floating_Point_Literal | Iir_Kind_Null_Literal | Iir_Kind_Unit_Declaration - | Iir_Kind_Simple_Aggregate => + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Overflow_Literal => return; when Iir_Kinds_Monadic_Operator | Iir_Kinds_Dyadic_Operator diff --git a/sem_stmts.adb b/sem_stmts.adb index 30ea99cae..a62890a55 100644 --- a/sem_stmts.adb +++ b/sem_stmts.adb @@ -739,7 +739,7 @@ package body Sem_Stmts is end if; end if; if not Check_Implicit_Conversion (Get_Type (Target), Expr) then - Error_Msg_Sem + Warning_Msg_Sem ("expression length does not match target length", Stmt); end if; end Sem_Variable_Assignment; diff --git a/sem_types.adb b/sem_types.adb index e7f8c97b4..ffa426809 100644 --- a/sem_types.adb +++ b/sem_types.adb @@ -1884,6 +1884,7 @@ package body Sem_Types is Res := Create_Iir (Iir_Kind_Access_Subtype_Definition); Location_Copy (Res, Def); Set_Base_Type (Res, Type_Mark); + Set_Type_Mark (Res, Base_Type); Set_Signal_Type_Flag (Res, False); Free_Old_Iir (Def); return Res; @@ -2001,9 +2002,12 @@ package body Sem_Types is Set_Type_Mark (Res, Def); Set_Range_Constraint (Res, Get_Range_Constraint (Def)); - when Iir_Kind_Access_Subtype_Definition - | Iir_Kind_Access_Type_Definition => + when Iir_Kind_Access_Subtype_Definition => Res := Create_Iir (Iir_Kind_Access_Subtype_Definition); + Set_Type_Mark (Res, Get_Type_Mark (Def)); + when Iir_Kind_Access_Type_Definition => + Res := Create_Iir (Iir_Kind_Access_Subtype_Definition); + Set_Type_Mark (Res, Get_Designated_Type (Def)); when Iir_Kind_Array_Type_Definition => Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); @@ -2035,7 +2039,8 @@ package body Sem_Types is end if; Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); Set_Constraint_State (Res, Get_Constraint_State (Def)); - + Set_Elements_Declaration_List + (Res, Get_Elements_Declaration_List (Def)); when others => -- FIXME: todo Error_Kind ("copy_subtype_indication", Def); diff --git a/testsuite/vests/testsuite.sh b/testsuite/vests/testsuite.sh index f8fb1555e..2eb281f8d 100755 --- a/testsuite/vests/testsuite.sh +++ b/testsuite/vests/testsuite.sh @@ -150,6 +150,11 @@ run_compliant_test () handle_test run $@ } +run_err_non_compliant_test () +{ + handle_test run_err $@ +} + # Decode options. skip=0 diff --git a/testsuite/vests/vhdl-93/billowitch/non_compliant/analyzer_failure/non_compliant.exp b/testsuite/vests/vhdl-93/billowitch/non_compliant/analyzer_failure/non_compliant.exp index cac6b02a6..81e3932ce 100644 --- a/testsuite/vests/vhdl-93/billowitch/non_compliant/analyzer_failure/non_compliant.exp +++ b/testsuite/vests/vhdl-93/billowitch/non_compliant/analyzer_failure/non_compliant.exp @@ -611,7 +611,7 @@ run_non_compliant_test tc1407.vhd run_non_compliant_test tc1408.vhd run_non_compliant_test tc1411.vhd run_non_compliant_test tc1415.vhd -run_non_compliant_test tc1416.vhd +run_err_non_compliant_test tc1416.vhd run_non_compliant_test tc1417.vhd run_non_compliant_test tc1418.vhd run_non_compliant_test tc1419.vhd @@ -1040,9 +1040,9 @@ run_non_compliant_test tc2250.vhd run_non_compliant_test tc2251.vhd run_non_compliant_test tc2252.vhd run_non_compliant_test tc2253.vhd -run_non_compliant_test tc2254.vhd -run_non_compliant_test tc2255.vhd -run_non_compliant_test tc2256.vhd +run_err_non_compliant_test tc2254.vhd +run_err_non_compliant_test tc2255.vhd +run_err_non_compliant_test tc2256.vhd run_non_compliant_test tc2273.vhd run_non_compliant_test tc2274.vhd run_non_compliant_test tc2275.vhd @@ -1097,7 +1097,7 @@ run_non_compliant_test tc2356.vhd run_non_compliant_test tc2357.vhd run_non_compliant_test tc2358.vhd run_non_compliant_test tc2361.vhd -run_non_compliant_test tc2362.vhd +run_err_non_compliant_test tc2362.vhd run_non_compliant_test tc2375.vhd run_non_compliant_test tc2376.vhd run_non_compliant_test tc2377.vhd diff --git a/translate/ghdldrv/ghdllocal.adb b/translate/ghdldrv/ghdllocal.adb index 7169fa32a..6459f70dd 100644 --- a/translate/ghdldrv/ghdllocal.adb +++ b/translate/ghdldrv/ghdllocal.adb @@ -34,6 +34,7 @@ with Files_Map; with Post_Sems; with Disp_Tree; with Options; +with Iirs_Utils; use Iirs_Utils; package body Ghdllocal is -- Version of the IEEE library to use. This just change pathes. @@ -273,12 +274,12 @@ package body Ghdllocal is case Get_Kind (Unit) is when Iir_Kind_Architecture_Body => Put (" of "); - Image (Get_Identifier (Get_Entity (Unit))); + Image (Get_Entity_Identifier_Of_Architecture (Unit)); Put (Name_Buffer (1 .. Name_Length)); when Iir_Kind_Configuration_Declaration => if Id = Null_Identifier then Put (" of entity "); - Image (Get_Identifier (Get_Library_Unit (Get_Entity (Unit)))); + Image (Get_Entity_Identifier_Of_Architecture (Unit)); Put (Name_Buffer (1 .. Name_Length)); end if; when others => @@ -580,7 +581,7 @@ package body Ghdllocal is return "-s [OPTS] FILEs Check syntax of FILEs"; end Get_Short_Help; - procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean) + function Analyze_One_File (File_Name : String) return Iir_Design_File is use Ada.Text_IO; Id : Name_Id; @@ -588,40 +589,52 @@ package body Ghdllocal is Unit : Iir; Next_Unit : Iir; begin - Setup_Libraries (True); + Id := Name_Table.Get_Identifier (File_Name); + if Flag_Verbose then + Put (File_Name); + Put_Line (":"); + end if; + Design_File := Libraries.Load_File (Id); + if Design_File = Null_Iir then + raise Errorout.Compilation_Error; + end if; - -- Parse all files. - for I in Files'Range loop - Id := Name_Table.Get_Identifier (Files (I).all); + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop if Flag_Verbose then - Put (Files (I).all); - Put_Line (":"); + Put (' '); + Disp_Library_Unit (Get_Library_Unit (Unit)); + New_Line; end if; - Design_File := Libraries.Load_File (Id); - if Design_File /= Null_Iir then - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - if Flag_Verbose then - Put (' '); - Disp_Library_Unit (Get_Library_Unit (Unit)); - New_Line; - end if; - -- Sem, canon, annotate a design unit. - Back_End.Finish_Compilation (Unit, True); + -- Sem, canon, annotate a design unit. + Back_End.Finish_Compilation (Unit, True); - Next_Unit := Get_Chain (Unit); - if Errorout.Nbr_Errors = 0 then - Set_Chain (Unit, Null_Iir); - Libraries.Add_Design_Unit_Into_Library (Unit); - end if; + Next_Unit := Get_Chain (Unit); + if Errorout.Nbr_Errors = 0 then + Set_Chain (Unit, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Unit); + end if; - Unit := Next_Unit; - end loop; + Unit := Next_Unit; + end loop; - if Errorout.Nbr_Errors > 0 then - raise Errorout.Compilation_Error; - end if; - end if; + if Errorout.Nbr_Errors > 0 then + raise Errorout.Compilation_Error; + end if; + + return Design_File; + end Analyze_One_File; + + procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean) + is + Design_File : Iir_Design_File; + pragma Unreferenced (Design_File); + begin + Setup_Libraries (True); + + -- Parse all files. + for I in Files'Range loop + Design_File := Analyze_One_File (Files (I).all); end loop; if Save_Library then @@ -694,7 +707,6 @@ package body Ghdllocal is File : Iir_Design_File; Design_Unit : Iir_Design_Unit; Lib_Unit : Iir; - Ent_Unit : Iir; Str : String_Access; begin if Args'Length /= 0 then @@ -722,10 +734,10 @@ package body Ghdllocal is | Iir_Kind_Configuration_Declaration => Delete_Top_Unit (Image (Get_Identifier (Lib_Unit))); when Iir_Kind_Architecture_Body => - Ent_Unit := Get_Entity (Lib_Unit); - Delete_Top_Unit (Image (Get_Identifier (Ent_Unit)) - & '-' - & Image (Get_Identifier (Lib_Unit))); + Delete_Top_Unit + (Image (Get_Entity_Identifier_Of_Architecture (Lib_Unit)) + & '-' + & Image (Get_Identifier (Lib_Unit))); when others => null; end case; diff --git a/translate/ghdldrv/ghdllocal.ads b/translate/ghdldrv/ghdllocal.ads index 46eff1a14..f197038c3 100644 --- a/translate/ghdldrv/ghdllocal.ads +++ b/translate/ghdldrv/ghdllocal.ads @@ -84,6 +84,10 @@ package Ghdllocal is -- Setup standard libaries path. If LOAD is true, then load them now. procedure Setup_Libraries (Load : Boolean); + -- Analyze file FILE_NAME. Raise Compilation_Error in case of analysis + -- error. + function Analyze_One_File (File_Name : String) return Iir_Design_File; + -- Setup library, analyze FILES, and if SAVE_LIBRARY is set save the -- work library only procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean); diff --git a/translate/ghdldrv/ghdlprint.adb b/translate/ghdldrv/ghdlprint.adb index 0b775760e..214f03009 100644 --- a/translate/ghdldrv/ghdlprint.adb +++ b/translate/ghdldrv/ghdlprint.adb @@ -26,12 +26,14 @@ with Files_Map; with Libraries; with Errorout; use Errorout; with Iirs; use Iirs; +with Iirs_Utils; use Iirs_Utils; with Tokens; with Scanner; with Version; with Xrefs; with Ghdlmain; use Ghdlmain; with Ghdllocal; use Ghdllocal; +with Disp_Vhdl; package body Ghdlprint is type Html_Format_Type is (Html_2, Html_Css); @@ -566,7 +568,7 @@ package body Ghdlprint is when Iir_Kind_Package_Body => Len := Len + 1 + 4; -- add -body when Iir_Kind_Architecture_Body => - Id1 := Get_Identifier (Get_Entity (Lib)); + Id1 := Get_Entity_Identifier_Of_Architecture (Lib); Len := Len + 1 + Get_Name_Length (Id1); when others => Error_Kind ("build_file_name", Lib); @@ -599,7 +601,7 @@ package body Ghdlprint is Append (Name_Buffer (1 .. Name_Length)); Append ("-body"); when Iir_Kind_Architecture_Body => - Image (Get_Identifier (Get_Entity (Lib))); + Image (Get_Entity_Identifier_Of_Architecture (Lib)); Append (Name_Buffer (1 .. Name_Length)); Append ("-"); Image (Id); @@ -938,6 +940,50 @@ package body Ghdlprint is end loop; end Perform_Action; + -- Command Reprint. + type Command_Reprint is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Reprint; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Reprint) return String; + procedure Perform_Action (Cmd : in out Command_Reprint; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Reprint; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--reprint"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Reprint) return String + is + pragma Unreferenced (Cmd); + begin + return "--reprint [OPTS] FILEs Redisplay FILEs"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Reprint; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Design_File : Iir_Design_File; + Unit : Iir; + begin + Setup_Libraries (True); + + -- Parse all files. + for I in Args'Range loop + Design_File := Analyze_One_File (Args (I).all); + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + Disp_Vhdl.Disp_Vhdl (Unit); + Unit := Get_Chain (Unit); + end loop; + end loop; + end Perform_Action; + + -- Command html. type Command_Html is abstract new Command_Lib with null record; procedure Decode_Option (Cmd : in out Command_Html; @@ -1569,6 +1615,7 @@ package body Ghdlprint is begin Register_Command (new Command_Chop); Register_Command (new Command_Lines); + Register_Command (new Command_Reprint); Register_Command (new Command_PP_Html); Register_Command (new Command_Xref_Html); Register_Command (new Command_Xref); diff --git a/translate/ghdldrv/ghdlrun.adb b/translate/ghdldrv/ghdlrun.adb index 676c82824..cded35158 100644 --- a/translate/ghdldrv/ghdlrun.adb +++ b/translate/ghdldrv/ghdlrun.adb @@ -240,8 +240,6 @@ package body Ghdlrun is Def (Trans_Decls.Ghdl_Memcpy, Grt.Lib.Ghdl_Memcpy'Address); - Def (Trans_Decls.Ghdl_Bound_Check_Failed_L0, - Grt.Lib.Ghdl_Bound_Check_Failed_L0'Address); Def (Trans_Decls.Ghdl_Bound_Check_Failed_L1, Grt.Lib.Ghdl_Bound_Check_Failed_L1'Address); Def (Trans_Decls.Ghdl_Malloc0, diff --git a/translate/grt/grt-lib.adb b/translate/grt/grt-lib.adb index fcbbecb64..3c10417aa 100644 --- a/translate/grt/grt-lib.adb +++ b/translate/grt/grt-lib.adb @@ -188,13 +188,6 @@ package body Grt.Lib is Error_E (""); end Ghdl_Program_Error; - procedure Ghdl_Bound_Check_Failed_L0 (Number : Ghdl_Index_Type) is - begin - Error_C ("bound check failed (#"); - Error_C (Integer (Number)); - Error_E (")"); - end Ghdl_Bound_Check_Failed_L0; - procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String; Line: Ghdl_I32) is diff --git a/translate/grt/grt-lib.ads b/translate/grt/grt-lib.ads index 580406dcc..2c75a90e4 100644 --- a/translate/grt/grt-lib.ads +++ b/translate/grt/grt-lib.ads @@ -67,7 +67,6 @@ package Grt.Lib is Error_Severity : constant Integer := 2; Failure_Severity : constant Integer := 3; - procedure Ghdl_Bound_Check_Failed_L0 (Number : Ghdl_Index_Type); procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String; Line: Ghdl_I32); @@ -113,8 +112,6 @@ private pragma Export (C, Ghdl_Psl_Cover_Failed, "__ghdl_psl_cover_failed"); pragma Export (C, Ghdl_Report, "__ghdl_report"); - pragma Export (C, Ghdl_Bound_Check_Failed_L0, - "__ghdl_bound_check_failed_l0"); pragma Export (C, Ghdl_Bound_Check_Failed_L1, "__ghdl_bound_check_failed_l1"); pragma Export (C, Ghdl_Program_Error, "__ghdl_program_error"); diff --git a/translate/trans_decls.ads b/translate/trans_decls.ads index 9226c582c..20cc445fe 100644 --- a/translate/trans_decls.ads +++ b/translate/trans_decls.ads @@ -160,7 +160,6 @@ package Trans_Decls is -- Procedure called in case of check failed. Ghdl_Program_Error : O_Dnode; - Ghdl_Bound_Check_Failed_L0 : O_Dnode; Ghdl_Bound_Check_Failed_L1 : O_Dnode; -- Stack 2. diff --git a/translate/translation.adb b/translate/translation.adb index 270c707cd..98cf8bccd 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -2008,9 +2008,10 @@ package body Translation is -- RANGE_PTR from length LENGTH, which is of type INDEX_TYPE. -- This is done according to rules 7.2.4 of LRM93, ie: -- direction and left bound of the range is the same of INDEX_TYPE. - -- LENGTH and RANGE_PTR are variables. + -- LENGTH and RANGE_PTR are variables. LOC is the location in case of + -- error. procedure Create_Range_From_Length - (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode); + (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode; Loc : Iir); end Chap3; @@ -2330,12 +2331,13 @@ package body Translation is procedure Translate_Implicit_Subprogram (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos); - -- Assign EXPR to TARGET. + -- Assign EXPR to TARGET. LOC is the location used to report errors. -- FIXME: do the checks. procedure Translate_Assign (Target : Mnode; Expr : Iir; Target_Type : Iir); procedure Translate_Assign - (Target : Mnode; Val: O_Enode; Expr : Iir; Target_Type : Iir); + (Target : Mnode; + Val: O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir); -- Find the declaration of the predefined function IMP in type -- definition BASE_TYPE. @@ -9228,7 +9230,7 @@ package body Translation is end Create_Range_From_Array_Attribute_And_Length; procedure Create_Range_From_Length - (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode) + (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode; Loc : Iir) is Iinfo : Type_Info_Acc; Op : ON_Op_Kind; @@ -9294,7 +9296,7 @@ package body Translation is New_Dyadic_Op (Op, Left_Bound, Diff)); -- Check the right bounds is inside the bounds of the index type. - Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Null_Iir); + Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Loc); New_Assign_Stmt (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Right), New_Obj_Value (Var_Right)); @@ -9378,9 +9380,7 @@ package body Translation is -- Not a full constant declaration (ie a value for an -- already declared constant). -- Must create the declaration. - if Get_Expr_Staticness (El) = Locally - or else Chap7.Is_Static_Constant (El) - then + if Chap7.Is_Static_Constant (El) then Info.Object_Static := True; Info.Object_Var := Create_Global_Const (Create_Identifier (El), Obj_Type, Global_Storage, @@ -11179,7 +11179,7 @@ package body Translation is -- Create range from length Chap3.Create_Range_From_Length - (Index_Type, Var_Length, Var_Range_Ptr); + (Index_Type, Var_Length, Var_Range_Ptr, Func); New_Assign_Stmt (New_Selected_Element (New_Obj (Var_Array), Base_Info.T.Bounds_Field (Mode_Value)), @@ -12762,30 +12762,17 @@ package body Translation is end case; end Get_Array_Ptr_Bound_Length; - -- There is a uniq number associated which each error. - Bound_Error_Number : Unsigned_64 := 0; - procedure Gen_Bound_Error (Loc : Iir) is Constr : O_Assoc_List; Name : Name_Id; Line, Col : Natural; begin - if Loc /= Null_Iir then - Files_Map.Location_To_Position - (Get_Location (Loc), Name, Line, Col); + Files_Map.Location_To_Position (Get_Location (Loc), Name, Line, Col); - Start_Association (Constr, Ghdl_Bound_Check_Failed_L1); - Assoc_Filename_Line (Constr, Line); - New_Procedure_Call (Constr); - else - Start_Association (Constr, Ghdl_Bound_Check_Failed_L0); - New_Association - (Constr, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, - Bound_Error_Number))); - New_Procedure_Call (Constr); - Bound_Error_Number := Bound_Error_Number + 1; - end if; + Start_Association (Constr, Ghdl_Bound_Check_Failed_L1); + Assoc_Filename_Line (Constr, Line); + New_Procedure_Call (Constr); end Gen_Bound_Error; procedure Gen_Program_Error (Loc : Iir; Code : Natural) @@ -13816,21 +13803,21 @@ package body Translation is function Is_Static_Constant (Decl : Iir_Constant_Declaration) return Boolean is - Expr : Iir; + Expr : constant Iir := Get_Default_Value (Decl); Atype : Iir; Info : Iir; begin - if Get_Expr_Staticness (Decl) = Locally then - -- Should be not necessary. - return True; - end if; - - Expr := Get_Default_Value (Decl); - if Expr = Null_Iir then + if Expr = Null_Iir + or else Get_Kind (Expr) = Iir_Kind_Overflow_Literal + then -- Deferred constant. return False; end if; + if Get_Expr_Staticness (Decl) = Locally then + return True; + end if; + -- Only aggregates are handled. if Get_Kind (Expr) /= Iir_Kind_Aggregate then return False; @@ -14376,9 +14363,8 @@ package body Translation is function Translate_Static_Expression (Expr : Iir; Res_Type : Iir) return O_Cnode is - Expr_Type : Iir; + Expr_Type : constant Iir := Get_Type (Expr); begin - Expr_Type := Get_Type (Expr); case Get_Kind (Expr) is when Iir_Kind_Integer_Literal | Iir_Kind_Enumeration_Literal @@ -15395,7 +15381,8 @@ package body Translation is -- Assign EXPR to TARGET. procedure Translate_Assign - (Target : Mnode; Val : O_Enode; Expr : Iir; Target_Type : Iir) + (Target : Mnode; + Val : O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir) is T_Info : constant Type_Info_Acc := Get_Info (Target_Type); begin @@ -15427,8 +15414,7 @@ package body Translation is (T_Info.Ortho_Ptr_Type (Mode_Value), Val); Chap3.Check_Array_Match (Target_Type, T, - Get_Type (Expr), Dp2M (E, T_Info, Mode_Value), - Null_Iir); + Get_Type (Expr), Dp2M (E, T_Info, Mode_Value), Loc); Chap3.Translate_Object_Copy (T, New_Obj_Value (E), Target_Type); end; @@ -15455,7 +15441,7 @@ package body Translation is else Open_Temp; Val := Chap7.Translate_Expression (Expr, Target_Type); - Translate_Assign (Target, Val, Expr, Target_Type); + Translate_Assign (Target, Val, Expr, Target_Type, Expr); Close_Temp; end if; end Translate_Assign; @@ -16176,11 +16162,9 @@ package body Translation is (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) return O_Enode is - Res_Info : Type_Info_Acc; - Expr_Info : Type_Info_Acc; + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); begin - Res_Info := Get_Info (Res_Type); - Expr_Info := Get_Info (Expr_Type); case Res_Info.Type_Mode is when Type_Mode_Array => declare @@ -16672,13 +16656,11 @@ package body Translation is when Iir_Kind_Null_Literal => declare + Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); + Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); L : O_Dnode; - Otype : O_Tnode; B : Type_Info_Acc; - Tinfo : Type_Info_Acc; begin - Tinfo := Get_Info (Expr_Type); - Otype := Tinfo.Ortho_Type (Mode_Value); if Tinfo.Type_Mode = Type_Mode_Fat_Acc then -- Create a fat null pointer. -- FIXME: should be optimized!! @@ -16700,6 +16682,25 @@ package body Translation is end if; end; + when Iir_Kind_Overflow_Literal => + declare + Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); + Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); + L : O_Dnode; + begin + -- Generate the error message + Chap6.Gen_Bound_Error (Expr); + + -- Create a dummy value + L := Create_Temp (Otype); + if Tinfo.Type_Mode = Type_Mode_Fat_Acc then + return New_Address (New_Obj (L), + Tinfo.Ortho_Ptr_Type (Mode_Value)); + else + return New_Obj_Value (L); + end if; + end; + when Iir_Kind_Allocator_By_Expression => return Translate_Allocator_By_Expression (Expr); when Iir_Kind_Allocator_By_Subtype => @@ -17819,7 +17820,7 @@ package body Translation is (New_Obj (Var_Range_Ptr), M2Addr (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))); Chap3.Create_Range_From_Length - (Index_Type, Var_Length, Var_Range_Ptr); + (Index_Type, Var_Length, Var_Range_Ptr, Subprg); Finish_Declare_Stmt; end; end if; @@ -20481,7 +20482,7 @@ package body Translation is (Param, Do_Conversion (In_Conv, Act, Params (Pos)), In_Expr, - Formal_Type); + Formal_Type, El); end if; elsif Ftype_Info.Type_Mode not in Type_Mode_By_Value then -- Passed by reference. @@ -20546,7 +20547,7 @@ package body Translation is Param := Chap6.Translate_Name (Formal); Formal_Info.Interface_Node := Prev_Node; end; - Chap7.Translate_Assign (Param, Val, Act, Formal_Type); + Chap7.Translate_Assign (Param, Val, Act, Formal_Type, El); end if; << Continue >> null; El := Get_Chain (El); @@ -20661,7 +20662,7 @@ package body Translation is Do_Conversion (Out_Conv, Formal, Param), Out_Expr, - Get_Type (Get_Actual (El))); + Get_Type (Get_Actual (El)), El); elsif Base_Formal /= Formal then -- By individual. -- Copy back. @@ -20678,7 +20679,7 @@ package body Translation is Formal_Info.Interface_Node := Prev_Node; end; Chap7.Translate_Assign - (Params (Pos), Val, Formal, Get_Type (Act)); + (Params (Pos), Val, Formal, Get_Type (Act), El); end if; end if; El := Get_Chain (El); @@ -21274,7 +21275,7 @@ package body Translation is -- Set driver. Chap7.Translate_Assign - (Drv, M2E (Data.Expr), Data.Expr_Node, Targ_Type); + (Drv, M2E (Data.Expr), Data.Expr_Node, Targ_Type, Data.Expr_Node); -- Test if the signal is active. Start_If_Stmt @@ -28327,14 +28328,6 @@ package body Translation is (Interfaces, Param, Get_Identifier ("code"), Ghdl_Index_Type); Finish_Subprogram_Decl (Interfaces, Ghdl_Program_Error); - -- procedure __ghdl_bound_check_failed_l0; - Start_Procedure_Decl - (Interfaces, Get_Identifier ("__ghdl_bound_check_failed_l0"), - O_Storage_External); - New_Interface_Decl (Interfaces, Param, Get_Identifier ("index"), - Ghdl_Index_Type); - Finish_Subprogram_Decl (Interfaces, Ghdl_Bound_Check_Failed_L0); - -- procedure __ghdl_bound_check_failed_l1 (filename : char_ptr_type; -- line : ghdl_i32); Start_Procedure_Decl diff --git a/xrefs.adb b/xrefs.adb index 4b864af56..1b96544ec 100644 --- a/xrefs.adb +++ b/xrefs.adb @@ -108,7 +108,8 @@ package body Xrefs is case Get_Kind (Name) is when Iir_Kind_Simple_Name | Iir_Kind_Selected_Name - | Iir_Kind_Operator_Symbol => + | Iir_Kind_Operator_Symbol + | Iir_Kind_Character_Literal => Res := Get_Named_Entity (Name); if Res = Std_Package.Error_Mark then return; @@ -126,7 +127,8 @@ package body Xrefs is end case; case Get_Kind (Name) is when Iir_Kind_Simple_Name - | Iir_Kind_Operator_Symbol => + | Iir_Kind_Operator_Symbol + | Iir_Kind_Character_Literal => null; when Iir_Kind_Selected_Name | Iir_Kind_Parenthesis_Name -- cgit v1.2.3