diff options
| -rw-r--r-- | configuration.adb | 5 | ||||
| -rw-r--r-- | disp_tree.adb | 44 | ||||
| -rw-r--r-- | disp_vhdl.adb | 144 | ||||
| -rw-r--r-- | errorout.adb | 5 | ||||
| -rw-r--r-- | evaluation.adb | 27 | ||||
| -rw-r--r-- | evaluation.ads | 3 | ||||
| -rw-r--r-- | ieee-std_logic_1164.adb | 9 | ||||
| -rw-r--r-- | iir_chains.ads | 4 | ||||
| -rw-r--r-- | iirs.adb | 177 | ||||
| -rw-r--r-- | iirs.adb.in | 18 | ||||
| -rw-r--r-- | iirs.ads | 102 | ||||
| -rw-r--r-- | iirs_utils.adb | 7 | ||||
| -rw-r--r-- | iirs_utils.ads | 4 | ||||
| -rw-r--r-- | name_table.adb | 3 | ||||
| -rw-r--r-- | nodes.ads | 2 | ||||
| -rw-r--r-- | parse.adb | 222 | ||||
| -rw-r--r-- | sem.adb | 49 | ||||
| -rw-r--r-- | sem_assocs.adb | 94 | ||||
| -rw-r--r-- | sem_decls.adb | 176 | ||||
| -rw-r--r-- | sem_expr.adb | 471 | ||||
| -rw-r--r-- | sem_expr.ads | 4 | ||||
| -rw-r--r-- | sem_names.adb | 15 | ||||
| -rw-r--r-- | sem_stmts.adb | 7 | ||||
| -rw-r--r-- | sem_types.adb | 1196 | ||||
| -rw-r--r-- | sem_types.ads | 6 | ||||
| -rw-r--r-- | std_package.adb | 1 | ||||
| -rw-r--r-- | translate/gcc/Makefile.in | 1 | ||||
| -rw-r--r-- | translate/translation.adb | 301 | ||||
| -rw-r--r-- | xtools/check_iirs_pkg.adb | 4 |
29 files changed, 2117 insertions, 984 deletions
diff --git a/configuration.adb b/configuration.adb index 0aa3ad2ab..f5d177fb1 100644 --- a/configuration.adb +++ b/configuration.adb @@ -319,8 +319,9 @@ package body Configuration is -- A port of any mode other than IN may be unconnected or -- unassociated as long as its type is not an unconstrained array -- type. - if Get_Kind (Get_Type (Port)) - in Iir_Kinds_Unconstrained_Array_Type_Definition + if Get_Kind (Get_Type (Port)) in Iir_Kinds_Array_Type_Definition + and then (Get_Constraint_State (Get_Type (Port)) + /= Fully_Constrained) then if Loc /= Null_Iir then Error_Msg_Elab ("unconstrained " & Disp_Node (Port) diff --git a/disp_tree.adb b/disp_tree.adb index 7e72a125c..6ad16d7af 100644 --- a/disp_tree.adb +++ b/disp_tree.adb @@ -276,6 +276,9 @@ package body Disp_Tree is when Iir_Kind_Element_Declaration => Put ("element_declaration"); Disp_Identifier (Tree); + when Iir_Kind_Record_Element_Constraint => + Put ("record_element_constraint"); + Disp_Identifier (Tree); when Iir_Kind_Attribute_Declaration => Put ("attribute_declaration"); Disp_Identifier (Tree); @@ -994,6 +997,11 @@ package body Disp_Tree is when Iir_Kind_Element_Declaration => Header ("type:"); Disp_Tree (Get_Type (Tree), Ntab, True); + when Iir_Kind_Record_Element_Constraint => + Header ("type:"); + Disp_Tree (Get_Type (Tree), Ntab, True); + Header ("element_declaration:"); + Disp_Tree (Get_Element_Declaration (Tree), Ntab); when Iir_Kind_Attribute_Declaration => if Flat_Decl then return; @@ -1163,7 +1171,7 @@ package body Disp_Tree is Fl : Boolean; begin if Base /= Null_Iir - and then Kind = Iir_Kind_Array_Type_Definition + and then Get_Kind (Base) = Iir_Kind_Array_Type_Definition then Fl := Get_Type_Declarator (Base) /= Get_Type_Declarator (Tree); @@ -1177,29 +1185,13 @@ package body Disp_Tree is Header ("index_subtype_list:"); Disp_Tree_List (Get_Index_Subtype_List (Tree), Ntab, True); Header ("element_subtype:"); - Disp_Tree_Flat (Get_Element_Subtype (Tree), Ntab); - Header ("resolution function:"); - Disp_Tree_Flat (Get_Resolution_Function (Tree), Ntab); - when Iir_Kind_Unconstrained_Array_Subtype_Definition => - if Flat_Decl and then Get_Type_Declarator (Tree) /= Null_Iir then - return; - end if; - Header ("type declarator:"); - Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); - Header ("resolved flag: ", False); - Disp_Type_Resolved_Flag (Tree); - Header ("signal_type_flag: ", False); - Disp_Flag (Get_Signal_Type_Flag (Tree)); - Header ("has_signal_flag: ", False); - Disp_Flag (Get_Has_Signal_Flag (Tree)); - Header ("base type:"); - Disp_Tree (Get_Base_Type (Tree), Ntab, True); - Header ("type mark:"); - Disp_Tree (Get_Type_Mark (Tree), Ntab, True); + Disp_Tree (Get_Element_Subtype (Tree), Ntab, True); Header ("resolution function:"); Disp_Tree_Flat (Get_Resolution_Function (Tree), Ntab); - Header ("index_subtype_list:"); - Disp_Tree_List (Get_Index_Subtype_List (Tree), Ntab, True); + Header ("index_constraint: ", False); + Disp_Flag (Get_Index_Constraint_Flag (Tree)); + Header ("constraint_state: " + & Iir_Constraint'Image (Get_Constraint_State (Tree))); when Iir_Kind_Array_Type_Definition => if Flat_Decl and then Get_Type_Declarator (Tree) /= Null_Iir then return; @@ -1228,8 +1220,10 @@ package body Disp_Tree is Disp_Flag (Get_Signal_Type_Flag (Tree)); Header ("has_signal_flag: ", False); Disp_Flag (Get_Has_Signal_Flag (Tree)); + Header ("constraint_state: " + & Iir_Constraint'Image (Get_Constraint_State (Tree))); Header ("elements:"); - Disp_Tree_Chain (Get_Element_Declaration_Chain (Tree), Ntab, True); + Disp_Tree_List (Get_Elements_Declaration_List (Tree), Ntab, True); when Iir_Kind_Record_Subtype_Definition => if Flat_Decl and then not Is_Anonymous_Type_Definition (Tree) then return; @@ -1246,6 +1240,10 @@ package body Disp_Tree is Disp_Tree (Get_Type_Mark (Tree), Ntab, True); Header ("resolution function:"); Disp_Tree_Flat (Get_Resolution_Function (Tree), Ntab); + Header ("constraint_state: " + & Iir_Constraint'Image (Get_Constraint_State (Tree))); + Header ("elements:"); + Disp_Tree_List (Get_Elements_Declaration_List (Tree), Ntab, True); when Iir_Kind_Physical_Type_Definition => if Flat_Decl and then Get_Type_Declarator (Tree) /= Null_Iir then return; diff --git a/disp_vhdl.adb b/disp_vhdl.adb index 57b2d4da6..57132fbc2 100644 --- a/disp_vhdl.adb +++ b/disp_vhdl.adb @@ -135,6 +135,7 @@ package body Disp_Vhdl is | Iir_Kind_File_Declaration | Iir_Kind_Subtype_Declaration | Iir_Kind_Element_Declaration + | Iir_Kind_Record_Element_Constraint | Iir_Kind_Package_Declaration | Iir_Kind_Object_Alias_Declaration | Iir_Kind_Non_Object_Alias_Declaration @@ -221,12 +222,30 @@ package body Disp_Vhdl is end Disp_Use_Clause; -- Disp the resolution function (if any) of type definition DEF. - procedure Disp_Resolution_Function (Def: Iir) is - Decl: Iir; + procedure Disp_Resolution_Function (Subtype_Def: Iir) + is + procedure Inner (Def : Iir) + is + Decl: Iir; + begin + Decl := Get_Resolution_Function (Def); + if Decl /= Null_Iir then + Disp_Name (Decl); + else + case Get_Kind (Def) is + when Iir_Kind_Array_Subtype_Definition => + Put ('('); + Inner (Get_Element_Subtype (Def)); + Put (')'); + when others => + Error_Kind ("disp_resolution_function", Def); + end case; + end if; + end Inner; + begin - Decl := Get_Resolution_Function (Def); - if Decl /= Null_Iir then - Disp_Name (Decl); + if Get_Resolved_Flag (Subtype_Def) then + Inner (Subtype_Def); Put (' '); end if; end Disp_Resolution_Function; @@ -275,12 +294,93 @@ package body Disp_Vhdl is Put (";"); end Disp_Floating_Subtype_Definition; - procedure Disp_Subtype_Indication (Def: Iir; Full_Decl: Boolean := False) + procedure Disp_Element_Constraint (Def : Iir; Type_Mark : Iir); + + procedure Disp_Array_Element_Constraint (Def : Iir; Type_Mark : Iir) + is + Index : Iir; + Def_El : Iir; + Tm_El : Iir; + Has_Index : Boolean; + Has_Own_Element_Subtype : Boolean; + begin + Has_Index := Get_Index_Constraint_Flag (Def); + Def_El := Get_Element_Subtype (Def); + Tm_El := Get_Element_Subtype (Type_Mark); + Has_Own_Element_Subtype := Def_El /= Tm_El; + + if not Has_Index and not Has_Own_Element_Subtype then + return; + end if; + + Put (" ("); + if Has_Index then + for I in Natural loop + Index := Get_Nth_Element (Get_Index_Subtype_List (Def), I); + exit when Index = Null_Iir; + if I /= 0 then + Put (", "); + end if; + --Disp_Expression (Get_Range_Constraint (Index)); + Disp_Range (Index); + end loop; + else + Put ("open"); + end if; + Put (")"); + + if Has_Own_Element_Subtype + and then Get_Kind (Def_El) in Iir_Kinds_Composite_Type_Definition + then + Disp_Element_Constraint (Def_El, Tm_El); + end if; + end Disp_Array_Element_Constraint; + + procedure Disp_Record_Element_Constraint (Def : Iir) + is + El_List : constant Iir_List := Get_Elements_Declaration_List (Def); + El : Iir; + Has_El : Boolean := False; + begin + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + if Get_Kind (El) = Iir_Kind_Record_Element_Constraint + and then Get_Parent (El) = Def + then + if Has_El then + Put (", "); + else + Put ("("); + Has_El := True; + end if; + Disp_Name_Of (El); + Disp_Element_Constraint (Get_Type (El), + Get_Base_Type (Get_Type (El))); + end if; + end loop; + if Has_El then + Put (")"); + end if; + end Disp_Record_Element_Constraint; + + procedure Disp_Element_Constraint (Def : Iir; Type_Mark : Iir) is + begin + case Get_Kind (Def) is + when Iir_Kind_Record_Subtype_Definition => + Disp_Record_Element_Constraint (Def); + when Iir_Kind_Array_Subtype_Definition => + Disp_Array_Element_Constraint (Def, Type_Mark); + when others => + Error_Kind ("disp_element_constraint", Def); + end case; + end Disp_Element_Constraint; + + procedure Disp_Subtype_Indication (Def : Iir; Full_Decl : Boolean := False) is - Type_Mark: Iir; + Type_Mark : Iir; Base_Type : Iir; - Index: Iir; - Decl: Iir; + Decl : Iir; begin Decl := Get_Type_Declarator (Def); if not Full_Decl and then Decl /= Null_Iir then @@ -298,10 +398,6 @@ package body Disp_Vhdl is Disp_Name_Of (Decl); end if; - if Get_Kind (Def) = Iir_Kind_Unconstrained_Array_Subtype_Definition then - return; - end if; - Base_Type := Get_Base_Type (Def); case Get_Kind (Base_Type) is when Iir_Kind_Integer_Type_Definition @@ -318,19 +414,9 @@ package body Disp_Vhdl is Disp_Expression (Get_Range_Constraint (Def)); end if; when Iir_Kind_Array_Type_Definition => - Put (" ("); - for I in Natural loop - Index := Get_Nth_Element (Get_Index_Subtype_List (Def), I); - exit when Index = Null_Iir; - if I /= 0 then - Put (", "); - end if; - Disp_Expression (Get_Range_Constraint (Index)); - --Disp_Range (Get_Range_Constraint (Index); - end loop; - Put (")"); + Disp_Array_Element_Constraint (Def, Type_Mark); when Iir_Kind_Record_Type_Definition => - null; + Disp_Record_Element_Constraint (Def); when others => Error_Kind ("disp_subtype_indication", Base_Type); end case; @@ -463,19 +549,21 @@ package body Disp_Vhdl is procedure Disp_Record_Type_Definition (Def: Iir_Record_Type_Definition; Indent: Count) is + List : Iir_List; El: Iir_Element_Declaration; begin Put_Line ("record"); Set_Col (Indent); Put_Line ("begin"); - El := Get_Element_Declaration_Chain (Def); - while El /= Null_Iir loop + List := Get_Elements_Declaration_List (Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; Set_Col (Indent + Indentation); Disp_Identifier (El); Put (" : "); Disp_Subtype_Indication (Get_Type (El)); Put_Line (";"); - El := Get_Chain (El); end loop; Set_Col (Indent); Put ("end record;"); diff --git a/errorout.adb b/errorout.adb index 32b124960..544f56bf0 100644 --- a/errorout.adb +++ b/errorout.adb @@ -403,6 +403,8 @@ package body Errorout is return "enumeration literal " & Iirs_Utils.Image_Identifier (Node); when Iir_Kind_Element_Declaration => return Disp_Identifier (Node, "element"); + when Iir_Kind_Record_Element_Constraint => + return "record element constraint"; when Iir_Kind_Null_Literal => return "null literal"; when Iir_Kind_Aggregate => @@ -436,8 +438,7 @@ package body Errorout is when Iir_Kind_Array_Type_Definition => return Disp_Type (Node, "array type"); - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => + when Iir_Kind_Array_Subtype_Definition => return Disp_Type (Node, "array subtype"); when Iir_Kind_Record_Type_Definition => return Disp_Type (Node, "record type"); diff --git a/evaluation.adb b/evaluation.adb index c54300304..4742aeeb2 100644 --- a/evaluation.adb +++ b/evaluation.adb @@ -335,6 +335,8 @@ package body Evaluation is Append_Element (Get_Index_Subtype_List (Res), Index_Type); Set_Type_Staticness (Res, Min (Get_Type_Staticness (Res), Get_Type_Staticness (Index_Type))); + Set_Constraint_State (Res, Fully_Constrained); + Set_Index_Constraint_Flag (Res, True); return Res; end Create_Unidim_Array_From_Index; @@ -1144,6 +1146,7 @@ package body Evaluation is | Iir_Predefined_Write | Iir_Predefined_Read | Iir_Predefined_Read_Length + | Iir_Predefined_Flush | Iir_Predefined_File_Open | Iir_Predefined_File_Open_Status | Iir_Predefined_File_Close @@ -1164,7 +1167,8 @@ package body Evaluation is | Iir_Predefined_Attribute_Last_Event | Iir_Predefined_Attribute_Last_Active | Iir_Predefined_Attribute_Driving - | Iir_Predefined_Attribute_Driving_Value => + | Iir_Predefined_Attribute_Driving_Value + | Iir_Predefined_Array_To_String => -- Not binary or never locally static. Error_Internal (Orig, "eval_dyadic_operator: " & Iir_Predefined_Functions'Image (Func)); @@ -1413,8 +1417,7 @@ package body Evaluation is Error_Msg_Sem ("non matching length in type convertion", Conv); end if; return Res; - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => + when Iir_Kind_Array_Type_Definition => if Get_Base_Type (Conv_Index_Type) = Get_Base_Type (Val_Index_Type) then Index_Type := Val_Index_Type; @@ -1510,7 +1513,14 @@ package body Evaluation is when Iir_Kind_Constant_Declaration => Val := Get_Default_Value (Expr); Res := Build_Constant (Val, Expr); - Set_Type (Res, Get_Type (Val)); + -- Type of the expression should be type of the constant + -- declaration at least in case of array subtype. + -- If the constant is declared as an unconstrained array, get type + -- from the default value. + -- FIXME: handle this during semantisation of the declaration. + if Get_Kind (Get_Type (Res)) = Iir_Kind_Array_Type_Definition then + Set_Type (Res, Get_Type (Val)); + end if; return Res; when Iir_Kind_Object_Alias_Declaration => return Build_Constant (Eval_Static_Expr (Get_Name (Expr)), Expr); @@ -1814,6 +1824,15 @@ package body Evaluation is end if; end Eval_Expr_If_Static; + function Eval_Expr_Check_If_Static (Expr : Iir; Atype : Iir) return Iir is + begin + if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then + return Eval_Expr_Check (Expr, Atype); + else + return Expr; + end if; + end Eval_Expr_Check_If_Static; + function Eval_Int_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean is begin case Get_Kind (Bound) is diff --git a/evaluation.ads b/evaluation.ads index a54ead36c..282a7522a 100644 --- a/evaluation.ads +++ b/evaluation.ads @@ -59,6 +59,9 @@ package Evaluation is -- computation. function Eval_Expr_Check (Expr : Iir; Sub_Type : Iir) return Iir; + -- Call Eval_Expr_Check only if EXPR is static. + function Eval_Expr_Check_If_Static (Expr : Iir; Atype : Iir) return Iir; + -- Return TRUE iff VAL belongs to BOUND. function Eval_Int_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean; diff --git a/ieee-std_logic_1164.adb b/ieee-std_logic_1164.adb index 561ed6535..8ecd1acee 100644 --- a/ieee-std_logic_1164.adb +++ b/ieee-std_logic_1164.adb @@ -113,15 +113,16 @@ package body Ieee.Std_Logic_1164 is Decl := Get_Chain (Decl); Decl := Skip_Implicit (Decl); if Decl = Null_Iir - or else Get_Kind (Decl) /= Iir_Kind_Type_Declaration + or else (Get_Kind (Decl) /= Iir_Kind_Type_Declaration + and then Get_Kind (Decl) /= Iir_Kind_Subtype_Declaration) or else Get_Identifier (Decl) /= Name_Std_Logic_Vector then raise Error; end if; Def := Get_Type (Decl); - if Get_Kind (Def) /= Iir_Kind_Array_Type_Definition then - raise Error; - end if; +-- if Get_Kind (Def) /= Iir_Kind_Array_Type_Definition then +-- raise Error; +-- end if; Std_Logic_Vector_Type := Def; -- Skip any declarations but functions. diff --git a/iir_chains.ads b/iir_chains.ads index 95b2f755b..dc2f3894c 100644 --- a/iir_chains.ads +++ b/iir_chains.ads @@ -60,10 +60,6 @@ package Iir_Chains is (Get_Chain_Start => Get_Unit_Chain, Set_Chain_Start => Set_Unit_Chain); - package Element_Declaration_Chain_Handling is new Iir_Chain_Handling - (Get_Chain_Start => Get_Element_Declaration_Chain, - Set_Chain_Start => Set_Element_Declaration_Chain); - package Configuration_Item_Chain_Handling is new Iir_Chain_Handling (Get_Chain_Start => Get_Configuration_Item_Chain, Set_Chain_Start => Set_Configuration_Item_Chain); @@ -264,15 +264,15 @@ package body Iirs is return Token_Type'Pos (T); end Token_Type_To_Iir; - function Iir_To_Iir_Index32 (N : Iir) return Iir_Index32 is - begin - return Iir_Index32 (N); - end Iir_To_Iir_Index32; +-- function Iir_To_Iir_Index32 (N : Iir) return Iir_Index32 is +-- begin +-- return Iir_Index32 (N); +-- end Iir_To_Iir_Index32; - function Iir_Index32_To_Iir (V : Iir_Index32) return Iir is - begin - return Iir_Index32'Pos (V); - end Iir_Index32_To_Iir; +-- function Iir_Index32_To_Iir (V : Iir_Index32) return Iir is +-- begin +-- return Iir_Index32'Pos (V); +-- end Iir_Index32_To_Iir; function Iir_To_Name_Id (N : Iir) return Name_Id is begin @@ -344,6 +344,7 @@ package body Iirs is | Iir_Kind_Aggregate_Info | Iir_Kind_Procedure_Call | Iir_Kind_Operator_Symbol + | Iir_Kind_Record_Element_Constraint | Iir_Kind_Disconnection_Specification | Iir_Kind_Configuration_Specification | Iir_Kind_Access_Type_Definition @@ -481,7 +482,6 @@ package body Iirs is | Iir_Kind_Binding_Indication | Iir_Kind_Attribute_Specification | Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition | Iir_Kind_Array_Subtype_Definition | Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Declaration @@ -2095,7 +2095,6 @@ package body Iirs is | Iir_Kind_Attribute_Declaration | Iir_Kind_Group_Template_Declaration | Iir_Kind_Group_Declaration - | Iir_Kind_Element_Declaration | Iir_Kind_Non_Object_Alias_Declaration | Iir_Kind_Function_Body | Iir_Kind_Function_Declaration @@ -2220,6 +2219,7 @@ package body Iirs is | Iir_Kind_Bit_String_Literal | Iir_Kind_Simple_Aggregate | Iir_Kind_Attribute_Value + | Iir_Kind_Record_Element_Constraint | Iir_Kind_Disconnection_Specification | Iir_Kind_Range_Expression | Iir_Kind_Type_Declaration @@ -3012,7 +3012,8 @@ package body Iirs is procedure Check_Kind_For_Element_Position (Target : Iir) is begin case Get_Kind (Target) is - when Iir_Kind_Element_Declaration => + when Iir_Kind_Record_Element_Constraint + | Iir_Kind_Element_Declaration => null; when others => Failed ("Element_Position", Target); @@ -3031,6 +3032,28 @@ package body Iirs is Set_Field4 (Target, Iir_Index32'Pos (Pos)); end Set_Element_Position; + procedure Check_Kind_For_Element_Declaration (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Record_Element_Constraint => + null; + when others => + Failed ("Element_Declaration", Target); + end case; + end Check_Kind_For_Element_Declaration; + + function Get_Element_Declaration (Target : Iir) return Iir is + begin + Check_Kind_For_Element_Declaration (Target); + return Get_Field2 (Target); + end Get_Element_Declaration; + + procedure Set_Element_Declaration (Target : Iir; El : Iir) is + begin + Check_Kind_For_Element_Declaration (Target); + Set_Field2 (Target, El); + end Set_Element_Declaration; + procedure Check_Kind_For_Selected_Element (Target : Iir) is begin case Get_Kind (Target) is @@ -3151,7 +3174,6 @@ package body Iirs is | Iir_Kind_Protected_Type_Declaration | Iir_Kind_Record_Type_Definition | Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition | Iir_Kind_Array_Subtype_Definition | Iir_Kind_Record_Subtype_Definition | Iir_Kind_Access_Subtype_Definition @@ -3292,6 +3314,7 @@ package body Iirs is | Iir_Kind_Library_Clause | Iir_Kind_Character_Literal | Iir_Kind_Operator_Symbol + | Iir_Kind_Record_Element_Constraint | Iir_Kind_Protected_Type_Body | Iir_Kind_Type_Declaration | Iir_Kind_Anonymous_Type_Declaration @@ -3415,6 +3438,7 @@ package body Iirs is begin case Get_Kind (Target) is when Iir_Kind_Design_Unit + | Iir_Kind_Record_Element_Constraint | Iir_Kind_Type_Declaration | Iir_Kind_Subtype_Declaration | Iir_Kind_Unit_Declaration @@ -3585,7 +3609,6 @@ package body Iirs is | Iir_Kind_Protected_Type_Declaration | Iir_Kind_Record_Type_Definition | Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition | Iir_Kind_Array_Subtype_Definition | Iir_Kind_Record_Subtype_Definition | Iir_Kind_Access_Subtype_Definition @@ -3618,8 +3641,7 @@ package body Iirs is procedure Check_Kind_For_Resolution_Function (Target : Iir) is begin case Get_Kind (Target) is - when Iir_Kind_Unconstrained_Array_Subtype_Definition - | Iir_Kind_Array_Subtype_Definition + when Iir_Kind_Array_Subtype_Definition | Iir_Kind_Record_Subtype_Definition | Iir_Kind_Physical_Subtype_Definition | Iir_Kind_Floating_Subtype_Definition @@ -3666,6 +3688,28 @@ package body Iirs is Set_Flag4 (Atype, Flag); end Set_Text_File_Flag; + procedure Check_Kind_For_Only_Characters_Flag (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Enumeration_Type_Definition => + null; + when others => + Failed ("Only_Characters_Flag", Target); + end case; + end Check_Kind_For_Only_Characters_Flag; + + function Get_Only_Characters_Flag (Atype : Iir) return Boolean is + begin + Check_Kind_For_Only_Characters_Flag (Atype); + return Get_Flag4 (Atype); + end Get_Only_Characters_Flag; + + procedure Set_Only_Characters_Flag (Atype : Iir; Flag : Boolean) is + begin + Check_Kind_For_Only_Characters_Flag (Atype); + Set_Flag4 (Atype, Flag); + end Set_Only_Characters_Flag; + procedure Check_Kind_For_Type_Staticness (Target : Iir) is begin case Get_Kind (Target) is @@ -3676,7 +3720,6 @@ package body Iirs is | Iir_Kind_Protected_Type_Declaration | Iir_Kind_Record_Type_Definition | Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition | Iir_Kind_Array_Subtype_Definition | Iir_Kind_Record_Subtype_Definition | Iir_Kind_Access_Subtype_Definition @@ -3706,11 +3749,35 @@ package body Iirs is Set_State1 (Atype, Iir_Staticness'Pos (Static)); end Set_Type_Staticness; + procedure Check_Kind_For_Constraint_State (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition => + null; + when others => + Failed ("Constraint_State", Target); + end case; + end Check_Kind_For_Constraint_State; + + function Get_Constraint_State (Atype : Iir) return Iir_Constraint is + begin + Check_Kind_For_Constraint_State (Atype); + return Iir_Constraint'Val (Get_State2 (Atype)); + end Get_Constraint_State; + + procedure Set_Constraint_State (Atype : Iir; State : Iir_Constraint) is + begin + Check_Kind_For_Constraint_State (Atype); + Set_State2 (Atype, Iir_Constraint'Pos (State)); + end Set_Constraint_State; + procedure Check_Kind_For_Index_Subtype_List (Target : Iir) is begin case Get_Kind (Target) is when Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition | Iir_Kind_Array_Subtype_Definition => null; when others => @@ -3756,7 +3823,6 @@ package body Iirs is begin case Get_Kind (Target) is when Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition | Iir_Kind_Array_Subtype_Definition => null; when others => @@ -3776,49 +3842,28 @@ package body Iirs is Set_Field1 (Decl, Sub_Type); end Set_Element_Subtype; - procedure Check_Kind_For_Element_Declaration_Chain (Target : Iir) is + procedure Check_Kind_For_Elements_Declaration_List (Target : Iir) is begin case Get_Kind (Target) is - when Iir_Kind_Record_Type_Definition => + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => null; when others => - Failed ("Element_Declaration_Chain", Target); + Failed ("Elements_Declaration_List", Target); end case; - end Check_Kind_For_Element_Declaration_Chain; + end Check_Kind_For_Elements_Declaration_List; - function Get_Element_Declaration_Chain (Decl : Iir) return Iir is + function Get_Elements_Declaration_List (Decl : Iir) return Iir_List is begin - Check_Kind_For_Element_Declaration_Chain (Decl); - return Get_Field2 (Decl); - end Get_Element_Declaration_Chain; - - procedure Set_Element_Declaration_Chain (Decl : Iir; Chain : Iir) is - begin - Check_Kind_For_Element_Declaration_Chain (Decl); - Set_Field2 (Decl, Chain); - end Set_Element_Declaration_Chain; - - procedure Check_Kind_For_Number_Element_Declaration (Target : Iir) is - begin - case Get_Kind (Target) is - when Iir_Kind_Record_Type_Definition => - null; - when others => - Failed ("Number_Element_Declaration", Target); - end case; - end Check_Kind_For_Number_Element_Declaration; + Check_Kind_For_Elements_Declaration_List (Decl); + return Iir_To_Iir_List (Get_Field1 (Decl)); + end Get_Elements_Declaration_List; - function Get_Number_Element_Declaration (Decl : Iir) return Iir_Index32 is + procedure Set_Elements_Declaration_List (Decl : Iir; List : Iir_List) is begin - Check_Kind_For_Number_Element_Declaration (Decl); - return Iir_To_Iir_Index32 (Get_Field1 (Decl)); - end Get_Number_Element_Declaration; - - procedure Set_Number_Element_Declaration (Decl : Iir; Val : Iir_Index32) is - begin - Check_Kind_For_Number_Element_Declaration (Decl); - Set_Field1 (Decl, Iir_Index32_To_Iir (Val)); - end Set_Number_Element_Declaration; + Check_Kind_For_Elements_Declaration_List (Decl); + Set_Field1 (Decl, Iir_List_To_Iir (List)); + end Set_Elements_Declaration_List; procedure Check_Kind_For_Designated_Type (Target : Iir) is begin @@ -4265,7 +4310,6 @@ package body Iirs is | Iir_Kind_Protected_Type_Declaration | Iir_Kind_Record_Type_Definition | Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition | Iir_Kind_Array_Subtype_Definition | Iir_Kind_Record_Subtype_Definition | Iir_Kind_Access_Subtype_Definition @@ -4305,7 +4349,6 @@ package body Iirs is | Iir_Kind_Protected_Type_Declaration | Iir_Kind_Record_Type_Definition | Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition | Iir_Kind_Array_Subtype_Definition | Iir_Kind_Record_Subtype_Definition | Iir_Kind_Access_Subtype_Definition @@ -4342,7 +4385,6 @@ package body Iirs is | Iir_Kind_Incomplete_Type_Definition | Iir_Kind_Record_Type_Definition | Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition | Iir_Kind_Array_Subtype_Definition | Iir_Kind_Record_Subtype_Definition | Iir_Kind_Physical_Subtype_Definition @@ -4416,6 +4458,29 @@ package body Iirs is Set_Flag3 (Design, Flag); end Set_Elab_Flag; + procedure Check_Kind_For_Index_Constraint_Flag (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + null; + when others => + Failed ("Index_Constraint_Flag", Target); + end case; + end Check_Kind_For_Index_Constraint_Flag; + + function Get_Index_Constraint_Flag (Atype : Iir) return Boolean is + begin + Check_Kind_For_Index_Constraint_Flag (Atype); + return Get_Flag4 (Atype); + end Get_Index_Constraint_Flag; + + procedure Set_Index_Constraint_Flag (Atype : Iir; Flag : Boolean) is + begin + Check_Kind_For_Index_Constraint_Flag (Atype); + Set_Flag4 (Atype, Flag); + end Set_Index_Constraint_Flag; + procedure Check_Kind_For_Assertion_Condition (Target : Iir) is begin case Get_Kind (Target) is @@ -4986,6 +5051,7 @@ package body Iirs is | Iir_Kind_Block_Configuration | Iir_Kind_Component_Configuration | Iir_Kind_Procedure_Call + | Iir_Kind_Record_Element_Constraint | Iir_Kind_Attribute_Specification | Iir_Kind_Disconnection_Specification | Iir_Kind_Configuration_Specification @@ -6284,7 +6350,6 @@ package body Iirs is begin case Get_Kind (Target) is when Iir_Kind_File_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition | Iir_Kind_Array_Subtype_Definition | Iir_Kind_Record_Subtype_Definition | Iir_Kind_Access_Subtype_Definition diff --git a/iirs.adb.in b/iirs.adb.in index 06a0e58cc..cba22aebd 100644 --- a/iirs.adb.in +++ b/iirs.adb.in @@ -264,15 +264,15 @@ package body Iirs is return Token_Type'Pos (T); end Token_Type_To_Iir; - function Iir_To_Iir_Index32 (N : Iir) return Iir_Index32 is - begin - return Iir_Index32 (N); - end Iir_To_Iir_Index32; - - function Iir_Index32_To_Iir (V : Iir_Index32) return Iir is - begin - return Iir_Index32'Pos (V); - end Iir_Index32_To_Iir; +-- function Iir_To_Iir_Index32 (N : Iir) return Iir_Index32 is +-- begin +-- return Iir_Index32 (N); +-- end Iir_To_Iir_Index32; + +-- function Iir_Index32_To_Iir (V : Iir_Index32) return Iir is +-- begin +-- return Iir_Index32'Pos (V); +-- end Iir_Index32_To_Iir; function Iir_To_Name_Id (N : Iir) return Name_Id is begin @@ -1161,7 +1161,22 @@ package Iirs is -- -- Get/Set_Type (Field1) -- - -- Get/Set_Chain (Field2) + -- Get/Set_Identifier (Field3) + -- + -- Return the position of the element in the record, starting from 0 for the + -- first record element, increasing by one for each successive element. + -- Get/Set_Element_Position (Field4) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Record_Element_Constraint (Short) + -- + -- Record subtype definition which defines this constraint. + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Element_Declaration (Field2) -- -- Get/Set_Identifier (Field3) -- @@ -1289,6 +1304,8 @@ package Iirs is -- -- Get/Set_Has_Signal_Flag (Flag3) -- + -- Get/Set_Only_Characters_Flag (Flag4) + -- -- Get/Set_Type_Staticness (State1) -- Iir_Kind_Enumeration_Literal (Medium) @@ -1391,17 +1408,19 @@ package Iirs is -- -- Get/Set_Type_Staticness (State1) -- + -- Get/Set_Constraint_State (State2) + -- -- Get/Set_Resolved_Flag (Flag1) -- -- Get/Set_Signal_Type_Flag (Flag2) -- -- Get/Set_Has_Signal_Flag (Flag3) + -- + -- Get/Set_Index_Constraint_Flag (Flag4) -- Iir_Kind_Record_Type_Definition (Short) -- - -- Get/Set_Number_Element_Declaration (Field1) - -- - -- Get/Set_Element_Declaration_Chain (Field2) + -- Get/Set_Elements_Declaration_List (Field1) -- -- Get/Set_Type_Declarator (Field3) -- @@ -1409,6 +1428,8 @@ package Iirs is -- -- Get/Set_Type_Staticness (State1) -- + -- Get/Set_Constraint_State (State2) + -- -- Get/Set_Resolved_Flag (Flag1) -- -- Get/Set_Signal_Type_Flag (Flag2) @@ -1543,6 +1564,8 @@ package Iirs is -- Iir_Kind_Record_Subtype_Definition (Short) -- + -- Get/Set_Elements_Declaration_List (Field1) + -- -- Get/Set_Type_Mark (Field2) -- -- Get/Set_Type_Declarator (Field3) @@ -1558,18 +1581,10 @@ package Iirs is -- Get/Set_Has_Signal_Flag (Flag3) -- -- Get/Set_Type_Staticness (State1) + -- + -- Get/Set_Constraint_State (State2) -- Iir_Kind_Array_Subtype_Definition (Medium) - -- Iir_Kind_Unconstrained_Array_Subtype_Definition (Medium) - -- - -- Iir_Kind_Array_Subtype_definition defines a constrained array - -- subtype, which *must* be a subtype of an iir_array_type_definition. - -- - -- Iir_Kind_Unconstrained_Array_Subtype_Definition defines a - -- unconstrained array subtype, which *must* be a subtype of an - -- iir_array_type_definition. The only way to create such a - -- subtype is via a subtype declaration, without adding - -- constraints. -- -- Get/Set_Element_Subtype (Field1) -- @@ -1585,11 +1600,15 @@ package Iirs is -- -- Get/Set_Type_Staticness (State1) -- + -- Get/Set_Constraint_State (State2) + -- -- Get/Set_Resolved_Flag (Flag1) -- -- Get/Set_Signal_Type_Flag (Flag2) -- -- Get/Set_Has_Signal_Flag (Flag3) + -- + -- Get/Set_Index_Constraint_Flag (Flag4) -- Iir_Kind_Range_Expression (Short) -- @@ -2491,6 +2510,7 @@ package Iirs is Iir_Kind_Aggregate_Info, Iir_Kind_Procedure_Call, Iir_Kind_Operator_Symbol, + Iir_Kind_Record_Element_Constraint, Iir_Kind_Attribute_Specification, Iir_Kind_Disconnection_Specification, @@ -2505,7 +2525,6 @@ package Iirs is Iir_Kind_Protected_Type_Declaration, Iir_Kind_Record_Type_Definition, -- composite Iir_Kind_Array_Type_Definition, -- composite, array - Iir_Kind_Unconstrained_Array_Subtype_Definition, -- composite, array, st Iir_Kind_Array_Subtype_Definition, -- composite, array, st Iir_Kind_Record_Subtype_Definition, -- composite, st Iir_Kind_Access_Subtype_Definition, -- st @@ -2913,9 +2932,13 @@ package Iirs is Iir_Predefined_File_Close, Iir_Predefined_Read, Iir_Predefined_Read_Length, + Iir_Predefined_Flush, Iir_Predefined_Write, Iir_Predefined_Endfile, + -- To_String + Iir_Predefined_Array_To_String, + -- Predefined function. Iir_Predefined_Now_Function ); @@ -2992,6 +3015,11 @@ package Iirs is type Iir_All_Sensitized is (Unknown, No_Signal, Read_Signal, Invalid_Signal); + -- Constraint state of a type. + -- See LRM08 5.1 for definition. + type Iir_Constraint is + (Unconstrained, Partially_Constrained, Fully_Constrained); + --------------- -- subranges -- --------------- @@ -3030,7 +3058,6 @@ package Iirs is subtype Iir_Kinds_Array_Type_Definition is Iir_Kind range Iir_Kind_Array_Type_Definition .. - --Iir_Kind_Unconstrained_Array_Subtype_Definition Iir_Kind_Array_Subtype_Definition; subtype Iir_Kinds_Type_And_Subtype_Definition is Iir_Kind range @@ -3040,7 +3067,6 @@ package Iirs is --Iir_Kind_Protected_Type_Declaration --Iir_Kind_Record_Type_Definition --Iir_Kind_Array_Type_Definition - --Iir_Kind_Unconstrained_Array_Subtype_Definition --Iir_Kind_Array_Subtype_Definition --Iir_Kind_Record_Subtype_Definition --Iir_Kind_Access_Subtype_Definition @@ -3054,8 +3080,7 @@ package Iirs is Iir_Kind_Physical_Type_Definition; subtype Iir_Kinds_Subtype_Definition is Iir_Kind range - Iir_Kind_Unconstrained_Array_Subtype_Definition .. - --Iir_Kind_Array_Subtype_Definition + Iir_Kind_Array_Subtype_Definition .. --Iir_Kind_Record_Subtype_Definition --Iir_Kind_Access_Subtype_Definition --Iir_Kind_Physical_Subtype_Definition @@ -3087,18 +3112,9 @@ package Iirs is subtype Iir_Kinds_Composite_Type_Definition is Iir_Kind range Iir_Kind_Record_Type_Definition .. --Iir_Kind_Array_Type_Definition - --Iir_Kind_Unconstrained_Array_Subtype_Definition --Iir_Kind_Array_Subtype_Definition Iir_Kind_Record_Subtype_Definition; - subtype Iir_Kinds_Unconstrained_Array_Type_Definition is Iir_Kind range - Iir_Kind_Array_Type_Definition .. - Iir_Kind_Unconstrained_Array_Subtype_Definition; - - subtype Iir_Kinds_Array_Subtype_Definition is Iir_Kind range - Iir_Kind_Unconstrained_Array_Subtype_Definition .. - Iir_Kind_Array_Subtype_Definition; - subtype Iir_Kinds_Type_Declaration is Iir_Kind range Iir_Kind_Type_Declaration .. --Iir_Kind_Anonymous_Type_Declaration @@ -3546,8 +3562,6 @@ package Iirs is subtype Iir_Array_Subtype_Definition is Iir; - subtype Iir_Unconstrained_Array_Subtype_Definition is Iir; - subtype Iir_Physical_Type_Definition is Iir; subtype Iir_Physical_Subtype_Definition is Iir; @@ -4320,6 +4334,10 @@ package Iirs is procedure Set_Element_Position (Target : Iir; Pos : Iir_Index32); -- Field: Field2 + function Get_Element_Declaration (Target : Iir) return Iir; + procedure Set_Element_Declaration (Target : Iir; El : Iir); + + -- Field: Field2 function Get_Selected_Element (Target : Iir) return Iir; procedure Set_Selected_Element (Target : Iir; El : Iir); @@ -4419,10 +4437,19 @@ package Iirs is function Get_Text_File_Flag (Atype : Iir) return Boolean; procedure Set_Text_File_Flag (Atype : Iir; Flag : Boolean); + -- True if enumeration type ATYPE has only character literals. + -- Field: Flag4 + function Get_Only_Characters_Flag (Atype : Iir) return Boolean; + procedure Set_Only_Characters_Flag (Atype : Iir; Flag : Boolean); + -- Field: State1 (pos) function Get_Type_Staticness (Atype : Iir) return Iir_Staticness; procedure Set_Type_Staticness (Atype : Iir; Static : Iir_Staticness); + -- Field: State2 (pos) + function Get_Constraint_State (Atype : Iir) return Iir_Constraint; + procedure Set_Constraint_State (Atype : Iir; State : Iir_Constraint); + -- Field: Field6 (uc) function Get_Index_Subtype_List (Decl : Iir) return Iir_List; procedure Set_Index_Subtype_List (Decl : Iir; List : Iir_List); @@ -4436,14 +4463,9 @@ package Iirs is procedure Set_Element_Subtype (Decl : Iir; Sub_Type : Iir); -- Chains of elements of a record. - -- Field: Field2 - function Get_Element_Declaration_Chain (Decl : Iir) return Iir; - procedure Set_Element_Declaration_Chain (Decl : Iir; Chain : Iir); - - -- Number of elements in the record. -- Field: Field1 (uc) - function Get_Number_Element_Declaration (Decl : Iir) return Iir_Index32; - procedure Set_Number_Element_Declaration (Decl : Iir; Val : Iir_Index32); + function Get_Elements_Declaration_List (Decl : Iir) return Iir_List; + procedure Set_Elements_Declaration_List (Decl : Iir; List : Iir_List); -- Field: Field2 function Get_Designated_Type (Target : Iir) return Iir; @@ -4581,6 +4603,12 @@ package Iirs is function Get_Elab_Flag (Design : Iir) return Boolean; procedure Set_Elab_Flag (Design : Iir; Flag : Boolean); + -- Set on an array_subtype if there is an index constraint. + -- If not set, the subtype is unconstrained. + -- Field: Flag4 + function Get_Index_Constraint_Flag (Atype : Iir) return Boolean; + procedure Set_Index_Constraint_Flag (Atype : Iir; Flag : Boolean); + -- Condition of an assertion. -- Field: Field1 function Get_Assertion_Condition (Target : Iir) return Iir; diff --git a/iirs_utils.adb b/iirs_utils.adb index 9b441f75a..46e51ccfa 100644 --- a/iirs_utils.adb +++ b/iirs_utils.adb @@ -513,10 +513,11 @@ package body Iirs_Utils is return Get_Type_Declarator (Def) = Null_Iir; end Is_Anonymous_Type_Definition; - function Is_Unconstrained_Type_Definition (Def : Iir) return Boolean is + function Is_Fully_Constrained_Type (Def : Iir) return Boolean is begin - return Get_Kind (Def) in Iir_Kinds_Unconstrained_Array_Type_Definition; - end Is_Unconstrained_Type_Definition; + return Get_Kind (Def) not in Iir_Kinds_Composite_Type_Definition + or else Get_Constraint_State (Def) = Fully_Constrained; + end Is_Fully_Constrained_Type; function Is_Same_Profile (L, R: Iir) return Boolean is diff --git a/iirs_utils.ads b/iirs_utils.ads index 67baa832f..fce466c61 100644 --- a/iirs_utils.ads +++ b/iirs_utils.ads @@ -87,8 +87,8 @@ package Iirs_Utils is function Is_Anonymous_Type_Definition (Def : Iir) return Boolean; pragma Inline (Is_Anonymous_Type_Definition); - -- Return TRUE iff DEF is an unconstrained type (or subtype) definition. - function Is_Unconstrained_Type_Definition (Def : Iir) return Boolean; + -- Return TRUE iff DEF is a fully constrained type (or subtype) definition. + function Is_Fully_Constrained_Type (Def : Iir) return Boolean; -- Return true iff L and R have the same profile. -- L and R must be subprograms specification (or spec_body). diff --git a/name_table.adb b/name_table.adb index 85f65191f..af60ec0b7 100644 --- a/name_table.adb +++ b/name_table.adb @@ -89,9 +89,10 @@ package body Name_Table is if Names_Table.Allocate /= Null_Identifier then raise Program_Error; end if; + Strings_Table.Set_Last (1); Names_Table.Table (Null_Identifier) := (Length => 0, Hash => 0, - Name => 0, + Name => 1, Next => Null_Identifier, Info => 0); -- Store characters. @@ -83,7 +83,7 @@ package Nodes is -- Fields of Format_Medium: -- Odigit1 : Bit3_Type - -- Odigit2 : Bit3_Type + -- Odigit2 : Bit3_Type (odigit1) -- State3 : Bit2_Type -- State4 : Bit2_Type -- Field4 : Iir @@ -509,6 +509,13 @@ package body Parse is if C2 /= '*' then Bad_Operator_Symbol; end if; + when '?' => + if Vhdl_Std < Vhdl_08 then + Bad_Operator_Symbol; + elsif C2 /= '?' then + Bad_Operator_Symbol; + end if; + Id := Name_Op_Condition; when others => Bad_Operator_Symbol; Id := Name_Op_Equality; @@ -1291,7 +1298,7 @@ package body Parse is -- precond : ARRAY -- postcond: ?? -- - -- [ §3.2.1 ] + -- [ LRM93 3.2.1 ] -- array_type_definition ::= unconstrained_array_definition -- | constrained_array_definition -- @@ -1307,6 +1314,14 @@ package body Parse is -- index_constraint ::= ( discrete_range { , discrete_range } ) -- -- discrete_range ::= discrete_subtype_indication | range + -- + -- [ LRM08 5.3.2.1 ] + -- array_type_definition ::= unbounded_array_definition + -- | constrained_array_definition + -- + -- unbounded_array_definition ::= + -- ARRAY ( index_subtype_definition { , index_subtype_definition } ) + -- OF element_subtype_indication function Parse_Array_Definition return Iir is Index_Constrained : Boolean; @@ -1472,9 +1487,8 @@ package body Parse is -- element_subtype_definition ::= subtype_indication function Parse_Record_Definition return Iir_Record_Type_Definition is - use Iir_Chains.Element_Declaration_Chain_Handling; Res: Iir_Record_Type_Definition; - Last : Iir_Element_Declaration; + El_List : Iir_List; El: Iir_Element_Declaration; First : Iir; Pos: Iir_Index32; @@ -1482,9 +1496,10 @@ package body Parse is begin Res := Create_Iir (Iir_Kind_Record_Type_Definition); Set_Location (Res); + El_List := Create_Iir_List; + Set_Elements_Declaration_List (Res, El_List); Scan.Scan; Pos := 0; - Build_Init (Last); First := Null_Iir; loop pragma Assert (First = Null_Iir); @@ -1492,9 +1507,12 @@ package body Parse is loop El := Create_Iir (Iir_Kind_Element_Declaration); Set_Location (El); + if First = Null_Iir then + First := El; + end if; Expect (Tok_Identifier); Set_Identifier (El, Current_Identifier); - Append (Last, Res, El); + Append_Element (El_List, El); Set_Element_Position (El, Pos); Pos := Pos + 1; if First = Null_Iir then @@ -1507,15 +1525,12 @@ package body Parse is Expect (Tok_Colon); Scan.Scan; Subtype_Indication := Parse_Subtype_Indication; - while First /= Null_Iir loop - Set_Type (First, Subtype_Indication); - First := Get_Chain (First); - end loop; + Set_Type (First, Subtype_Indication); + First := Null_Iir; Expect (Tok_Semi_Colon); Scan.Scan; exit when Current_Token = Tok_End; end loop; - Set_Number_Element_Declaration (Res, Pos); Scan_Expect (Tok_Record); Scan.Scan; return Res; @@ -1792,32 +1807,174 @@ package body Parse is return Decl; end Parse_Type_Declaration; - -- precond : identifier + -- precond: '(' or identifier -- postcond: next token -- - -- [ §4.2 ] + -- [ LRM08 6.3 ] + -- + -- resolution_indication ::= + -- resolution_function_name | ( element_resolution ) + -- + -- element_resolution ::= + -- array_element_resolution | record_resolution + -- + -- array_element_resolution ::= resolution_indication + -- + -- record_resolution ::= + -- record_element_resolution { , record_element_resolution } + -- + -- record_element_resolution ::= + -- record_element_simple_name resolution_indication + function Parse_Resolution_Indication return Iir + is + Res : Iir; + Def : Iir; + Loc : Location_Type; + El_List : Iir_List; + El : Iir; + Id : Name_Id; + begin + if Current_Token = Tok_Identifier then + -- Resolution function name. + return Parse_Name (Allow_Indexes => False); + elsif Current_Token = Tok_Left_Paren then + -- Element resolution. + Loc := Get_Token_Location; + + Scan.Scan; -- Eat '(' + Res := Parse_Resolution_Indication; + if Current_Token = Tok_Identifier + or else Current_Token = Tok_Left_Paren + then + -- This was in fact a record_resolution. + if Get_Kind (Res) /= Iir_Kind_Simple_Name then + Error_Msg_Parse ("element name expected", Res); + return Null_Iir; + end if; + Id := Get_Identifier (Res); + Free_Iir (Res); + Def := Create_Iir (Iir_Kind_Record_Subtype_Definition); + Set_Location (Def, Loc); + El_List := Create_Iir_List; + Set_Elements_Declaration_List (Def, El_List); + loop + El := Create_Iir (Iir_Kind_Record_Element_Constraint); + Set_Location (El, Loc); + Set_Identifier (El, Id); + Set_Element_Declaration (El, Parse_Resolution_Indication); + Append_Element (El_List, El); + exit when Current_Token = Tok_Right_Paren; + Expect (Tok_Comma); + Scan.Scan; + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("record element identifier expected"); + exit; + end if; + Id := Current_Identifier; + Loc := Get_Token_Location; + Scan.Scan; + end loop; + else + Def := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Location (Def, Loc); + Set_Element_Subtype (Def, Res); + end if; + Expect (Tok_Right_Paren); + Scan.Scan; + return Def; + else + Error_Msg_Parse ("resolution indication expected"); + raise Parse_Error; + end if; + end Parse_Resolution_Indication; + + -- precond : '(' + -- postcond: next token + -- + -- [ LRM08 6.3 Subtype declarations ] + -- element_constraint ::= + -- array_constraint | record_constraint + -- + -- [ LRM08 5.3.2.1 Array types ] + -- array_constraint ::= + -- index_constraint [ array_element_constraint ] + -- | ( open ) [ array_element_constraint ] + -- + -- array_element_constraint ::= element_constraint + -- + -- RES is the resolution_indication of the subtype indication. + function Parse_Element_Constraint return Iir + is + Def : Iir; + El : Iir; + begin + -- Index_constraint. + Def := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Location (Def); + + -- Eat '('. + Scan.Scan; + + if Current_Token = Tok_Open then + -- Eat 'open'. + Scan.Scan; + else + Set_Index_Subtype_List (Def, Create_Iir_List); + -- index_constraint ::= (discrete_range {, discrete_range} ) + loop + -- accept parenthesis or comma. + El := Parse_Discrete_Range; + Append_Element (Get_Index_Subtype_List (Def), El); + exit when Current_Token = Tok_Right_Paren; + Expect (Tok_Comma); + Scan.Scan; + end loop; + end if; + Expect (Tok_Right_Paren); + Scan.Scan; + + if Current_Token = Tok_Left_Paren then + Set_Element_Subtype (Def, Parse_Element_Constraint); + end if; + return Def; + end Parse_Element_Constraint; + + -- precond : identifier or '(' + -- postcond: next token + -- + -- [ LRM93 4.2 ] -- subtype_indication ::= -- [ RESOLUTION_FUNCTION_name ] type_mark [ constraint ] -- - -- [ §4.2 ] -- constraint ::= range_constraint | index_constraint -- - -- [ §3.2.1] - -- index_constraint ::= ( discrete_range { , discrete_range } ) + -- [ LRM08 6.3 ] + -- subtype_indication ::= + -- [ resolution_indication ] type_mark [ constraint ] + -- + -- constraint ::= + -- range_constraint | array_constraint | record_constraint function Parse_Subtype_Indication (Name : Iir := Null_Iir) return Iir is Type_Mark : Iir; Def: Iir; - El: Iir; Resolution_Function: Iir; begin -- FIXME: location. Resolution_Function := Null_Iir; + Def := Null_Iir; if Name /= Null_Iir then Type_Mark := Name; else + if Current_Token = Tok_Left_Paren then + if Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("resolution_indication not allowed before vhdl08"); + end if; + Resolution_Function := Parse_Resolution_Indication; + end if; if Current_Token /= Tok_Identifier then Error_Msg_Parse ("type mark expected in a subtype indication"); raise Parse_Error; @@ -1826,28 +1983,19 @@ package body Parse is end if; if Current_Token = Tok_Identifier then + if Resolution_Function /= Null_Iir then + Error_Msg_Parse ("resolution function already indicated"); + end if; Resolution_Function := Type_Mark; Type_Mark := Parse_Type_Mark (Check_Paren => False); end if; case Current_Token is when Tok_Left_Paren => - -- Index_constraint. - Def := Create_Iir (Iir_Kind_Array_Subtype_Definition); - Set_Location (Def); + -- element_constraint. + Def := Parse_Element_Constraint; Set_Type_Mark (Def, Type_Mark); Set_Resolution_Function (Def, Resolution_Function); - Set_Index_Subtype_List (Def, Create_Iir_List); - -- index_constraint ::= (discrete_range {, discrete_range} ) - loop - -- accept parenthesis or comma. - Scan.Scan; - El := Parse_Discrete_Range; - Append_Element (Get_Index_Subtype_List (Def), El); - exit when Current_Token = Tok_Right_Paren; - Expect (Tok_Comma); - end loop; - Scan.Scan; when Tok_Range => -- range_constraint. @@ -1858,13 +2006,13 @@ package body Parse is Set_Resolution_Function (Def, Resolution_Function); when others => - if Resolution_Function = Null_Iir then - Def := Type_Mark; - else + if Resolution_Function /= Null_Iir then Def := Create_Iir (Iir_Kind_Subtype_Definition); Location_Copy (Def, Type_Mark); Set_Type_Mark (Def, Type_Mark); Set_Resolution_Function (Def, Resolution_Function); + else + Def := Type_Mark; end if; end case; return Def; @@ -4484,7 +4632,13 @@ package body Parse is case Current_Token is when Tok_To | Tok_Downto => - Actual := Parse_Range_Expression (Actual); + if Actual = Null_Iir then + -- Left expression is missing ie: (downto x). + Scan.Scan; + Actual := Parse_Expression; + else + Actual := Parse_Range_Expression (Actual); + end if; if Nbr_Assocs /= 1 then Error_Msg_Parse ("multi-dimensional slice is forbidden"); end if; @@ -1350,9 +1350,9 @@ package body Sem is Num : Iir_Int32; begin Inter := Get_Interpretation (Get_Identifier (Decl)); - if Valid_Interpretation (Inter) + while Valid_Interpretation (Inter) and then Is_In_Current_Declarative_Region (Inter) - then + loop -- There is a previous declaration with the same name in the -- current declarative region. Prev := Get_Declaration (Inter); @@ -1372,15 +1372,21 @@ package body Sem is Set_Overload_Number (Prev, 1); Num := 2; end if; + Set_Overload_Number (Decl, Num); + return; + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + -- Implicit declarations aren't taken into account (as they + -- are mangled differently). + Inter := Get_Next_Interpretation (Inter); when others => -- Can be an enumeration literal or an error. - Num := 0; + Set_Overload_Number (Decl, 0); + return; end case; - else - -- No previous declaration in the current declarative region. - Num := 0; - end if; - Set_Overload_Number (Decl, Num); + end loop; + -- No previous declaration in the current declarative region. + Set_Overload_Number (Decl, 0); end Set_Subprogram_Overload_Number; -- Check requirements on number of interfaces for subprogram specification @@ -1421,9 +1427,7 @@ package body Sem is end if; Error_Msg_Sem ("unary operator must have a single parameter", Subprg); - when Name_Logical_Operators - | Name_Xnor - | Name_Mod + when Name_Mod | Name_Rem | Name_Op_Mul | Name_Op_Div @@ -1442,7 +1446,28 @@ package body Sem is if Nbr_Interfaces = 2 then return; end if; - Error_Msg_Sem ("binary operator must have two parameters", Subprg); + Error_Msg_Sem + ("binary operators must have two parameters", Subprg); + when Name_Logical_Operators + | Name_Xnor => + -- LRM08 4.5.2 Operator overloading + -- For each of the "+", "-", "and", "or", "xor", "nand", "nor" + -- and "xnor", overloading is allowed both as a unary operator + -- and as a binary operator. + if Nbr_Interfaces = 2 then + return; + end if; + if Nbr_Interfaces = 1 then + if Vhdl_Std >= Vhdl_08 then + return; + end if; + Error_Msg_Sem + ("logical operators must have two parameters before vhdl08", + Subprg); + else + Error_Msg_Sem + ("logical operators must have two parameters", Subprg); + end if; when Name_Op_Plus | Name_Op_Minus => -- LRM93 2.3.1 diff --git a/sem_assocs.adb b/sem_assocs.adb index 1b5f4807d..e89b29c7e 100644 --- a/sem_assocs.adb +++ b/sem_assocs.adb @@ -638,16 +638,14 @@ package body Sem_Assocs is procedure Finish_Individual_Assoc_Record (Assoc : Iir; Atype : Iir) is - Base_Type : Iir_Record_Type_Definition; - Matches : Iir_Array_Acc; + Base_Type : constant Iir_Record_Type_Definition := Get_Base_Type (Atype); + El_List : constant Iir_List := Get_Elements_Declaration_List (Base_Type); + Matches : Iir_Array (0 .. Get_Nbr_Elements (El_List) - 1); Ch : Iir; Pos : Natural; Rec_El : Iir; begin - Base_Type := Get_Base_Type (Atype); - Matches := new Iir_Array - (0 .. Natural (Get_Number_Element_Declaration (Base_Type)) - 1); - Matches.all := (others => Null_Iir); + Matches := (others => Null_Iir); Ch := Get_Individual_Association_Chain (Assoc); while Ch /= Null_Iir loop Rec_El := Get_Name (Ch); @@ -661,12 +659,11 @@ package body Sem_Assocs is end if; Ch := Get_Chain (Ch); end loop; - Rec_El := Get_Element_Declaration_Chain (Base_Type); for I in Matches'Range loop + Rec_El := Get_Nth_Element (El_List, I); if Matches (I) = Null_Iir then Error_Msg_Sem (Disp_Node (Rec_El) & " not associated", Assoc); end if; - Rec_El := Get_Chain (Rec_El); end loop; Set_Actual_Type (Assoc, Atype); end Finish_Individual_Assoc_Record; @@ -689,10 +686,11 @@ package body Sem_Assocs is case Get_Kind (Atype) is when Iir_Kind_Array_Subtype_Definition => Finish_Individual_Assoc_Array_Subtype (Assoc, Atype); - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => - Set_Actual_Type - (Assoc, Create_Array_Subtype (Atype, Get_Location (Assoc))); + when Iir_Kind_Array_Type_Definition => + Atype := Create_Array_Subtype (Atype, Get_Location (Assoc)); + Set_Index_Constraint_Flag (Atype, True); + Set_Constraint_State (Atype, Fully_Constrained); + Set_Actual_Type (Assoc, Atype); Finish_Individual_Assoc_Array (Assoc, Assoc, 1); when Iir_Kind_Record_Type_Definition | Iir_Kind_Record_Subtype_Definition => @@ -756,36 +754,6 @@ package body Sem_Assocs is Finish_Individual_Association (Iassoc); end Sem_Individual_Association; - - -- EXPR is a formal or actual expression. - -- Extract conversion function CONV from EXPR, if: - -- * argument of the function is of type ARG_TYPE. - -- * return type of the function is RES_TYPE if RES_TYPE /= Null_Iir - -- or any type if RES_TYPE = Null_Iir. --- procedure Sem_Conversion (Expr : in out Iir; Conv : out Iir) --- is --- Assoc : Iir; --- begin --- Conv := Null_Iir; --- case Get_Kind (Expr) is --- when Iir_Kind_Parenthesis_Name => --- raise Internal_Error; --- when Iir_Kind_Function_Call => --- Conv := Get_Implementation (Expr); --- Assoc := Get_Parameter_Association_Chain (Expr); --- Expr := Get_Actual (Assoc); --- Free_Iir (Assoc); --- Set_Use_Flag (Conv, True); --- when Iir_Kind_Type_Conversion => --- Assoc := Get_Expression (Expr); --- Conv := Expr; --- Expr := Assoc; --- --Set_Expression (Conv, Null_Iir); --- when others => --- return; --- end case; --- end Sem_Conversion; - function Is_Conversion_Function (Assoc_Chain : Iir) return Boolean is begin @@ -955,8 +923,8 @@ package body Sem_Assocs is Name_Type := Null_Iir; return; end if; - Rec_El := Find_Name_In_Chain - (Get_Element_Declaration_Chain (Base_Type), + Rec_El := Find_Name_In_List + (Get_Elements_Declaration_List (Base_Type), Get_Suffix_Identifier (Name)); if Rec_El = Null_Iir then Name_Type := Null_Iir; @@ -1394,14 +1362,48 @@ package body Sem_Assocs is end if; end if; + -- LRM08 6.5.7 Association lists + -- The formal part of a named association element may be in the form of + -- a function call [...] if and only if the formal is an interface + -- object, the mode of the formal is OUT, INOUT, BUFFER or LINKAGE [...] Set_Out_Conversion (Assoc, Out_Conv); + if Out_Conv /= Null_Iir + and then Get_Mode (Inter) = Iir_In_Mode + then + Error_Msg_Sem + ("can't use an out conversion for an in interface", Assoc); + end if; + + -- LRM08 6.5.7 Association lists + -- The actual part of an association element may be in the form of a + -- function call [...] if and only if the mode of the format is IN, + -- INOUT or LINKAGE [...] Set_In_Conversion (Assoc, In_Conv); + if In_Conv /= Null_Iir + and then Get_Mode (Inter) in Iir_Buffer_Mode .. Iir_Out_Mode + then + Error_Msg_Sem + ("can't use an in conversion for an out/buffer interface", Assoc); + end if; + + -- FIXME: LRM refs + -- This is somewhat wrong. A missing conversion is not an error but + -- may result in a type mismatch. + if Get_Mode (Inter) = Iir_Inout_Mode then + if In_Conv = Null_Iir and then Out_Conv /= Null_Iir then + Error_Msg_Sem + ("out conversion without corresponding in conversion", Assoc); + elsif In_Conv /= Null_Iir and then Out_Conv = Null_Iir then + Error_Msg_Sem + ("in conversion without corresponding out conversion", Assoc); + end if; + end if; Set_Actual (Assoc, Actual); -- Semantize actual. Expr := Sem_Expression (Actual, Res_Type); if Expr /= Null_Iir then - Expr := Eval_Expr_If_Static (Expr); + Expr := Eval_Expr_Check_If_Static (Expr, Res_Type); Set_Actual (Assoc, Expr); if In_Conv = Null_Iir and then Out_Conv = Null_Iir then if not Check_Implicit_Conversion (Formal_Type, Expr) then @@ -1667,7 +1669,7 @@ package body Sem_Assocs is if not Finish then raise Internal_Error; end if; - if Is_Unconstrained_Type_Definition (Get_Type (Inter)) + if not Is_Fully_Constrained_Type (Get_Type (Inter)) then Error_Msg_Sem ("unconstrained " & Disp_Node (Inter) diff --git a/sem_decls.adb b/sem_decls.adb index f5556495d..4d41c6492 100644 --- a/sem_decls.adb +++ b/sem_decls.adb @@ -88,6 +88,8 @@ package body Sem_Decls is if Default_Value /= Null_Iir and then A_Type /= Null_Iir then Deferred_Constant_Allowed := True; Default_Value := Sem_Expression (Default_Value, A_Type); + Default_Value := + Eval_Expr_Check_If_Static (Default_Value, A_Type); Deferred_Constant_Allowed := False; Check_Read (Default_Value); end if; @@ -307,6 +309,12 @@ package body Sem_Decls is end loop; end Sem_Interface_Chain; + function Is_One_Dimensional (Array_Def : Iir) return Boolean + is + begin + return Get_Nbr_Elements (Get_Index_Subtype_List (Array_Def)) = 1; + end Is_One_Dimensional; + -- LRM93 7.2.2 -- A discrete array is a one-dimensional array whose elements are of a -- discrete type. @@ -321,7 +329,7 @@ package body Sem_Decls is raise Internal_Error; -- return False; end case; - if Get_Nbr_Elements (Get_Index_Subtype_List (Def)) /= 1 then + if not Is_One_Dimensional (Def) then return False; end if; if Get_Kind (Get_Element_Subtype (Def)) @@ -454,20 +462,20 @@ package body Sem_Decls is Set_Mode (Inter, Iir_Out_Mode); Set_Base_Name (Inter, Inter); Append (Last_Interface, Proc, Inter); - case Get_Kind (Type_Mark) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => - Inter := Create_Iir (Iir_Kind_Variable_Interface_Declaration); - Set_Identifier (Inter, Std_Names.Name_Length); - Set_Location (Inter, Loc); - Set_Type (Inter, Std_Package.Natural_Subtype_Definition); - Set_Mode (Inter, Iir_Out_Mode); - Set_Base_Name (Inter, Inter); - Append (Last_Interface, Proc, Inter); - Set_Implicit_Definition (Proc, Iir_Predefined_Read_Length); - when others => - Set_Implicit_Definition (Proc, Iir_Predefined_Read); - end case; + if Get_Kind (Type_Mark) in Iir_Kinds_Array_Type_Definition + and then Get_Constraint_State (Type_Mark) /= Fully_Constrained + then + Inter := Create_Iir (Iir_Kind_Variable_Interface_Declaration); + Set_Identifier (Inter, Std_Names.Name_Length); + Set_Location (Inter, Loc); + Set_Type (Inter, Std_Package.Natural_Subtype_Definition); + Set_Mode (Inter, Iir_Out_Mode); + Set_Base_Name (Inter, Inter); + Append (Last_Interface, Proc, Inter); + Set_Implicit_Definition (Proc, Iir_Predefined_Read_Length); + else + Set_Implicit_Definition (Proc, Iir_Predefined_Read); + end if; Compute_Subprogram_Hash (Proc); -- Add it to the list. Insert_Incr (Last, Proc); @@ -656,33 +664,54 @@ package body Sem_Decls is Element_Type := Get_Element_Subtype (Type_Definition); - Add_Operation (Name_Op_Concatenation, - Iir_Predefined_Array_Array_Concat, - Binary_Chain, - Type_Definition); - - Inter_Chain := Create_Anonymous_Interface (Element_Type); - Set_Chain (Inter_Chain, Unary_Chain); - Add_Operation (Name_Op_Concatenation, - Iir_Predefined_Element_Array_Concat, - Inter_Chain, - Type_Definition); + if Is_One_Dimensional (Type_Definition) then + Add_Operation (Name_Op_Concatenation, + Iir_Predefined_Array_Array_Concat, + Binary_Chain, + Type_Definition); - Inter_Chain := Create_Anonymous_Interface (Type_Definition); - Set_Chain (Inter_Chain, - Create_Anonymous_Interface (Element_Type)); - Add_Operation (Name_Op_Concatenation, - Iir_Predefined_Array_Element_Concat, + Inter_Chain := Create_Anonymous_Interface (Element_Type); + Set_Chain (Inter_Chain, Unary_Chain); + Add_Operation (Name_Op_Concatenation, + Iir_Predefined_Element_Array_Concat, Inter_Chain, Type_Definition); - Inter_Chain := Create_Anonymous_Interface (Element_Type); - Set_Chain (Inter_Chain, - Create_Anonymous_Interface (Element_Type)); - Add_Operation (Name_Op_Concatenation, - Iir_Predefined_Element_Element_Concat, - Inter_Chain, - Type_Definition); + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain (Inter_Chain, + Create_Anonymous_Interface (Element_Type)); + Add_Operation (Name_Op_Concatenation, + Iir_Predefined_Array_Element_Concat, + Inter_Chain, + Type_Definition); + + Inter_Chain := Create_Anonymous_Interface (Element_Type); + Set_Chain (Inter_Chain, + Create_Anonymous_Interface (Element_Type)); + Add_Operation (Name_Op_Concatenation, + Iir_Predefined_Element_Element_Concat, + Inter_Chain, + Type_Definition); + + -- LRM08 5.3.2.4 Predefined operations on array type + -- + -- Given a type declaration that declares a one-dimensional + -- array type T whose element type is a character type that + -- contains only character literals, the following operation + -- is implicitely declared immediately following the type + -- declaration + if Vhdl_Std >= Vhdl_08 + and then String_Type_Definition /= Null_Iir + and then Get_Kind (Get_Base_Type (Element_Type)) + = Iir_Kind_Enumeration_Type_Definition + and then Get_Only_Characters_Flag (Element_Type) + then + Add_Operation (Name_To_String, + Iir_Predefined_Array_To_String, + Unary_Chain, + String_Type_Definition); + end if; + end if; if Is_Discrete_Array (Type_Definition) then if Element_Type = Std_Package.Boolean_Type_Definition then @@ -1104,7 +1133,6 @@ package body Sem_Decls is procedure Sem_Subtype_Declaration (Decl: Iir; Is_Global : Boolean) is Def: Iir; - Res: Iir; begin -- Real hack to skip subtype declarations of anonymous type decls. if Get_Visible_Flag (Decl) then @@ -1121,63 +1149,12 @@ package body Sem_Decls is end if; if not Is_Anonymous_Type_Definition (Def) then - case Get_Kind (Def) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition => - -- no limits, makes an alias. - Res := Create_Iir (Get_Kind (Def)); - Set_Range_Constraint (Res, Get_Range_Constraint (Def)); - Set_Resolution_Function (Res, Get_Resolution_Function (Def)); - when Iir_Kind_Enumeration_Type_Definition => - -- makes an alias. - Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); - Set_Type_Mark (Res, Def); - Set_Range_Constraint (Res, Get_Range_Constraint (Def)); - when Iir_Kind_Access_Subtype_Definition - | Iir_Kind_Access_Type_Definition => - -- Make an alias. - Res := Create_Iir (Iir_Kind_Access_Subtype_Definition); - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => - Res := - Create_Iir (Iir_Kind_Unconstrained_Array_Subtype_Definition); - Set_Type_Staticness (Res, Get_Type_Staticness (Def)); - if Get_Kind (Def) /= Iir_Kind_Array_Type_Definition then - Set_Resolution_Function - (Res, Get_Resolution_Function (Def)); - end if; - Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); - Set_Type_Mark (Res, Def); - Set_Index_Subtype_List (Res, Get_Index_Subtype_List (Def)); - Set_Element_Subtype (Res, Get_Element_Subtype (Def)); - when Iir_Kind_Array_Subtype_Definition => - Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); - Set_Resolution_Function (Res, Get_Resolution_Function (Def)); - Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); - Set_Type_Mark (Res, Def); - Set_Index_Subtype_List (Res, Get_Index_Subtype_List (Def)); - Set_Element_Subtype (Res, Get_Element_Subtype (Def)); - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - Res := Create_Iir (Iir_Kind_Record_Subtype_Definition); - Set_Type_Staticness (Res, Get_Type_Staticness (Def)); - if Get_Kind (Def) /= Iir_Kind_Record_Type_Definition then - Set_Resolution_Function - (Res, Get_Resolution_Function (Def)); - end if; - Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); - when others => - -- FIXME: todo - Error_Kind ("sem_subtype_declaration", Def); - end case; - Location_Copy (Res, Decl); - Set_Base_Type (Res, Get_Base_Type (Def)); - Set_Type_Staticness (Res, Get_Type_Staticness (Def)); - Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Def)); - Def := Res; + -- There is no added constraints and therefore the subtype + -- declaration is in fact an alias of the type. + Def := Copy_Subtype_Indication (Def); + Location_Copy (Def, Decl); end if; + Set_Type (Decl, Def); Set_Type_Declarator (Def, Decl); Name_Visible (Decl); @@ -1267,7 +1244,7 @@ package body Sem_Decls is end if; end if; Set_Type (Decl, Atype); - Default_Value := Eval_Expr_If_Static (Default_Value); + Default_Value := Eval_Expr_Check_If_Static (Default_Value, Atype); Set_Default_Value (Decl, Default_Value); Set_Base_Name (Decl, Decl); Set_Name_Staticness (Decl, Locally); @@ -1360,11 +1337,6 @@ package body Sem_Decls is end if; end if; Set_Expr_Staticness (Decl, Staticness); - - if Staticness = Locally then - Set_Default_Value - (Decl, Eval_Expr_Check (Default_Value, Atype)); - end if; end if; when Iir_Kind_Signal_Declaration => @@ -1489,7 +1461,7 @@ package body Sem_Decls is -- For a variable or signal declared by an object declaration, the -- subtype indication of the corressponding object declaration -- must define a constrained array subtype. - if not Sem_Is_Constrained (Atype) then + if not Is_Fully_Constrained_Type (Atype) then Error_Msg_Sem ("declaration of " & Disp_Node (Decl) & " with unconstrained " & Disp_Node (Atype) diff --git a/sem_expr.adb b/sem_expr.adb index b26decdeb..74b7a1d4e 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -168,6 +168,7 @@ package body Sem_Expr is | Iir_Kind_Component_Declaration | Iir_Kinds_Procedure_Declaration | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute | Iir_Kind_Element_Declaration => Error_Msg_Sem (Disp_Node (Expr) & " not allowed in an expression", Loc); @@ -228,12 +229,15 @@ package body Sem_Expr is if Targ_Type = Null_Iir or else Expr = Null_Iir then return True; end if; - if Get_Kind (Targ_Type) /= Iir_Kind_Array_Subtype_Definition then + if Get_Kind (Targ_Type) /= Iir_Kind_Array_Subtype_Definition + or else Get_Constraint_State (Targ_Type) /= Fully_Constrained + then return True; end if; Expr_Type := Get_Type (Expr); if Expr_Type = Null_Iir or else Get_Kind (Expr_Type) /= Iir_Kind_Array_Subtype_Definition + or else Get_Constraint_State (Expr_Type) /= Fully_Constrained then return True; end if; @@ -645,10 +649,18 @@ package body Sem_Expr is -- FIXME: catch phys/phys. Set_Type (Expr, Integer_Type_Definition); elsif Range_Type = Universal_Integer_Type_Definition then - -- GHDL: this is not allowed, however often used: - -- eg: for i in 0 to v'length + 1 loop - -- eg: for i in -1 to 1 loop - if Flags.Vhdl_Std = Vhdl_93c then + if Vhdl_Std >= Vhdl_08 then + -- LRM08 5.3.2.2 + -- For a discrete range used in a constrained array definition + -- and defined by a range, an implicit conversion to the + -- predefined type INTEGER is assumed if the type of both bounds + -- (prior the implicit conversion) is the type universal_integer. + null; + elsif Vhdl_Std = Vhdl_93c then + -- GHDL: this is not allowed, however often used: + -- eg: for i in 0 to v'length + 1 loop + -- eg: for i in -1 to 1 loop + -- Be tolerant. Warning_Msg_Sem ("universal integer bound must be numeric literal " & "or attribute", Expr); @@ -1826,48 +1838,231 @@ package body Sem_Expr is El_Type := Get_Base_Type (Get_Element_Subtype (Lit_Base_Type)); Len := Sem_String_Literal (Lit, El_Type); - case Get_Kind (Lit_Type) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => - -- Set type of the string literal, - -- according to LRM93 7.3.2.2. - N_Type := Create_Unidim_Array_By_Length - (Lit_Base_Type, Iir_Int64 (Len), Lit); - Set_Type (Lit, N_Type); - when Iir_Kind_Array_Subtype_Definition => - Index_Type := Get_First_Element - (Get_Index_Subtype_List (Lit_Type)); - if Get_Type_Staticness (Index_Type) = Locally then - if Eval_Discrete_Type_Length (Index_Type) /= Iir_Int64 (Len) - then - Error_Msg_Sem ("string length does not match that of " - & Disp_Node (Index_Type), Lit); - end if; - else - -- FIXME: It this right ? - -- We really need a locally static type. - N_Type := Create_Unidim_Array_By_Length - (Lit_Base_Type, Iir_Int64 (Len), Lit); - Set_Type (Lit, N_Type); + if Get_Constraint_State (Lit_Type) = Fully_Constrained then + Index_Type := Get_First_Element + (Get_Index_Subtype_List (Lit_Type)); + if Get_Type_Staticness (Index_Type) = Locally then + if Eval_Discrete_Type_Length (Index_Type) /= Iir_Int64 (Len) + then + Error_Msg_Sem ("string length does not match that of " + & Disp_Node (Index_Type), Lit); end if; - when others => - Error_Kind ("sem_string_literal_type", Lit_Type); - end case; + return; + end if; + end if; + + -- Set type of the string literal, + -- according to LRM93 7.3.2.2. + N_Type := Create_Unidim_Array_By_Length + (Lit_Base_Type, Iir_Int64 (Len), Lit); + Set_Type (Lit, N_Type); end Sem_String_Literal; + generic + -- Compare two elements, return true iff OP1 < OP2. + with function Lt (Op1, Op2 : Natural) return Boolean; + + -- Swap two elements. + with procedure Swap (From : Natural; To : Natural); + package Heap_Sort is + -- Heap sort the N elements. + procedure Sort (N : Natural); + end Heap_Sort; + + package body Heap_Sort is + -- An heap is an almost complete binary tree whose each edge is less + -- than or equal as its decendent. + + -- Bubble down element I of a partially ordered heap of length N in + -- array ARR. + procedure Bubble_Down (I, N : Natural) + is + Child : Natural; + Parent : Natural := I; + begin + loop + Child := 2 * Parent; + if Child < N and then Lt (Child, Child + 1) then + Child := Child + 1; + end if; + exit when Child > N; + exit when not Lt (Parent, Child); + Swap (Parent, Child); + Parent := Child; + end loop; + end Bubble_Down; + + -- Heap sort of ARR. + procedure Sort (N : Natural) + is + begin + -- Heapify + for I in reverse 1 .. N / 2 loop + Bubble_Down (I, N); + end loop; + + -- Sort + for I in reverse 2 .. N loop + Swap (1, I); + Bubble_Down (1, I - 1); + end loop; + end Sort; + end Heap_Sort; + procedure Sem_String_Choices_Range (Choice_Chain : Iir; Sel : Iir) is -- True if others choice is present. Has_Others : Boolean; + -- Number of simple choices. + Nbr_Choices : Natural; + -- Type of SEL. Sel_Type : Iir; + -- Type of the element of SEL. + Sel_El_Type : Iir; + -- Number of literals in the element type. + Sel_El_Length : Iir_Int64; + -- List of literals. + Sel_El_Literal_List : Iir_List; + -- Length of SEL (number of characters in SEL). Sel_Length : Iir_Int64; + -- Array of choices. + Arr : Iir_Array_Acc; + Index : Natural; + + -- True if length of a choice mismatches + Has_Length_Error : Boolean := False; + El : Iir; + type Str_Info is record + El : Iir; + Ptr : String_Fat_Acc; + Len : Natural; + Lit_0 : Iir; + Lit_1 : Iir; + List : Iir_List; + end record; + + -- Fill Res from EL. This is used to speed up Lt and Eq operations. + procedure Get_Info (El : Iir; Res : out Str_Info) + is + Expr : constant Iir := Get_Expression (El); + begin + case Get_Kind (Expr) is + when Iir_Kind_Simple_Aggregate => + Res := Str_Info'(El => Expr, + Ptr => null, + Len => 0, + Lit_0 | Lit_1 => Null_Iir, + List => Get_Simple_Aggregate_List (Expr)); + Res.Len := Get_Nbr_Elements (Res.List); + when Iir_Kind_Bit_String_Literal => + Res := Str_Info'(El => Expr, + Ptr => Get_String_Fat_Acc (Expr), + Len => Get_String_Length (Expr), + Lit_0 => Get_Bit_String_0 (Expr), + Lit_1 => Get_Bit_String_1 (Expr), + List => Null_Iir_List); + when Iir_Kind_String_Literal => + Res := Str_Info'(El => Expr, + Ptr => Get_String_Fat_Acc (Expr), + Len => Get_String_Length (Expr), + Lit_0 | Lit_1 => Null_Iir, + List => Null_Iir_List); + when others => + Error_Kind ("sem_string_choice_range.get_info", Expr); + end case; + end Get_Info; + + -- Return the position of element IDX of STR. + function Get_Pos (Str : Str_Info; Idx : Natural) return Iir_Int32 + is + S : Iir; + C : Character; + begin + case Get_Kind (Str.El) is + when Iir_Kind_Simple_Aggregate => + S := Get_Nth_Element (Str.List, Idx); + when Iir_Kind_String_Literal => + C := Str.Ptr (Idx + 1); + -- FIXME: build a table from character to position. + -- This linear search is O(n)! + S := Find_Name_In_List (Sel_El_Literal_List, + Name_Table.Get_Identifier (C)); + when Iir_Kind_Bit_String_Literal => + C := Str.Ptr (Idx + 1); + case C is + when '0' => + S := Str.Lit_0; + when '1' => + S := Str.Lit_1; + when others => + raise Internal_Error; + end case; + when others => + Error_Kind ("sem_string_choice_range.get_pos", Str.El); + end case; + return Get_Enum_Pos (S); + end Get_Pos; + + -- Compare two elements of ARR. + -- Return true iff OP1 < OP2. + function Lt (Op1, Op2 : Natural) return Boolean + is + Str1, Str2 : Str_Info; + P1, P2 : Iir_Int32; + begin + Get_Info (Arr (Op1), Str1); + Get_Info (Arr (Op2), Str2); + if Str1.Len /= Str2.Len then + raise Internal_Error; + end if; + + for I in 0 .. Natural (Sel_Length - 1) loop + P1 := Get_Pos (Str1, I); + P2 := Get_Pos (Str2, I); + if P1 /= P2 then + if P1 < P2 then + return True; + else + return False; + end if; + end if; + end loop; + return False; + end Lt; + + function Eq (Op1, Op2 : Natural) return Boolean + is + Str1, Str2 : Str_Info; + begin + Get_Info (Arr (Op1), Str1); + Get_Info (Arr (Op2), Str2); + + for I in 0 .. Natural (Sel_Length - 1) loop + if Get_Pos (Str1, I) /= Get_Pos (Str2, I) then + return False; + end if; + end loop; + return True; + end Eq; + + procedure Swap (From : Natural; To : Natural) + is + Tmp : Iir; + begin + Tmp := Arr (To); + Arr (To) := Arr (From); + Arr (From) := Tmp; + end Swap; + + package Str_Heap_Sort is new Heap_Sort (Lt => Lt, Swap => Swap); + procedure Sem_Simple_Choice (Choice : Iir) is Expr : Iir; @@ -1878,11 +2073,13 @@ package body Sem_Expr is -- the same length as that of the case expression. Expr := Sem_Expression (Get_Expression (Choice), Sel_Type); if Expr = Null_Iir then + Has_Length_Error := True; return; end if; Set_Expression (Choice, Expr); if Get_Expr_Staticness (Expr) < Locally then Error_Msg_Sem ("choice must be locally static expression", Expr); + Has_Length_Error := True; return; end if; Expr := Eval_Expr (Expr); @@ -1890,6 +2087,7 @@ package body Sem_Expr is if Eval_Discrete_Type_Length (Get_String_Type_Bound_Type (Get_Type (Expr))) /= Sel_Length then + Has_Length_Error := True; Error_Msg_Sem ("value not of the same length of the case expression", Expr); return; @@ -1912,8 +2110,13 @@ package body Sem_Expr is end if; Sel_Length := Eval_Discrete_Type_Length (Get_String_Type_Bound_Type (Sel_Type)); + Sel_El_Type := Get_Element_Subtype (Sel_Type); + Sel_El_Length := Eval_Discrete_Type_Length (Sel_El_Type); + Sel_El_Literal_List := Get_Enumeration_Literal_List + (Get_Base_Type (Sel_El_Type)); Has_Others := False; + Nbr_Choices := 0; El := Choice_Chain; while El /= Null_Iir loop case Get_Kind (El) is @@ -1923,6 +2126,7 @@ package body Sem_Expr is Error_Msg_Sem ("range choice are not allowed for non-discrete type", El); when Iir_Kind_Choice_By_Expression => + Nbr_Choices := Nbr_Choices + 1; Sem_Simple_Choice (El); when Iir_Kind_Choice_By_Others => if Has_Others then @@ -1938,10 +2142,65 @@ package body Sem_Expr is El := Get_Chain (El); end loop; - -- FIXME: - -- * check for duplicate choices. - -- * check for leaking choices. - -- (should eval strings and bit-strings). + -- Null choices. + if Sel_Length = 0 then + return; + end if; + if Has_Length_Error then + return; + end if; + + -- LRM 8.8 + -- + -- If the expression is the name of an object whose subtype is locally + -- static, wether a scalar type or an array type, then each value of the + -- subtype must be represented once and only once in the set of choices + -- of the case statement and no other value is allowed; [...] + + -- 1. Allocate Arr and fill it + Arr := new Iir_Array (1 .. Nbr_Choices); + Index := 0; + El := Choice_Chain; + while El /= Null_Iir loop + if Get_Kind (El) = Iir_Kind_Choice_By_Expression then + Index := Index + 1; + Arr (Index) := El; + end if; + El := Get_Chain (El); + end loop; + + -- 2. Sort Arr + Str_Heap_Sort.Sort (Nbr_Choices); + + -- 3. Check for duplicate choices + for I in 1 .. Nbr_Choices - 1 loop + if Eq (I, I + 1) then + Error_Msg_Sem ("duplicate choice with choice at " & + Disp_Location (Arr (I + 1)), + Arr (I)); + exit; + end if; + end loop; + + -- 4. Free Arr + Free (Arr); + + -- Check for missing choice. + -- Do not try to compute the expected number of choices as this can + -- easily overflow. + if not Has_Others then + declare + Nbr : Iir_Int64 := Iir_Int64 (Nbr_Choices); + begin + for I in 1 .. Sel_Length loop + Nbr := Nbr / Sel_El_Length; + if Nbr = 0 then + Error_Msg_Sem ("missing choice(s)", Choice_Chain); + exit; + end if; + end loop; + end; + end if; end Sem_String_Choices_Range; function Is_Name (Name : Iir) return Boolean @@ -2115,37 +2374,7 @@ package body Sem_Expr is Arr (From) := Tmp; end Swap; - -- Bubble down element I of a partially ordered heap of length N in - -- array ARR. - procedure Bubble_Down (I, N : Natural) - is - Child : Natural; - begin - Child := 2 * I; - if Child < N and then Lt (Child, Child + 1) then - Child := Child + 1; - end if; - if Child <= N and then Lt (I, Child) then - Swap (I, Child); - Bubble_Down (Child, N); - end if; - end Bubble_Down; - - -- Heap sort of ARR. - procedure Heap_Sort (N : Natural) - is - begin - -- Heapify - for I in reverse 1 .. N / 2 loop - Bubble_Down (I, N); - end loop; - - -- Sort - for I in reverse 2 .. N loop - Swap (1, I); - Bubble_Down (1, I - 1); - end loop; - end Heap_Sort; + package Disc_Heap_Sort is new Heap_Sort (Lt => Lt, Swap => Swap); begin Low := Null_Iir; High := Null_Iir; @@ -2309,7 +2538,7 @@ package body Sem_Expr is -- Third: -- Sort the list - Heap_Sort (Index); + Disc_Heap_Sort.Sort (Index); -- Set low and high bounds. if Index > 0 then @@ -2481,12 +2710,13 @@ package body Sem_Expr is function Sem_Record_Aggregate (Aggr: Iir_Aggregate; A_Type: Iir) return boolean is - Base_Type : Iir; + Base_Type : constant Iir := Get_Base_Type (A_Type); + El_List : constant Iir_List := Get_Elements_Declaration_List (Base_Type); -- Type of the element. El_Type : Iir; - Matches: Iir_Array_Acc; + Matches: Iir_Array (0 .. Get_Nbr_Elements (El_List) - 1); Ok : Boolean; -- Add a choice for element REC_EL. @@ -2532,8 +2762,8 @@ package body Sem_Expr is Ok := False; return Ass; end if; - Aggr_El := Find_Name_In_Chain - (Get_Element_Declaration_Chain (Base_Type), Get_Identifier (Expr)); + Aggr_El := Find_Name_In_List + (Get_Elements_Declaration_List (Base_Type), Get_Identifier (Expr)); if Aggr_El = Null_Iir then Error_Msg_Sem ("record has no such element " & Disp_Node (Ass), Ass); @@ -2556,20 +2786,17 @@ package body Sem_Expr is El, Prev_El : Iir; Expr: Iir; Has_Named : Boolean; - Rec_El : Iir_Element_Declaration; + Rec_El_Index : Natural; Value_Staticness : Iir_Staticness; begin Ok := True; Assoc_Chain := Get_Association_Choices_Chain (Aggr); - Base_Type := Get_Base_Type (A_Type); - Matches := new Iir_Array - (0 .. Natural (Get_Number_Element_Declaration (Base_Type)) - 1); - Matches.all := (others => Null_Iir); + Matches := (others => Null_Iir); Value_Staticness := Locally; El_Type := Null_Iir; Has_Named := False; - Rec_El := Get_Element_Declaration_Chain (Base_Type); + Rec_El_Index := 0; Prev_El := Null_Iir; El := Assoc_Chain; while El /= Null_Iir loop @@ -2586,12 +2813,12 @@ package body Sem_Expr is if Has_Named then Error_Msg_Sem ("positional association after named one", El); Ok := False; - elsif Rec_El = Null_Iir then + elsif Rec_El_Index > Matches'Last then Error_Msg_Sem ("too many elements", El); exit; else - Add_Match (El, Rec_El); - Rec_El := Get_Chain (Rec_El); + Add_Match (El, Get_Nth_Element (El_List, Rec_El_Index)); + Rec_El_Index := Rec_El_Index + 1; end if; when Iir_Kind_Choice_By_Expression => Has_Named := True; @@ -2611,17 +2838,13 @@ package body Sem_Expr is end if; declare Found : Boolean := False; - Rec_El : Iir_Element_Declaration; begin - Rec_El := Get_Element_Declaration_Chain (Base_Type); - for I in Matches.all'Range loop + for I in Matches'Range loop if Matches (I) = Null_Iir then - Add_Match (El, Rec_El); + Add_Match (El, Get_Nth_Element (El_List, I)); Found := True; end if; - Rec_El := Get_Chain (Rec_El); end loop; - pragma Assert (Rec_El = Null_Iir); if not Found then Error_Msg_Sem ("no element for choice others", El); Ok := False; @@ -2655,15 +2878,14 @@ package body Sem_Expr is end loop; -- Check for missing associations. - El := Get_Element_Declaration_Chain (Base_Type); - for I in Matches.all'Range loop + for I in Matches'Range loop if Matches (I) = Null_Iir then - Error_Msg_Sem ("no value for " & Disp_Node (El), Aggr); + Error_Msg_Sem + ("no value for " & Disp_Node (Get_Nth_Element (El_List, I)), + Aggr); Ok := False; end if; - El := Get_Chain (El); end loop; - Free (Matches); Set_Value_Staticness (Aggr, Value_Staticness); Set_Expr_Staticness (Aggr, Min (Globally, Value_Staticness)); return Ok; @@ -2886,13 +3108,15 @@ package body Sem_Expr is Set_Base_Type (Info.Index_Subtype, Get_Base_Type (Index_Type)); Index_Constraint := Get_Range_Constraint (Index_Type); + -- LRM93 7.3.2.2 + -- If the aggregate appears in one of the above contexts, then the + -- direction of the index subtype of the aggregate is that of the + -- corresponding constrained array subtype; [...] Index_Subtype_Constraint := Create_Iir (Iir_Kind_Range_Expression); Location_Copy (Index_Subtype_Constraint, Aggr); Set_Range_Constraint (Info.Index_Subtype, Index_Subtype_Constraint); Set_Type_Staticness (Info.Index_Subtype, Choice_Staticness); - Set_Direction (Index_Subtype_Constraint, - Get_Direction (Index_Constraint)); -- LRM93 7.3.2.2 -- For an aggregate that has named associations, the leftmost and @@ -2906,6 +3130,8 @@ package body Sem_Expr is Get_Range_Constraint (Index_Type)); Free_Iir (Index_Subtype_Constraint); else + Set_Direction (Index_Subtype_Constraint, + Get_Direction (Index_Constraint)); case Get_Direction (Index_Constraint) is when Iir_To => Set_Left_Limit (Index_Subtype_Constraint, Low); @@ -2925,6 +3151,8 @@ package body Sem_Expr is Expr := Get_Expression (Choice); case Get_Kind (Choice) is when Iir_Kind_Choice_By_Expression => + Set_Direction (Index_Subtype_Constraint, + Get_Direction (Index_Constraint)); Set_Left_Limit (Index_Subtype_Constraint, Expr); Set_Right_Limit (Index_Subtype_Constraint, Expr); when Iir_Kind_Choice_By_Range => @@ -3098,6 +3326,8 @@ package body Sem_Expr is Iirs.Min (Get_Type_Staticness (A_Subtype), Get_Type_Staticness (Infos (I).Index_Subtype))); end loop; + Set_Index_Constraint_Flag (A_Subtype, True); + Set_Constraint_State (A_Subtype, Fully_Constrained); Set_Type (Aggr, A_Subtype); else Set_Type (Aggr, Base_Type); @@ -3141,7 +3371,8 @@ package body Sem_Expr is Set_Type (Expr, A_Type); -- FIXME: should free old type case Get_Kind (A_Type) is when Iir_Kind_Array_Subtype_Definition => - return Sem_Array_Aggregate_Type (Expr, A_Type, True); + return Sem_Array_Aggregate_Type + (Expr, A_Type, Get_Index_Constraint_Flag (A_Type)); when Iir_Kind_Array_Type_Definition => return Sem_Array_Aggregate_Type (Expr, A_Type, False); when Iir_Kind_Record_Type_Definition @@ -3229,7 +3460,7 @@ package body Sem_Expr is -- type of the object created is an array type, then the -- subtype indication must either denote a constrained -- subtype or include an explicit index constraint. - if not Sem_Types.Sem_Is_Constrained (Arg) then + if not Is_Fully_Constrained_Type (Arg) then Error_Msg_Sem ("allocator of unconstrained " & Disp_Node (Arg) & " is not allowed", Expr); end if; @@ -3908,4 +4139,54 @@ package body Sem_Expr is end if; return Sem_Expression_Ov (Expr1, Res); end Sem_Expression_Universal; + + function Sem_Case_Expression (Expr : Iir) return Iir + is + Expr1 : Iir; + Expr_Type : Iir; + El : Iir; + Res : Iir; + List : Iir_List; + begin + Expr1 := Sem_Expression_Ov (Expr, Null_Iir); + if Expr1 = Null_Iir then + return Null_Iir; + end if; + Expr_Type := Get_Type (Expr1); + if not Is_Overload_List (Expr_Type) then + return Expr1; + end if; + + -- In case of overload, try to find one match. + -- FIXME: match only character types. + + -- LRM93 8.8 Case statement + -- This type must be determinable independently of the context in which + -- the expression occurs, but using the fact that the expression must be + -- of a discrete type or a one-dimensional character array type. + List := Get_Overload_List (Expr_Type); + Res := Null_Iir; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if Get_Kind (El) in Iir_Kinds_Discrete_Type_Definition + or else Is_Unidim_Array_Type (El) + then + if Res = Null_Iir then + Res := El; + else + Error_Overload (Expr1); + Disp_Overload_List (List, Expr1); + return Null_Iir; + end if; + end if; + end loop; + if Res = Null_Iir then + Error_Overload (Expr1); + Disp_Overload_List (List, Expr1); + return Null_Iir; + end if; + return Sem_Expression_Ov (Expr1, Res); + end Sem_Case_Expression; + end Sem_Expr; diff --git a/sem_expr.ads b/sem_expr.ads index 441e3e069..1c7713eb6 100644 --- a/sem_expr.ads +++ b/sem_expr.ads @@ -59,6 +59,10 @@ package Sem_Expr is -- if overloaded. function Sem_Expression_Universal (Expr : Iir) return Iir; + -- Same as Sem_Expression but specialized for a case expression. + -- (Handle specific overloading rules). + function Sem_Case_Expression (Expr : Iir) return Iir; + -- Check EXPR can be read. procedure Check_Read (Expr : Iir); diff --git a/sem_names.adb b/sem_names.adb index 234926be0..5d5fdd9e5 100644 --- a/sem_names.adb +++ b/sem_names.adb @@ -413,7 +413,9 @@ package body Sem_Names is then if Get_Kind (Get_Type (Obj)) /= Iir_Kind_Protected_Type_Declaration then - raise Internal_Error; + Error_Msg_Sem ("type of the prefix should be a protected type", + Prefix); + return; end if; Set_Method_Object (Call, Obj); end if; @@ -618,6 +620,7 @@ package body Sem_Names is -- Check this only if the type is a constrained type. Suffix_Rng := Eval_Range (Suffix); if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition + and then Get_Index_Constraint_Flag (Prefix_Type) and then Prefix_Rng /= Null_Iir and then Suffix_Rng /= Null_Iir and then Get_Direction (Suffix_Rng) /= Get_Direction (Prefix_Rng) @@ -677,6 +680,8 @@ package body Sem_Names is (Expr_Type, Min (Get_Type_Staticness (Prefix_Type), Get_Type_Staticness (Slice_Type))); Set_Type (Name, Expr_Type); + Set_Index_Constraint_Flag (Expr_Type, True); + Set_Constraint_State (Expr_Type, Fully_Constrained); if Is_Signal_Object (Prefix) then Sem_Types.Set_Type_Has_Signal (Expr_Type); end if; @@ -1396,8 +1401,8 @@ package body Sem_Names is return; end if; - Rec_El := Find_Name_In_Chain - (Get_Element_Declaration_Chain (Base_Type), Suffix); + Rec_El := Find_Name_In_List + (Get_Elements_Declaration_List (Base_Type), Suffix); if Rec_El = Null_Iir then return; end if; @@ -2397,9 +2402,7 @@ package body Sem_Names is | Iir_Kind_Type_Declaration | Iir_Kind_Base_Attribute => Prefix_Type := Get_Type (Prefix); - if Get_Kind (Prefix_Type) - in Iir_Kinds_Unconstrained_Array_Type_Definition - then + if not Is_Fully_Constrained_Type (Prefix_Type) then Error_Msg_Sem ("prefix type is not constrained", Attr); -- We continue using the unconstrained array type. -- At least, this type is valid; and even if the array was diff --git a/sem_stmts.adb b/sem_stmts.adb index c5ec80bb9..d18a8afa6 100644 --- a/sem_stmts.adb +++ b/sem_stmts.adb @@ -897,8 +897,7 @@ package body Sem_Stmts is when Iir_Kinds_Discrete_Type_Definition => Sem_Choices_Range (Chain, Choice_Type, False, Loc, Low, High); when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => + | Iir_Kind_Array_Type_Definition => if not Is_Unidim_Array_Type (Choice_Type) then Error_Msg_Sem ("expression must be of a one-dimensional array type", @@ -930,7 +929,7 @@ package body Sem_Stmts is begin Expr := Get_Expression (Stmt); -- FIXME: overload. - Expr := Sem_Expression (Expr, Null_Iir); + Expr := Sem_Case_Expression (Expr); if Expr = Null_Iir then return; end if; @@ -1689,7 +1688,7 @@ package body Sem_Stmts is end if; -- The choices. - Expr := Sem_Expression (Get_Expression (Stmt), Null_Iir); + Expr := Sem_Case_Expression (Get_Expression (Stmt)); if Expr = Null_Iir then return; end if; diff --git a/sem_types.adb b/sem_types.adb index fc8b932ed..4b54dd4d9 100644 --- a/sem_types.adb +++ b/sem_types.adb @@ -25,6 +25,7 @@ with Sem_Expr; use Sem_Expr; with Sem_Scopes; use Sem_Scopes; with Sem_Names; use Sem_Names; with Sem_Decls; +with Name_Table; with Std_Names; with Iirs_Utils; use Iirs_Utils; with Std_Package; use Std_Package; @@ -78,12 +79,14 @@ package body Sem_Types is Set_Type_Has_Signal (Get_Element_Subtype (Atype)); when Iir_Kind_Record_Type_Definition => declare + El_List : constant Iir_List := + Get_Elements_Declaration_List (Atype); El : Iir; begin - El := Get_Element_Declaration_Chain (Atype); - while El /= Null_Iir loop + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; Set_Type_Has_Signal (Get_Type (El)); - El := Get_Chain (El); end loop; end; when Iir_Kind_Error => @@ -452,7 +455,9 @@ package body Sem_Types is -- array subtype] [...] for the element subtype indication -- of an array type definition, if the type of the array -- element is itself an array type. - if not Sem_Is_Constrained (El_Type) then + if Vhdl_Std < Vhdl_08 + and then not Is_Fully_Constrained_Type (El_Type) + then Error_Msg_Sem ("array element of unconstrained " & Disp_Node (El_Type) & " is not allowed", Def); end if; @@ -655,6 +660,62 @@ package body Sem_Types is Close_Declarative_Region; end Sem_Protected_Type_Body; + + -- Return the constraint state from CONST (the initial state) and ATYPE, + -- as if ATYPE was a new element of a record. + function Update_Record_Constraint (Const : Iir_Constraint; Atype : Iir) + return Iir_Constraint is + begin + if Get_Kind (Atype) not in Iir_Kinds_Composite_Type_Definition then + return Const; + end if; + + case Const is + when Fully_Constrained + | Unconstrained => + if Get_Constraint_State (Atype) = Const then + return Const; + else + return Partially_Constrained; + end if; + when Partially_Constrained => + return Partially_Constrained; + end case; + end Update_Record_Constraint; + + function Get_Array_Constraint (Def : Iir) return Iir_Constraint + is + El_Type : constant Iir := Get_Element_Subtype (Def); + Index : constant Boolean := + Get_Kind (Def) = Iir_Kind_Array_Subtype_Definition + and then Get_Index_Constraint_Flag (Def); + begin + if Get_Kind (El_Type) in Iir_Kinds_Composite_Type_Definition then + case Get_Constraint_State (El_Type) is + when Fully_Constrained => + if Index then + return Fully_Constrained; + else + return Partially_Constrained; + end if; + when Partially_Constrained => + return Partially_Constrained; + when Unconstrained => + if not Index then + return Unconstrained; + else + return Partially_Constrained; + end if; + end case; + else + if Index then + return Fully_Constrained; + else + return Unconstrained; + end if; + end if; + end Get_Array_Constraint; + function Sem_Type_Definition (Def: Iir; Decl: Iir) return Iir is begin @@ -670,6 +731,7 @@ package body Sem_Types is declare El: Iir; Literal_List: Iir_List; + Only_Characters : Boolean := True; begin Literal_List := Get_Enumeration_Literal_List (Def); for I in Natural loop @@ -684,7 +746,13 @@ package body Sem_Types is Sem_Scopes.Add_Name (El); Name_Visible (El); Xref_Decl (El); + if Only_Characters + and then not Name_Table.Is_Character (Get_Identifier (El)) + then + Only_Characters := False; + end if; end loop; + Set_Only_Characters_Flag (Def, Only_Characters); end; Set_Resolved_Flag (Def, False); return Def; @@ -716,6 +784,25 @@ package body Sem_Types is end; when Iir_Kind_Array_Subtype_Definition => + -- LRM08 5.3.2.1 Array types + -- A constrained array definition similarly defines both an array + -- type and a subtype of this type. + -- - The array type is an implicitely declared anonymous type, + -- this type is defined by an (implicit) unbounded array + -- definition in which the element subtype indication either + -- denotes the base type of the subtype denoted by the element + -- subtype indication of the constrained array definition, if + -- that subtype is a composite type, or otherwise is the + -- element subtype indication of the constrained array + -- definition, and in which the type mark of each index subtype + -- definition denotes the subtype defined by the corresponding + -- discrete range. + -- - The array subtype is the subtype obtained by imposition of + -- the index constraint on the array type and if the element + -- subtype indication of the constrained array definition + -- denotes a fully or partially constrained composite subtype, + -- imposition of the constraint of that subtype as an array + -- element constraint on the array type. declare Index_Type : Iir; Index_List : Iir_List; @@ -773,7 +860,10 @@ package body Sem_Types is Set_Type_Staticness (Base_Type, None); Set_Type_Declarator (Base_Type, Decl); Set_Resolved_Flag (Base_Type, Get_Resolved_Flag (Def)); - + Set_Index_Constraint_Flag (Def, True); + Set_Constraint_State (Def, Get_Array_Constraint (Def)); + Set_Constraint_State + (Base_Type, Get_Array_Constraint (Base_Type)); Set_Base_Type (Def, Base_Type); Set_Type_Mark (Def, Base_Type); return Def; @@ -811,38 +901,39 @@ package body Sem_Types is -- According to LRM93 §7.4.1, an unconstrained array type -- is not static. Set_Type_Staticness (Def, None); - Sem_Array_Element (Def); + Set_Constraint_State (Def, Get_Array_Constraint (Def)); return Def; end; when Iir_Kind_Record_Type_Definition => declare - -- Non semantized type of previous element. - Last_El_Type : Iir; -- Semantized type of previous element Last_Type : Iir; + El_List : Iir_List; El: Iir; El_Type : Iir; Resolved_Flag : Boolean; Staticness : Iir_Staticness; + Constraint : Iir_Constraint; begin -- LRM 10.1 -- 5. A record type declaration, Open_Declarative_Region; Resolved_Flag := True; - Last_El_Type := Null_Iir; Last_Type := Null_Iir; Staticness := Locally; + Constraint := Fully_Constrained; Set_Signal_Type_Flag (Def, True); - El := Get_Element_Declaration_Chain (Def); - while El /= Null_Iir loop + El_List := Get_Elements_Declaration_List (Def); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; El_Type := Get_Type (El); - if El_Type /= Last_El_Type then + if El_Type /= Null_Iir then -- Be careful for a declaration list (r,g,b: integer). - Last_El_Type := El_Type; El_Type := Sem_Subtype_Indication (El_Type); Last_Type := El_Type; else @@ -860,7 +951,9 @@ package body Sem_Types is -- subtype] exits for the subtype indication of an -- element declaration, if the type of the record -- element is an array type. - if not Sem_Is_Constrained (El_Type) then + if Vhdl_Std < Vhdl_08 + and then not Is_Fully_Constrained_Type (El_Type) + then Error_Msg_Sem ("element declaration of unconstrained " & Disp_Node (El_Type) & " is not allowed", El); @@ -869,18 +962,20 @@ package body Sem_Types is Resolved_Flag and Get_Resolved_Flag (El_Type); Staticness := Min (Staticness, Get_Type_Staticness (El_Type)); + Constraint := Update_Record_Constraint + (Constraint, El_Type); else Staticness := None; end if; Sem_Scopes.Add_Name (El); Name_Visible (El); Xref_Decl (El); - El := Get_Chain (El); end loop; Close_Declarative_Region; Set_Base_Type (Def, Def); Set_Resolved_Flag (Def, Resolved_Flag); Set_Type_Staticness (Def, Staticness); + Set_Constraint_State (Def, Constraint); return Def; end; @@ -1055,28 +1150,14 @@ package body Sem_Types is end Is_A_Resolution_Function; -- Note: this sets resolved_flag. - procedure Sem_Resolution_Function (Decl: Iir) + procedure Sem_Resolution_Function (Name : Iir; Atype : Iir) is - Func: Iir; - Name : Iir; + Func : Iir; Res: Iir; El : Iir; List : Iir_List; Has_Error : Boolean; begin - Name := Get_Resolution_Function (Decl); - if Name = Null_Iir then - -- This is not a resolved type. - return; - end if; - - -- FIXME: add this check (maybe based on resolved_flag ?) - --if Get_Kind (Name) in Iir_Kinds_Function_Declaration then - -- -- The resolution function was already semantized. - -- -- This can happen if comes from an unconstrained array subtype. - -- return; - --end if; - Sem_Name (Name, False); Func := Get_Named_Entity (Name); if Func = Error_Mark then @@ -1091,14 +1172,14 @@ package body Sem_Types is for I in Natural loop El := Get_Nth_Element (List, I); exit when El = Null_Iir; - if Is_A_Resolution_Function (El, Decl) then + if Is_A_Resolution_Function (El, Atype) then if Res /= Null_Iir then if not Has_Error then Has_Error := True; Error_Msg_Sem ("can't resolve overload for resolution function", - Decl); - Error_Msg_Sem ("candidate functions are:", Decl); + Atype); + Error_Msg_Sem ("candidate functions are:", Atype); Error_Msg_Sem (" " & Disp_Subprg (Func), Func); end if; Error_Msg_Sem (" " & Disp_Subprg (El), El); @@ -1111,369 +1192,623 @@ package body Sem_Types is return; end if; else - if Is_A_Resolution_Function (Func, Decl) then + if Is_A_Resolution_Function (Func, Atype) then Res := Func; end if; end if; if Res = Null_Iir then Error_Msg_Sem ("no matching resolution function for " - & Disp_Node (Name), Decl); + & Disp_Node (Name), Atype); else Set_Named_Entity (Name, Res); Set_Use_Flag (Res, True); - Set_Resolved_Flag (Decl, True); + Set_Resolved_Flag (Atype, True); + Set_Resolution_Function (Atype, Name); Xref_Name (Name); end if; end Sem_Resolution_Function; - -- Semantize array_subtype_definition DEF using TYPE_MARK as the base type - -- of DEF. - -- DEF must have an index list and may have a resolution function. - -- Return DEF. - function Sem_Array_Subtype_Indication (Type_Mark : Iir; Def : Iir) - return Iir + function Sem_Subtype_Constraint + (Def : Iir; Type_Mark : Iir; Resolution : Iir) + return Iir; + + -- DEF is an incomplete subtype_indication or array_constraint, + -- BASE_TYPE is the base type of the subtype_indication. + function Sem_Array_Constraint (Def : Iir; Type_Mark : Iir; Resolution : Iir) + return Iir is + Res : Iir; Type_Index, Subtype_Index: Iir; Base_Type : Iir; + Mark_El_Type : Iir; El_Type : Iir; Staticness : Iir_Staticness; Error_Seen : Boolean; Type_Index_List : Iir_List; Subtype_Index_List : Iir_List; + Resolv_Func : Iir := Null_Iir; + Resolv_El : Iir := Null_Iir; begin - case Get_Kind (Type_Mark) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => - null; - when others => - Error_Msg_Sem - (Disp_Node (Type_Mark) & " cannot be constrained", Def); - -- Continue as if BASE_TYPE is really a base type, it is safe. - end case; + if Resolution /= Null_Iir then + case Get_Kind (Resolution) is + when Iir_Kinds_Name => + Resolv_Func := Resolution; + when Iir_Kind_Array_Subtype_Definition => + Resolv_El := Get_Element_Subtype (Resolution); + Free_Iir (Resolution); + when Iir_Kind_Record_Subtype_Definition => + Error_Msg_Sem + ("record element resolution not allowed for array subtype", + Resolution); + when others => + Error_Kind ("sem_array_constraint(resolution)", Resolution); + end case; + end if; - Base_Type := Get_Base_Type (Type_Mark); - Set_Base_Type (Def, Base_Type); - El_Type := Get_Element_Subtype (Base_Type); - Staticness := Get_Type_Staticness (El_Type); - Error_Seen := False; - Type_Index_List := Get_Index_Subtype_List (Base_Type); - Subtype_Index_List := Get_Index_Subtype_List (Def); - for I in Natural loop - Type_Index := Get_Nth_Element (Type_Index_List, I); - Subtype_Index := Get_Nth_Element (Subtype_Index_List, I); - exit when Type_Index = Null_Iir and Subtype_Index = Null_Iir; - - if Type_Index = Null_Iir then - Error_Msg_Sem ("subtype has more indexes than " - & Disp_Node (Type_Mark) - & " defined at " & Disp_Location (Type_Mark), - Subtype_Index); - -- Forget extra indexes. - Set_Nbr_Elements (Subtype_Index_List, I); - exit; - end if; - if Subtype_Index = Null_Iir then - if not Error_Seen then - Error_Msg_Sem ("subtype has less indexes than " - & Disp_Node (Type_Mark) - & " defined at " & Disp_Location (Type_Mark), - Def); - Error_Seen := True; - end if; - -- Use type_index as a fake subtype - -- FIXME: it is too fake. - Append_Element (Subtype_Index_List, Type_Index); - Staticness := None; - else - Subtype_Index := Sem_Discrete_Range_Expression - (Subtype_Index, Type_Index, True); - if Subtype_Index /= Null_Iir then - Subtype_Index := Range_To_Subtype_Definition (Subtype_Index); - Staticness := Min (Staticness, - Get_Type_Staticness (Subtype_Index)); - end if; - if Subtype_Index = Null_Iir then - -- Create a fake subtype from type_index. - -- FIXME: It is too fake. - Subtype_Index := Type_Index; - Staticness := None; - end if; - Replace_Nth_Element (Subtype_Index_List, I, Subtype_Index); + Mark_El_Type := Get_Element_Subtype (Type_Mark); + + if Def = Null_Iir then + Res := Copy_Subtype_Indication (Type_Mark); + else + case Get_Kind (Def) is + when Iir_Kind_Subtype_Definition => + -- This is the case of "subtype new_array is [func] old_array". + -- def must be a constrained array. + if Get_Range_Constraint (Def) /= Null_Iir then + Error_Msg_Sem + ("cannot use a range constraint for array types", Def); + return Type_Mark; + end if; + + -- LRM08 6.3 Subtype declarations + -- + -- If the subtype indication does not include a constraint, the + -- subtype is the same as that denoted by the type mark. + if Resolution = Null_Iir then + Free_Name (Def); + return Type_Mark; + end if; + + Res := Copy_Subtype_Indication (Type_Mark); + Location_Copy (Res, Def); + Free_Name (Def); + + when Iir_Kind_Array_Subtype_Definition => + -- Case of a constraint for an array. + -- Check each index constraint against array type. + + Base_Type := Get_Base_Type (Type_Mark); + Set_Base_Type (Def, Base_Type); + + Staticness := Get_Type_Staticness (Mark_El_Type); + Error_Seen := False; + Type_Index_List := Get_Index_Subtype_List (Base_Type); + Subtype_Index_List := Get_Index_Subtype_List (Def); + + -- LRM08 5.3.2.2 + -- If an array constraint of the first form (including an index + -- constraint) applies to a type or subtype, then the type or + -- subtype shall be an unconstrained or partially constrained + -- array type with no index constraint applying to the index + -- subtypes, or an access type whose designated type is such + -- a type. + if Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition + and then Get_Index_Constraint_Flag (Type_Mark) + then + Error_Msg_Sem ("constrained array cannot be re-constrained", + Def); + end if; + for I in Natural loop + Type_Index := Get_Nth_Element (Type_Index_List, I); + Subtype_Index := Get_Nth_Element (Subtype_Index_List, I); + exit when Type_Index = Null_Iir and Subtype_Index = Null_Iir; + + if Type_Index = Null_Iir then + Error_Msg_Sem + ("subtype has more indexes than " + & Disp_Node (Type_Mark) + & " defined at " & Disp_Location (Type_Mark), + Subtype_Index); + -- Forget extra indexes. + Set_Nbr_Elements (Subtype_Index_List, I); + exit; + end if; + if Subtype_Index = Null_Iir then + if not Error_Seen then + Error_Msg_Sem + ("subtype has less indexes than " + & Disp_Node (Type_Mark) + & " defined at " + & Disp_Location (Type_Mark), Def); + Error_Seen := True; + end if; + -- Use type_index as a fake subtype + -- FIXME: it is too fake. + Append_Element (Subtype_Index_List, Type_Index); + Staticness := None; + else + Subtype_Index := Sem_Discrete_Range_Expression + (Subtype_Index, Type_Index, True); + if Subtype_Index /= Null_Iir then + Subtype_Index := + Range_To_Subtype_Definition (Subtype_Index); + Staticness := Min + (Staticness, Get_Type_Staticness (Subtype_Index)); + end if; + if Subtype_Index = Null_Iir then + -- Create a fake subtype from type_index. + -- FIXME: It is too fake. + Subtype_Index := Type_Index; + Staticness := None; + end if; + Replace_Nth_Element + (Subtype_Index_List, I, Subtype_Index); + end if; + end loop; + Set_Index_Constraint_Flag (Def, True); + Set_Type_Staticness (Def, Staticness); + Set_Type_Mark (Def, Type_Mark); + Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (Type_Mark)); + Res := Def; + + when others => + -- LRM93 3.2.1.1 / LRM08 5.3.2.2 + -- Index Constraints and Discrete Ranges + -- + -- If an index constraint appears after a type mark [...] + -- The type mark must denote either an unconstrained array + -- type, or an access type whose designated type is such + -- an array type. + Error_Msg_Sem + ("only unconstrained array type may be contrained " + &"by index", Def); + Error_Msg_Sem + (" (type mark is " & Disp_Node (Type_Mark) & ")", + Type_Mark); + return Type_Mark; + end case; + end if; + + -- Element subtype. + if Resolv_El /= Null_Iir then + El_Type := Sem_Subtype_Constraint (Null_Iir, Mark_El_Type, Resolv_El); + if El_Type = Null_Iir then + El_Type := Mark_El_Type; end if; - end loop; - Set_Type_Staticness (Def, Staticness); - Set_Element_Subtype (Def, El_Type); - Sem_Resolution_Function (Def); - if Get_Resolved_Flag (Def) or else Get_Resolved_Flag (El_Type) then - Set_Resolved_Flag (Def, True); else - Set_Resolved_Flag (Def, False); + El_Type := Mark_El_Type; end if; - Set_Type_Mark (Def, Type_Mark); - Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (Type_Mark)); - return Def; - end Sem_Array_Subtype_Indication; + Set_Element_Subtype (Res, El_Type); - -- Semantize a subtype indication. - -- DEF can be either a name or an iir_subtype_definition. - -- Return a new (an anonymous) subtype definition (with the correct kind), - -- or an already defined type definition (if DEF is a name). - function Sem_Subtype_Indication (Def: Iir; Incomplete : Boolean := False) - return Iir + Set_Constraint_State (Res, Get_Array_Constraint (Res)); + + if Resolv_Func /= Null_Iir then + Sem_Resolution_Function (Resolv_Func, Res); + elsif Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition then + Set_Resolution_Function (Res, Get_Resolution_Function (Type_Mark)); + end if; + if Get_Resolved_Flag (Res) + or else Get_Resolved_Flag (Get_Element_Subtype (Type_Mark)) + then + Set_Resolved_Flag (Res, True); + else + Set_Resolved_Flag (Res, False); + end if; + + return Res; + end Sem_Array_Constraint; + + function Reparse_As_Record_Element_Constraint (Name : Iir) return Iir is - Type_Mark: Iir; - Res: Iir; - Decl_Kind : Decl_Kind_Type; + Prefix : Iir; + Parent : Iir; + El : Iir; begin - if Incomplete then - Decl_Kind := Decl_Incomplete_Type; + if Get_Kind (Name) /= Iir_Kind_Parenthesis_Name then + Error_Msg_Sem ("record element constraint expected", Name); + return Null_Iir; else - Decl_Kind := Decl_Type; + Prefix := Get_Prefix (Name); + Parent := Name; + while Get_Kind (Prefix) = Iir_Kind_Parenthesis_Name loop + Parent := Prefix; + Prefix := Get_Prefix (Prefix); + end loop; + if Get_Kind (Prefix) /= Iir_Kind_Simple_Name then + Error_Msg_Sem ("record element name must be a simple name", + Prefix); + return Null_Iir; + else + El := Create_Iir (Iir_Kind_Record_Element_Constraint); + Location_Copy (El, Prefix); + Set_Identifier (El, Get_Identifier (Prefix)); + Set_Type (El, Name); + Set_Prefix (Parent, Null_Iir); + Free_Name (Prefix); + return El; + end if; end if; + end Reparse_As_Record_Element_Constraint; - -- Simple case that correspond to no indication except a subtype - -- identifier - if Get_Kind (Def) in Iir_Kinds_Name then - Type_Mark := Find_Declaration (Def, Decl_Kind); - if Type_Mark = Null_Iir then - return Create_Error_Type (Def); + function Reparse_As_Record_Constraint (Def : Iir) return Iir + is + Res : Iir; + Chain : Iir; + El_List : Iir_List; + El : Iir; + begin + if Get_Prefix (Def) /= Null_Iir then + raise Internal_Error; + end if; + Res := Create_Iir (Iir_Kind_Record_Subtype_Definition); + Location_Copy (Res, Def); + El_List := Create_Iir_List; + Set_Elements_Declaration_List (Res, El_List); + Chain := Get_Association_Chain (Def); + while Chain /= Null_Iir loop + if Get_Kind (Chain) /= Iir_Kind_Association_Element_By_Expression + or else Get_Formal (Chain) /= Null_Iir + then + Error_Msg_Sem ("badly formed record constraint", Chain); else - return Type_Mark; + El := Reparse_As_Record_Element_Constraint (Get_Actual (Chain)); + if El /= Null_Iir then + Append_Element (El_List, El); + end if; end if; + Chain := Get_Chain (Chain); + end loop; + return Res; + end Reparse_As_Record_Constraint; + + function Reparse_As_Array_Constraint (Def : Iir; Def_Type : Iir) return Iir + is + Parent : Iir; + Name : Iir; + Prefix : Iir; + Res : Iir; + Chain : Iir; + El_List : Iir_List; + Def_El_Type : Iir; + begin + Name := Def; + Prefix := Get_Prefix (Name); + Parent := Null_Iir; + while Prefix /= Null_Iir + and then Get_Kind (Prefix) = Iir_Kind_Parenthesis_Name + loop + Parent := Name; + Name := Prefix; + Prefix := Get_Prefix (Name); + end loop; + -- Detach prefix. + if Parent /= Null_Iir then + Set_Prefix (Parent, Null_Iir); + end if; + Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Location_Copy (Res, Name); + Chain := Get_Association_Chain (Name); + if Get_Kind (Chain) = Iir_Kind_Association_Element_Open then + if Get_Chain (Chain) /= Null_Iir then + Error_Msg_Sem ("'open' must be alone", Chain); + end if; + else + El_List := Create_Iir_List; + Set_Index_Subtype_List (Res, El_List); + while Chain /= Null_Iir loop + if Get_Kind (Chain) /= Iir_Kind_Association_Element_By_Expression + or else Get_Formal (Chain) /= Null_Iir + then + Error_Msg_Sem ("bad form of array constraint", Chain); + else + Append_Element (El_List, Get_Actual (Chain)); + end if; + Chain := Get_Chain (Chain); + end loop; end if; - -- Semantize the type mark. - Type_Mark := Find_Declaration (Get_Type_Mark (Def), Decl_Kind); - if Type_Mark = Null_Iir then - -- FIXME: handle inversion such as "subtype BASETYPE RESOLV", which - -- should emit "resolution function must precede type name". - return Create_Error_Type (Get_Type_Mark (Def)); + Def_El_Type := Get_Element_Subtype (Def_Type); + if Parent /= Null_Iir then + case Get_Kind (Def_El_Type) is + when Iir_Kinds_Array_Type_Definition => + Set_Element_Subtype + (Res, Reparse_As_Array_Constraint (Def, Def_El_Type)); + when others => + Error_Kind ("reparse_as_array_constraint", Def_El_Type); + end case; + end if; + return Res; + end Reparse_As_Array_Constraint; + + function Sem_Record_Constraint + (Def : Iir; Type_Mark : Iir; Resolution : Iir) + return Iir + is + Res : Iir; + El_List, Tm_El_List : Iir_List; + El : Iir; + Tm_El : Iir; + Tm_El_Type : Iir; + El_Type : Iir; + Res_List : Iir_List; + + Index_List : Iir_List; + Index_El : Iir; + begin + Res := Create_Iir (Iir_Kind_Record_Subtype_Definition); + Location_Copy (Res, Def); + Set_Base_Type (Res, Type_Mark); + Set_Type_Staticness (Res, Get_Type_Staticness (Type_Mark)); + Set_Type_Mark (Res, Type_Mark); + if Get_Kind (Type_Mark) = Iir_Kind_Record_Subtype_Definition then + Set_Resolution_Function (Res, Get_Resolution_Function (Type_Mark)); end if; - Set_Type_Mark (Def, Type_Mark); - -- Check constraint. case Get_Kind (Def) is - when Iir_Kind_Array_Subtype_Definition => - case Get_Kind (Type_Mark) is - when Iir_Kind_Unconstrained_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition - | Iir_Kind_Access_Type_Definition => - null; - when others => - -- LRM 3.2.1.1 Index Constraints and Discrete Ranges - -- If an index constraint appears after a type mark [...] - -- The type mark must denote either an unconstrained array - -- type, or an access type whose designated type is such - -- an array type. - Error_Msg_Sem - ("only unconstrained array type may be contrained " - &"by index", Def); - Error_Msg_Sem - (" (type mark is " & Disp_Node (Type_Mark) & ")", - Type_Mark); - return Type_Mark; - end case; when Iir_Kind_Subtype_Definition => - case Get_Kind (Type_Mark) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition => - null; - when Iir_Kind_Enumeration_Type_Definition => - null; - when others => - -- FIXME: find the correct sentence from LRM - -- GHDL: subtype_definition may also be used just to add - -- a resolution function. - if Get_Range_Constraint (Def) /= Null_Iir then - Error_Msg_Sem - ("only scalar types may be constrained by range", Def); - Error_Msg_Sem - (" (type mark is " & Disp_Node (Type_Mark) & ")", - Type_Mark); - return Type_Mark; - end if; - end case; + Free_Name (Def); + Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); + Set_Constraint_State (Res, Get_Constraint_State (Type_Mark)); + El_List := Null_Iir_List; + + when Iir_Kind_Array_Subtype_Definition => + -- Record constraints are parsed as array constraints. + if Get_Kind (Def) /= Iir_Kind_Array_Subtype_Definition then + raise Internal_Error; + end if; + Index_List := Get_Index_Subtype_List (Def); + El_List := Create_Iir_List; + Set_Elements_Declaration_List (Res, El_List); + for I in Natural loop + Index_El := Get_Nth_Element (Index_List, I); + exit when Index_El = Null_Iir; + El := Reparse_As_Record_Element_Constraint (Index_El); + if El /= Null_Iir then + Append_Element (El_List, El); + end if; + end loop; + + when Iir_Kind_Record_Subtype_Definition => + El_List := Get_Elements_Declaration_List (Def); + Set_Elements_Declaration_List (Res, El_List); + when others => - Error_Kind ("sem_subtype_indication", Def); + Error_Kind ("sem_record_constraint", Def); end case; - case Get_Kind (Type_Mark) is - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => --- -- If the base type is an unconstrained array subtype, then get --- -- the *real* base type, and copy the resolution function (since --- -- a base type has no resolution function). --- if Get_Kind (Type_Mark) = --- Iir_Kind_Unconstrained_Array_Subtype_Definition --- and then Get_Kind (Def) = Iir_Kind_Subtype_Definition --- then --- if Get_Resolution_Function (Def) = Null_Iir then --- if Get_Range_Constraint (Def) = Null_Iir then --- -- In this case, DEF must simply be a name. There is --- -- a parser internal error. --- raise Internal_Error; --- end if; --- Set_Resolution_Function --- (Def, Get_Resolution_Function (Type_Mark)); --- end if; --- end if; - - if Get_Kind (Def) = Iir_Kind_Subtype_Definition then - -- This is the case of "subtype new_array is [func] old_array". - -- def must be a constrained array. - if Get_Range_Constraint (Def) /= Null_Iir then - Error_Msg_Sem - ("cannot use a range constraint for an array", Def); - return Type_Mark; - end if; - if Get_Resolution_Function (Def) = Null_Iir then - -- In this case, DEF must simply be a name. There is - -- a parser internal error. - raise Internal_Error; - end if; - case Get_Kind (Type_Mark) is - when Iir_Kind_Array_Type_Definition => - Res := Create_Iir - (Iir_Kind_Unconstrained_Array_Subtype_Definition); - when Iir_Kind_Array_Subtype_Definition => - Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); - Set_Element_Subtype - (Res, Get_Element_Subtype (Type_Mark)); - Set_Index_Subtype_List - (Res, Get_Index_Subtype_List (Type_Mark)); - when others => - Error_Kind ("sem_subtype_indication(array)", Type_Mark); - end case; - Location_Copy (Res, Def); - Set_Base_Type (Res, Get_Base_Type (Type_Mark)); - Set_Resolution_Function (Res, Get_Resolution_Function (Def)); - Set_Type_Staticness (Res, Get_Type_Staticness (Type_Mark)); - Sem_Resolution_Function (Res); - Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); - if Get_Resolved_Flag (Res) - or else Get_Resolved_Flag (Get_Element_Subtype (Type_Mark)) - then - Set_Resolved_Flag (Res, True); - else - Set_Resolved_Flag (Res, False); - end if; - Set_Type_Mark (Res, Type_Mark); - Free_Name (Def); - return Res; - elsif Get_Kind (Def) = Iir_Kind_Array_Subtype_Definition then - -- Case of a constraint for an array. - -- Check each index constraint against array type. - return Sem_Array_Subtype_Indication (Type_Mark, Def); - else - Error_Kind ("sem_subtype_indication(1)", Def); - return Type_Mark; + Res_List := Null_Iir_List; + if Resolution /= Null_Iir then + case Get_Kind (Resolution) is + when Iir_Kinds_Name => + null; + when Iir_Kind_Record_Subtype_Definition => + Res_List := Get_Elements_Declaration_List (Resolution); + when Iir_Kind_Array_Subtype_Definition => + Error_Msg_Sem + ("resolution indication must be an array element resolution", + Resolution); + when others => + Error_Kind ("sem_record_constraint(resolution)", Resolution); + end case; + end if; + + Tm_El_List := Get_Elements_Declaration_List (Type_Mark); + if El_List /= Null_Iir_List or Res_List /= Null_Iir_List then + declare + Nbr_Els : constant Natural := Get_Nbr_Elements (Tm_El_List); + Els : Iir_Array (0 .. Nbr_Els - 1) := (others => Null_Iir); + Res_Els : Iir_Array (0 .. Nbr_Els - 1) := (others => Null_Iir); + Pos : Natural; + Constraint : Iir_Constraint; + begin + -- Fill ELS. + if El_List /= Null_Iir_List then + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + Tm_El := Find_Name_In_List (Tm_El_List, Get_Identifier (El)); + if Tm_El = Null_Iir then + Error_Msg_Sem (Disp_Node (Type_Mark) + & "has no " & Disp_Node (El), El); + else + Set_Element_Declaration (El, Tm_El); + Pos := Natural (Get_Element_Position (Tm_El)); + if Els (Pos) /= Null_Iir then + Error_Msg_Sem + (Disp_Node (El) & " was already constrained", El); + Error_Msg_Sem + (" (location of previous constrained)", Els (Pos)); + else + Els (Pos) := El; + Set_Parent (El, Res); + end if; + El_Type := Get_Type (El); + Tm_El_Type := Get_Type (Tm_El); + if Get_Kind (El_Type) = Iir_Kind_Parenthesis_Name then + case Get_Kind (Tm_El_Type) is + when Iir_Kinds_Array_Type_Definition => + El_Type := Reparse_As_Array_Constraint + (El_Type, Tm_El_Type); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + El_Type := Reparse_As_Record_Constraint + (El_Type); + when others => + Error_Msg_Sem + ("only composite types may be constrained", + El_Type); + end case; + end if; + Set_Type (El, El_Type); + end if; + end loop; + Destroy_Iir_List (El_List); end if; - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition => - if Get_Range_Constraint (Def) = Null_Iir - and then Get_Resolution_Function (Def) = Null_Iir - then - -- This defines an alias, and must have been handled just - -- before the case statment. - raise Internal_Error; + -- Fill Res_Els. + if Res_List /= Null_Iir_List then + for I in Natural loop + El := Get_Nth_Element (Res_List, I); + exit when El = Null_Iir; + Tm_El := Find_Name_In_List (Tm_El_List, Get_Identifier (El)); + if Tm_El = Null_Iir then + Error_Msg_Sem (Disp_Node (Type_Mark) + & "has no " & Disp_Node (El), El); + else + Pos := Natural (Get_Element_Position (Tm_El)); + if Res_Els (Pos) /= Null_Iir then + Error_Msg_Sem + (Disp_Node (El) & " was already resolved", El); + Error_Msg_Sem + (" (location of previous constrained)", Els (Pos)); + else + Res_Els (Pos) := Get_Element_Declaration (El); + end if; + end if; + --Free_Iir (El); + end loop; + Destroy_Iir_List (Res_List); end if; - declare - A_Range : Iir; - begin - -- There are limits. Create a new subtype. - Res := Create_Iir (Get_Kind (Type_Mark)); - Location_Copy (Res, Def); - Set_Base_Type (Res, Get_Base_Type (Type_Mark)); - Set_Type_Mark (Res, Type_Mark); - Set_Resolution_Function (Res, Get_Resolution_Function (Def)); - A_Range := Get_Range_Constraint (Def); - if A_Range = Null_Iir then - A_Range := Get_Range_Constraint (Type_Mark); + + -- Build elements list. + El_List := Create_Iir_List; + Set_Elements_Declaration_List (Res, El_List); + Constraint := Fully_Constrained; + for I in Els'Range loop + Tm_El := Get_Nth_Element (Tm_El_List, I); + if Els (I) = Null_Iir and Res_Els (I) = Null_Iir then + El := Tm_El; else - A_Range := Sem_Discrete_Range_Expression - (A_Range, Type_Mark, True); - if A_Range = Null_Iir then - -- Avoid error propagation. - A_Range := Get_Range_Constraint (Type_Mark); + if Els (I) = Null_Iir then + El := Create_Iir (Iir_Kind_Record_Element_Constraint); + Location_Copy (El, Tm_El); + Set_Element_Declaration (El, Tm_El); + Set_Element_Position (El, Get_Element_Position (Tm_El)); + El_Type := Null_Iir; + else + El := Els (I); + El_Type := Get_Type (El); end if; + El_Type := Sem_Subtype_Constraint (El_Type, + Get_Type (Tm_El), + Res_Els (I)); + Set_Type (El, El_Type); end if; - Set_Range_Constraint (Res, A_Range); - Set_Type_Staticness (Res, Get_Expr_Staticness (A_Range)); - Free_Name (Def); - Sem_Resolution_Function (Res); - Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); - return Res; - end; + Append_Element (El_List, El); + Constraint := Update_Record_Constraint + (Constraint, Get_Type (El)); + end loop; + Set_Constraint_State (Res, Constraint); + end; + else + Set_Elements_Declaration_List (Res, Tm_El_List); + Set_Constraint_State (Res, Get_Constraint_State (Type_Mark)); + end if; - when Iir_Kind_Enumeration_Type_Definition => - if Get_Range_Constraint (Def) = Null_Iir and then - Get_Resolution_Function (Def) = Null_Iir - then - raise Internal_Error; - end if; + Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); - declare - Constraint : Iir_Range_Expression; - begin - -- There are limits. Create a new subtype. - Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); - Location_Copy (Res, Def); - Set_Base_Type (Res, Type_Mark); - Set_Type_Mark (Res, Type_Mark); - Set_Resolution_Function (Res, Get_Resolution_Function (Def)); - Constraint := Get_Range_Constraint (Def); - if Constraint = Null_Iir then - Constraint := Get_Range_Constraint (Type_Mark); - else - Constraint := Sem_Discrete_Range_Expression - (Constraint, Type_Mark, True); - -- FIXME: check bounds, check static - end if; - Set_Range_Constraint (Res, Constraint); - Set_Type_Staticness (Res, Get_Expr_Staticness (Constraint)); - end; - Free_Name (Def); - Sem_Resolution_Function (Res); - Set_Signal_Type_Flag (Res, True); - return Res; + if Resolution /= Null_Iir + and then Get_Kind (Resolution) in Iir_Kinds_Name + then + Sem_Resolution_Function (Resolution, Res); + end if; - when Iir_Kind_Record_Type_Definition => - declare - Func: Iir; - begin - if Get_Kind (Def) /= Iir_Kind_Subtype_Definition then - Error_Kind ("sem_subtype_indication1", Def); - return Null_Iir; - end if; - Func := Get_Resolution_Function (Def); - if Func = Null_Iir then - -- This is an alias. - raise Internal_Error; - end if; - Res := Create_Iir (Iir_Kind_Record_Subtype_Definition); - Location_Copy (Res, Def); - Set_Base_Type (Res, Type_Mark); - Set_Type_Staticness (Res, Get_Type_Staticness (Type_Mark)); - Set_Type_Mark (Res, Type_Mark); - Set_Resolution_Function (Res, Func); - Sem_Resolution_Function (Res); - Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); - Free_Name (Def); - return Res; - end; + return Res; + end Sem_Record_Constraint; - when Iir_Kind_Access_Type_Definition => + function Sem_Range_Constraint (Def : Iir; Type_Mark : Iir; Resolution : Iir) + return Iir + is + Res : Iir; + A_Range : Iir; + begin + if Def = Null_Iir then + Res := Copy_Subtype_Indication (Type_Mark); + else + if Get_Kind (Def) /= Iir_Kind_Subtype_Definition then + -- FIXME: find the correct sentence from LRM + -- GHDL: subtype_definition may also be used just to add + -- a resolution function. + Error_Msg_Sem + ("only scalar types may be constrained by range", Def); + Error_Msg_Sem + (" (type mark is " & Disp_Node (Type_Mark) & ")", + Type_Mark); + return Type_Mark; + end if; + + if Get_Range_Constraint (Def) = Null_Iir + and then Resolution = Null_Iir + then + -- This defines an alias, and must have been handled just + -- before the case statment. + raise Internal_Error; + end if; + + -- There are limits. Create a new subtype. + if Get_Kind (Type_Mark) = Iir_Kind_Enumeration_Type_Definition then + Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + else + Res := Create_Iir (Get_Kind (Type_Mark)); + end if; + Location_Copy (Res, Def); + Set_Base_Type (Res, Get_Base_Type (Type_Mark)); + Set_Type_Mark (Res, Type_Mark); + Set_Resolution_Function (Res, Get_Resolution_Function (Def)); + A_Range := Get_Range_Constraint (Def); + if A_Range = Null_Iir then + A_Range := Get_Range_Constraint (Type_Mark); + else + A_Range := Sem_Discrete_Range_Expression + (A_Range, Type_Mark, True); + if A_Range = Null_Iir then + -- Avoid error propagation. + A_Range := Get_Range_Constraint (Type_Mark); + end if; + end if; + Set_Range_Constraint (Res, A_Range); + Set_Type_Staticness (Res, Get_Expr_Staticness (A_Range)); + Free_Name (Def); + Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); + end if; + + if Resolution /= Null_Iir then + -- LRM08 6.3 Subtype declarations. + if Get_Kind (Resolution) not in Iir_Kinds_Name then + Error_Msg_Sem ("resolution indication must be a function name", + Resolution); + else + Sem_Resolution_Function (Resolution, Res); + end if; + end if; + return Res; + end Sem_Range_Constraint; + + function Sem_Subtype_Constraint + (Def : Iir; Type_Mark : Iir; Resolution : Iir) + return Iir + is + begin + case Get_Kind (Type_Mark) is + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + return Sem_Array_Constraint (Def, Type_Mark, Resolution); + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition=> + return Sem_Range_Constraint (Def, Type_Mark, Resolution); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + return Sem_Record_Constraint (Def, Type_Mark, Resolution); + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => -- LRM93 4.2 -- A subtype indication denoting an access type [or a file type] -- may not contain a resolution function. - if Get_Resolution_Function (Def) /= Null_Iir then + if Resolution /= Null_Iir then Error_Msg_Sem ("resolution function not allowed for an access type", Def); end if; @@ -1491,9 +1826,11 @@ package body Sem_Types is Sub_Type : Iir; pragma Unreferenced (Sub_Type); Base_Type : Iir; + Res : Iir; begin Base_Type := Get_Designated_Type (Type_Mark); - Sub_Type := Sem_Array_Subtype_Indication (Base_Type, Def); + Sub_Type := Sem_Array_Constraint + (Def, Base_Type, Null_Iir); Res := Create_Iir (Iir_Kind_Access_Subtype_Definition); Location_Copy (Res, Def); Set_Base_Type (Res, Type_Mark); @@ -1506,50 +1843,157 @@ package body Sem_Types is end case; when Iir_Kind_File_Type_Definition => - if Get_Kind (Def) = Iir_Kind_Subtype_Definition then - Free_Name (Def); + -- LRM08 6.3 Subtype declarations + -- A subtype indication denoting a subtype of [...] a file + -- type [...] shall not contain a constraint. + if Get_Kind (Def) /= Iir_Kind_Subtype_Definition + or else Get_Range_Constraint (Def) /= Null_Iir + then + Error_Msg_Sem ("file types can't be constrained", Def); + return Type_Mark; + end if; + + -- LRM93 4.2 + -- A subtype indication denoting [an access type or] a file type + -- may not contain a resolution function. + if Resolution /= Null_Iir then + Error_Msg_Sem + ("resolution function not allowed for file types", Def); + return Type_Mark; + end if; + Free_Name (Def); + return Type_Mark; + + when Iir_Kind_Protected_Type_Declaration => + -- LRM08 6.3 Subtype declarations + -- A subtype indication denoting a subtype of [...] a protected + -- type [...] shall not contain a constraint. + if Get_Kind (Def) /= Iir_Kind_Subtype_Definition + or else Get_Range_Constraint (Def) /= Null_Iir + then + Error_Msg_Sem ("protected types can't be constrained", Def); + return Type_Mark; + end if; + + -- LRM08 6.3 Subtype declarations + -- A subtype indication denoting [...] a protected type shall + -- not contain a resolution function. + if Resolution /= Null_Iir then + Error_Msg_Sem + ("resolution function not allowed for file types", Def); return Type_Mark; - else - raise Internal_Error; end if; + Free_Name (Def); + return Type_Mark; when others => Error_Kind ("sem_subtype_indication", Type_Mark); - return Def; + return Type_Mark; end case; + end Sem_Subtype_Constraint; + + -- Semantize a subtype indication. + -- DEF can be either a name or an iir_subtype_definition. + -- Return a new (an anonymous) subtype definition (with the correct kind), + -- or an already defined type definition (if DEF is a name). + function Sem_Subtype_Indication (Def: Iir; Incomplete : Boolean := False) + return Iir + is + Type_Mark: Iir; + Decl_Kind : Decl_Kind_Type; + begin + if Incomplete then + Decl_Kind := Decl_Incomplete_Type; + else + Decl_Kind := Decl_Type; + end if; + + -- LRM08 6.3 Subtype declarations + -- + -- If the subtype indication does not include a constraint, the subtype + -- is the same as that denoted by the type mark. + if Get_Kind (Def) in Iir_Kinds_Name then + Type_Mark := Find_Declaration (Def, Decl_Kind); + if Type_Mark = Null_Iir then + return Create_Error_Type (Def); + else + return Type_Mark; + end if; + end if; + + -- Semantize the type mark. + Type_Mark := Find_Declaration (Get_Type_Mark (Def), Decl_Kind); + if Type_Mark = Null_Iir then + -- FIXME: handle inversion such as "subtype BASETYPE RESOLV", which + -- should emit "resolution function must precede type name". + return Create_Error_Type (Get_Type_Mark (Def)); + end if; + Set_Type_Mark (Def, Type_Mark); + + return Sem_Subtype_Constraint + (Def, Type_Mark, Get_Resolution_Function (Def)); end Sem_Subtype_Indication; - function Sem_Is_Constrained (A_Type: Iir) return Boolean is + function Copy_Subtype_Indication (Def : Iir) return Iir + is + Res : Iir; begin - case Get_Kind (A_Type) is - when Iir_Kind_Array_Subtype_Definition => - return True; - when Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Integer_Type_Definition + case Get_Kind (Def) is + when Iir_Kind_Integer_Subtype_Definition | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Floating_Type_Definition - | Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition - | Iir_Kind_File_Type_Definition => - --| Iir_Kind_File_Subtype_Definition => - return True; - when Iir_Kind_Protected_Type_Declaration => - return True; - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => - return False; - when Iir_Kind_Incomplete_Type_Definition => - return False; - when Iir_Kind_Error => - return True; + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Res := Create_Iir (Get_Kind (Def)); + Set_Range_Constraint (Res, Get_Range_Constraint (Def)); + Set_Resolution_Function (Res, Get_Resolution_Function (Def)); + when Iir_Kind_Enumeration_Type_Definition => + Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + Set_Type_Mark (Res, Def); + Set_Range_Constraint (Res, Get_Range_Constraint (Def)); + + when Iir_Kind_Access_Subtype_Definition + | Iir_Kind_Access_Type_Definition => + Res := Create_Iir (Iir_Kind_Access_Subtype_Definition); + + when Iir_Kind_Array_Type_Definition => + Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Type_Staticness (Res, Get_Type_Staticness (Def)); + Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); + Set_Type_Mark (Res, Def); + Set_Index_Subtype_List (Res, Get_Index_Subtype_List (Def)); + Set_Element_Subtype (Res, Get_Element_Subtype (Def)); + Set_Index_Constraint_Flag (Res, False); + Set_Constraint_State (Res, Get_Constraint_State (Def)); + when Iir_Kind_Array_Subtype_Definition => + Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Resolution_Function (Res, Get_Resolution_Function (Def)); + Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); + Set_Type_Mark (Res, Def); + Set_Index_Subtype_List (Res, Get_Index_Subtype_List (Def)); + Set_Element_Subtype (Res, Get_Element_Subtype (Def)); + Set_Index_Constraint_Flag + (Res, Get_Index_Constraint_Flag (Def)); + Set_Constraint_State (Res, Get_Constraint_State (Def)); + + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Res := Create_Iir (Iir_Kind_Record_Subtype_Definition); + Set_Type_Staticness (Res, Get_Type_Staticness (Def)); + if Get_Kind (Def) /= Iir_Kind_Record_Type_Definition then + Set_Resolution_Function + (Res, Get_Resolution_Function (Def)); + end if; + Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); + Set_Constraint_State (Res, Get_Constraint_State (Def)); + when others => - Error_Kind ("sem_is_constrained", A_Type); + -- FIXME: todo + Error_Kind ("copy_subtype_indication", Def); end case; - end Sem_Is_Constrained; - + Location_Copy (Res, Def); + Set_Base_Type (Res, Get_Base_Type (Def)); + Set_Type_Staticness (Res, Get_Type_Staticness (Def)); + Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Def)); + return Res; + end Copy_Subtype_Indication; end Sem_Types; diff --git a/sem_types.ads b/sem_types.ads index c71ebbc9d..dc36640ad 100644 --- a/sem_types.ads +++ b/sem_types.ads @@ -28,7 +28,7 @@ package Sem_Types is return Iir; -- Return FALSE if A_TYPE is an unconstrained array type or subtype. - function Sem_Is_Constrained (A_Type: Iir) return Boolean; + --function Sem_Is_Constrained (A_Type: Iir) return Boolean; procedure Sem_Protected_Type_Body (Bod : Iir); @@ -50,4 +50,8 @@ package Sem_Types is -- If ATYPE is not NULL_IIR, type must match. function Is_A_Resolution_Function (Func: Iir; Atype: Iir) return Boolean; + -- Return a subtype definition copy of DEF. + -- This is used when an alias of DEF is required (eg: subtype a is b). + function Copy_Subtype_Indication (Def : Iir) return Iir; + end Sem_Types; diff --git a/std_package.adb b/std_package.adb index cc69d3344..6d090fdf0 100644 --- a/std_package.adb +++ b/std_package.adb @@ -314,6 +314,7 @@ package body Std_Package is Set_Signal_Type_Flag (Bit_Type_Definition, True); Set_Has_Signal_Flag (Bit_Type_Definition, not Flags.Flag_Whole_Analyze); + Set_Only_Characters_Flag (Bit_Type_Definition, True); -- type bit is Bit_Type := Create_Std_Decl (Iir_Kind_Type_Declaration); diff --git a/translate/gcc/Makefile.in b/translate/gcc/Makefile.in index 9f47e58a9..d5de5c767 100644 --- a/translate/gcc/Makefile.in +++ b/translate/gcc/Makefile.in @@ -80,7 +80,6 @@ T_CPPFLAGS = X_ADAFLAGS = T_ADAFLAGS = -CC = cc ADAC = $(CC) ECHO = echo diff --git a/translate/translation.adb b/translate/translation.adb index 1e5658109..e5e9b5999 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -3632,22 +3632,24 @@ package body Translation is Var_Record : Mnode; Sub_Data : Data_Type; Composite_Data : Composite_Data_Type; + List : Iir_List; El : Iir_Element_Declaration; begin Open_Temp; Var_Record := Stabilize (Targ); Composite_Data := Prepare_Data_Record (Var_Record, Targ_Type, Data); - El := Get_Element_Declaration_Chain + List := Get_Elements_Declaration_List (Get_Base_Type (Targ_Type)); - while El /= Null_Iir loop + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; Sub_Data := Update_Data_Record (Composite_Data, Targ_Type, El); Foreach_Non_Composite (Chap6.Translate_Selected_Element (Var_Record, El), Get_Type (El), Sub_Data); - El := Get_Chain (El); end loop; Finish_Data_Record (Composite_Data); Close_Temp; @@ -3845,9 +3847,7 @@ package body Translation is El := Get_Port_Chain (Entity); while El /= Null_Iir loop El_Type := Get_Type (El); - if Get_Kind (El_Type) - in Iir_Kinds_Unconstrained_Array_Type_Definition - then + if not Is_Fully_Constrained_Type (El_Type) then Chap5.Elab_Unconstrained_Port (El, Get_Default_Value (El)); end if; Chap4.Elab_Signal_Declaration_Storage (El); @@ -4622,7 +4622,8 @@ package body Translation is Std_Names.Name_Op_Mul => "OPMu", Std_Names.Name_Op_Div => "OPDi", Std_Names.Name_Op_Exp => "OPEx", - Std_Names.Name_Op_Concatenation => "OPCc"); + Std_Names.Name_Op_Concatenation => "OPCc", + Std_Names.Name_Op_Condition => "OPCd"); -- Set the identifier prefix with the subprogram identifier and -- overload number if any. @@ -4767,9 +4768,7 @@ package body Translation is Tinfo.Ortho_Ptr_Type (Mode_Value)); -- Furthermore, if the result type is unconstrained, the -- function will allocate it on a secondary stack. - if Get_Kind (Rtype) - in Iir_Kinds_Unconstrained_Array_Type_Definition - then + if not Is_Fully_Constrained_Type (Rtype) then Info.Use_Stack2 := True; end if; else @@ -5886,8 +5885,7 @@ package body Translation is when Iir_Kinds_Scalar_Type_Definition => return 1; when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => + | Iir_Kind_Array_Subtype_Definition => return 2 + Get_File_Signature_Length (Get_Element_Subtype (Def)); when Iir_Kind_Record_Type_Definition @@ -5895,12 +5893,14 @@ package body Translation is declare El : Iir; Res : Natural; + List : Iir_List; begin Res := 2; - El := Get_Element_Declaration_Chain (Get_Base_Type (Def)); - while El /= Null_Iir loop + List := Get_Elements_Declaration_List (Get_Base_Type (Def)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; Res := Res + Get_File_Signature_Length (Get_Type (El)); - El := Get_Chain (El); end loop; return Res; end; @@ -5921,8 +5921,7 @@ package body Translation is Res (Off) := Scalar_Map (Get_Info (Def).Type_Mode); Off := Off + 1; when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => + | Iir_Kind_Array_Subtype_Definition => Res (Off) := '['; Off := Off + 1; Get_File_Signature (Get_Element_Subtype (Def), Res, Off); @@ -5932,13 +5931,15 @@ package body Translation is | Iir_Kind_Record_Subtype_Definition => declare El : Iir; + List : Iir_List; begin Res (Off) := '<'; Off := Off + 1; - El := Get_Element_Declaration_Chain (Get_Base_Type (Def)); - while El /= Null_Iir loop + List := Get_Elements_Declaration_List (Get_Base_Type (Def)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; Get_File_Signature (Get_Type (El), Res, Off); - El := Get_Chain (El); end loop; Res (Off) := '>'; Off := Off + 1; @@ -6500,6 +6501,7 @@ package body Translation is procedure Translate_Record_Type (Def : Iir_Record_Type_Definition) is El_List : O_Element_List; + List : Iir_List; El : Iir_Element_Declaration; Info : Type_Info_Acc; Field_Info : Ortho_Info_Acc; @@ -6514,8 +6516,10 @@ package body Translation is begin Info := Get_Info (Def); Need_Size := False; - El := Get_Element_Declaration_Chain (Def); - while El /= Null_Iir loop + List := Get_Elements_Declaration_List (Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; El_Type := Get_Type (El); if Get_Info (El_Type) = null then Push_Identifier_Prefix (Mark, Get_Identifier (El)); @@ -6526,20 +6530,19 @@ package body Translation is Need_Size := True; end if; Field_Info := Add_Info (El, Kind_Field); - El := Get_Chain (El); end loop; Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop Start_Record_Type (El_List); - El := Get_Element_Declaration_Chain (Def); - while El /= Null_Iir loop + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; Field_Info := Get_Info (El); El_Tinfo := Get_Info (Get_Type (El)); New_Record_Field (El_List, Field_Info.Field_Node (Kind), Create_Identifier_Without_Prefix (El), Chap4.Get_Element_Type (El_Tinfo, Kind)); - El := Get_Chain (El); end loop; Finish_Record_Type (El_List, Info.Ortho_Type (Kind)); end loop; @@ -6556,6 +6559,7 @@ package body Translation is (Def : Iir_Record_Type_Definition; Kind : Object_Kind_Type) is Base : O_Dnode; + List : Iir_List; El : Iir_Element_Declaration; function Get_Field_Lnode @@ -6596,14 +6600,15 @@ package body Translation is Char_Ptr_Type)); -- Set memory for each complex element. - El := Get_Element_Declaration_Chain (Def); - while El /= Null_Iir loop + List := Get_Elements_Declaration_List (Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; El_Type := Get_Type (El); if Get_Info (El_Type).C /= null then -- Complex type. Update_Field (El_Type, Mem, Kind); end if; - El := Get_Chain (El); end loop; Chap2.Finish_Subprg_Instance_Use (Info.C.Builder_Instance (Kind)); New_Return_Stmt (New_Obj_Value (Mem)); @@ -6625,8 +6630,7 @@ package body Translation is D_Info := Get_Info (D_Type); Def_Info := Get_Info (Def); - if Get_Kind (D_Type) in Iir_Kinds_Unconstrained_Array_Type_Definition - then + if not Is_Fully_Constrained_Type (D_Type) then -- An access type to an unconstrained type definition is a fat -- pointer. Def_Info.Type_Mode := Type_Mode_Fat_Acc; @@ -7002,10 +7006,12 @@ package body Translation is Create_Scalar_Type_Range (Def, Target); when Iir_Kind_Array_Subtype_Definition => - Info := Get_Info (Def); - if not Info.T.Static_Bounds then - Target := Get_Var (Info.T.Array_Bounds); - Create_Array_Subtype_Bounds (Def, Target); + if Get_Constraint_State (Def) = Fully_Constrained then + Info := Get_Info (Def); + if not Info.T.Static_Bounds then + Target := Get_Var (Info.T.Array_Bounds); + Create_Array_Subtype_Bounds (Def, Target); + end if; end if; when Iir_Kind_Array_Type_Definition => @@ -7013,7 +7019,6 @@ package body Translation is return; when Iir_Kind_Access_Type_Definition | Iir_Kind_Access_Subtype_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition | Iir_Kind_File_Type_Definition | Iir_Kind_Record_Type_Definition | Iir_Kind_Record_Subtype_Definition @@ -7074,21 +7079,23 @@ package body Translation is end if; when Type_Mode_Record => declare + List : Iir_List; El : Iir_Element_Declaration; N_Res : O_Enode; begin V := New_Sizeof (Info.Ortho_Type (Kind), Ghdl_Index_Type); - El := Get_Element_Declaration_Chain + List := Get_Elements_Declaration_List (Get_Base_Type (Def)); Res := New_Lit (V); - while El /= Null_Iir loop + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; N_Res := Get_Additionnal_Size (Get_Type (El), Kind); if N_Res /= O_Enode_Null then Res := New_Dyadic_Op (ON_Add_Ov, Res, N_Res); end if; - El := Get_Chain (El); end loop; end; when Type_Mode_Ptr_Array => @@ -7188,14 +7195,16 @@ package body Translation is declare El : Iir; Asub : Iir; + List : Iir_List; begin - El := Get_Element_Declaration_Chain (Def); - while El /= Null_Iir loop + List := Get_Elements_Declaration_List (Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; Asub := Get_Type (El); if Is_Anonymous_Type_Definition (Asub) then Handle_A_Subtype (Asub); end if; - El := Get_Chain (El); end loop; end; when others => @@ -7421,21 +7430,26 @@ package body Translation is -- Info.Type_Range_Type := Create_Array_Type_Bounds_Type (Def, Id); when Iir_Kind_Array_Subtype_Definition => - if Base_Info = null or else Base_Info.Type_Incomplete then - declare - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, "BT"); - Translate_Type_Definition (Base_Type); - Pop_Identifier_Prefix (Mark); - Base_Info := Get_Info (Base_Type); - end; - end if; - Translate_Array_Subtype (Def); - Info.T := Base_Info.T; - --Info.Type_Range_Type := Base_Info.Type_Range_Type; - if With_Vars then - Create_Array_Subtype_Bounds_Var (Def, False); + if Get_Index_Constraint_Flag (Def) then + if Base_Info = null or else Base_Info.Type_Incomplete then + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, "BT"); + Translate_Type_Definition (Base_Type); + Pop_Identifier_Prefix (Mark); + Base_Info := Get_Info (Base_Type); + end; + end if; + Translate_Array_Subtype (Def); + Info.T := Base_Info.T; + --Info.Type_Range_Type := Base_Info.Type_Range_Type; + if With_Vars then + Create_Array_Subtype_Bounds_Var (Def, False); + end if; + else + Free_Info (Def); + Set_Info (Def, Base_Info); end if; when Iir_Kind_Record_Type_Definition => @@ -7443,8 +7457,7 @@ package body Translation is Info.T := Ortho_Info_Type_Record_Init; when Iir_Kind_Record_Subtype_Definition - | Iir_Kind_Access_Subtype_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => + | Iir_Kind_Access_Subtype_Definition => Free_Info (Def); Set_Info (Def, Base_Info); @@ -8113,13 +8126,16 @@ package body Translation is Kind); when Type_Mode_Record => declare + List : Iir_List; El : Iir_Element_Declaration; El_Type : Iir; El_Info : Type_Info_Acc; begin - El := Get_Element_Declaration_Chain + List := Get_Elements_Declaration_List (Get_Base_Type (Obj_Type)); - while El /= Null_Iir loop + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; El_Type := Get_Type (El); El_Info := Get_Info (El_Type); if El_Info.C /= null then @@ -8129,7 +8145,6 @@ package body Translation is El_Type, Kind); end if; - El := Get_Chain (El); end loop; -- Record is known to be complex but has no complex -- element. @@ -9173,15 +9188,17 @@ package body Translation is declare Sobj : Mnode; El : Iir_Element_Declaration; + List : Iir_List; begin Open_Temp; Sobj := Stabilize (Obj); - El := Get_Element_Declaration_Chain + List := Get_Elements_Declaration_List (Get_Base_Type (Obj_Type)); - while El /= Null_Iir loop + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; Init_Object (Chap6.Translate_Selected_Element (Sobj, El), Get_Type (El)); - El := Get_Chain (El); end loop; Close_Temp; end; @@ -9395,21 +9412,23 @@ package body Translation is Get_Element_Subtype (Sig_Type))); when Type_Mode_Record => declare + List : Iir_List; El : Iir; Res : O_Enode; E : O_Enode; begin - El := - Get_Element_Declaration_Chain (Get_Base_Type (Sig_Type)); + List := + Get_Elements_Declaration_List (Get_Base_Type (Sig_Type)); Res := O_Enode_Null; - while El /= Null_Iir loop + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; E := Get_Nbr_Signals (Mnode_Null, Get_Type (El)); if Res /= O_Enode_Null then Res := New_Dyadic_Op (ON_Add_Ov, Res, E); else Res := E; end if; - El := Get_Chain (El); end loop; if Res = O_Enode_Null then return New_Lit (Ghdl_Index_0); @@ -9454,8 +9473,9 @@ package body Translation is declare Element : Iir; begin - Element := Get_Element_Declaration_Chain - (Get_Base_Type (Res_Type)); + Element := Get_First_Element + (Get_Elements_Declaration_List + (Get_Base_Type (Res_Type))); Res := Chap6.Translate_Selected_Element (Res, Element); Res_Type := Get_Type (Element); end; @@ -11038,6 +11058,9 @@ package body Translation is Push_Identifier_Prefix (Mark3, Get_Identifier (Get_Base_Name (Formal))); + -- Handle anonymous subtypes. + Chap3.Translate_Anonymous_Type_Definition (Out_Type, False); + Chap3.Translate_Anonymous_Type_Definition (In_Type, False); Out_Info := Get_Info (Out_Type); In_Info := Get_Info (In_Type); @@ -11764,9 +11787,7 @@ package body Translation is begin Actual_Type := Get_Type (Actual); Open_Temp; - if Get_Kind (Actual_Type) - not in Iir_Kinds_Unconstrained_Array_Type_Definition - then + if Is_Fully_Constrained_Type (Actual_Type) then Chap3.Create_Array_Subtype (Actual_Type, False); Tinfo := Get_Info (Actual_Type); Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); @@ -13743,6 +13764,12 @@ package body Translation is when others => Error_Kind ("tranlate_numeric_literal", Expr); end case; + exception + when Constraint_Error => + -- Can be raised by Get_Physical_Unit_Value because of the kludge + -- on staticness. + Error_Msg_Elab ("numeric literal not in range", Expr); + return New_Signed_Literal (Res_Type, 0); end Translate_Numeric_Literal; function Translate_Numeric_Literal (Expr : Iir; Res_Type : Iir) @@ -15238,8 +15265,10 @@ package body Translation is Aggr_Type : constant Iir := Get_Type (Aggr); Aggr_Base_Type : constant Iir_Record_Type_Definition := Get_Base_Type (Aggr_Type); - Nbr_El : constant Iir_Index32 := - Get_Number_Element_Declaration (Aggr_Base_Type); + El_List : constant Iir_List := + Get_Elements_Declaration_List (Aggr_Base_Type); + El_Index : Natural; + Nbr_El : constant Natural := Get_Nbr_Elements (El_List); -- Record which elements of the record have been set. The 'others' -- clause applies to all elements not already set. @@ -15255,16 +15284,15 @@ package body Translation is begin Translate_Assign (Chap6.Translate_Selected_Element (Targ, El), El_Expr, Get_Type (El)); - Set_Array (Get_Element_Position (El)) := True; + Set_Array (Natural (Get_Element_Position (El))) := True; end Set_El; Assoc : Iir; - El : Iir; N_El_Expr : Iir; begin Open_Temp; Targ := Stabilize (Target); - El := Get_Element_Declaration_Chain (Aggr_Base_Type); + El_Index := 0; Assoc := Get_Association_Choices_Chain (Aggr); while Assoc /= Null_Iir loop N_El_Expr := Get_Associated (Assoc); @@ -15273,20 +15301,17 @@ package body Translation is end if; case Get_Kind (Assoc) is when Iir_Kind_Choice_By_None => - Set_El (El); - El := Get_Chain (El); + Set_El (Get_Nth_Element (El_List, El_Index)); + El_Index := El_Index + 1; when Iir_Kind_Choice_By_Name => Set_El (Get_Name (Assoc)); - El := Null_Iir; + El_Index := Natural'Last; when Iir_Kind_Choice_By_Others => - El := Get_Element_Declaration_Chain (Aggr_Base_Type); for J in Set_Array'Range loop if not Set_Array (J) then - Set_El (El); + Set_El (Get_Nth_Element (El_List, J)); end if; - El := Get_Chain (El); end loop; - pragma Assert (El = Null_Iir); when others => Error_Kind ("translate_record_aggregate", Assoc); end case; @@ -15664,13 +15689,14 @@ package body Translation is -- If res_type = expr_type, do not convert. -- FIXME: range check ? return New_Convert_Ov (Expr, Res_Info.Ortho_Type (Mode_Value)); - when Iir_Kind_Array_Subtype_Definition => - return Translate_Array_Subtype_Conversion - (Expr, Expr_Type, Res_Type, Loc); - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => - return Translate_Fat_Array_Type_Conversion - (Expr, Expr_Type, Res_Type, Loc); + when Iir_Kinds_Array_Type_Definition => + if Get_Constraint_State (Res_Type) = Fully_Constrained then + return Translate_Array_Subtype_Conversion + (Expr, Expr_Type, Res_Type, Loc); + else + return Translate_Fat_Array_Type_Conversion + (Expr, Expr_Type, Res_Type, Loc); + end if; when others => Error_Kind ("translate_type_conversion", Res_Type); end case; @@ -16958,6 +16984,7 @@ package body Translation is If_Blk : O_If_Block; Le, Re : Mnode; + El_List : Iir_List; El : Iir_Element_Declaration; begin Rec_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); @@ -16987,8 +17014,10 @@ package body Translation is R := Dp2M (Var_R, Info, Mode_Value); -- Compare each element. - El := Get_Element_Declaration_Chain (Rec_Type); - while El /= Null_Iir loop + El_List := Get_Elements_Declaration_List (Rec_Type); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; Le := Chap6.Translate_Selected_Element (L, El); Re := Chap6.Translate_Selected_Element (R, El); @@ -17000,7 +17029,6 @@ package body Translation is New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); Finish_If_Stmt (If_Blk); Close_Temp; - El := Get_Chain (El); end loop; New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); Chap2.Finish_Subprg_Instance_Use (Subprg); @@ -17842,18 +17870,20 @@ package body Translation is New_Procedure_Call (Assocs); when Type_Mode_Record => declare + El_List : Iir_List; El : Iir; Val1 : Mnode; begin Open_Temp; Val1 := Stabilize (Val); - El := Get_Element_Declaration_Chain + El_List := Get_Elements_Declaration_List (Get_Base_Type (Val_Type)); - while El /= Null_Iir loop + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; Translate_Rw (Chap6.Translate_Selected_Element (Val1, El), Get_Type (El), Proc); - El := Get_Chain (El); end loop; Close_Temp; end; @@ -18676,19 +18706,20 @@ package body Translation is (Targ : Iir_Aggregate; Targ_Type : Iir; Val : Mnode) is Aggr_El : Iir; - El : Iir_Element_Declaration; + El_List : Iir_List; + El_Index : Natural; Elem : Iir; begin - El := Get_Element_Declaration_Chain (Get_Base_Type (Targ_Type)); + El_List := Get_Elements_Declaration_List (Get_Base_Type (Targ_Type)); + El_Index := 0; Aggr_El := Get_Association_Choices_Chain (Targ); while Aggr_El /= Null_Iir loop case Get_Kind (Aggr_El) is when Iir_Kind_Choice_By_None => - Elem := El; - El := Get_Chain (El); + Elem := Get_Nth_Element (El_List, El_Index); + El_Index := El_Index + 1; when Iir_Kind_Choice_By_Name => Elem := Get_Name (Aggr_El); - El := Null_Iir; when others => Error_Kind ("translate_variable_rec_aggr", Aggr_El); end case; @@ -20221,20 +20252,22 @@ package body Translation is (Aggr : Mnode; Target : Iir; Target_Type : Iir) is Aggr_El : Iir; - El_Decl : Iir_Element_Declaration; + El_List : Iir_List; + El_Index : Natural; Element : Iir_Element_Declaration; begin - El_Decl := Get_Element_Declaration_Chain + El_List := Get_Elements_Declaration_List (Get_Base_Type (Target_Type)); + El_Index := 0; Aggr_El := Get_Association_Choices_Chain (Target); while Aggr_El /= Null_Iir loop case Get_Kind (Aggr_El) is when Iir_Kind_Choice_By_None => - Element := El_Decl; - El_Decl := Get_Chain (El_Decl); + Element := Get_Nth_Element (El_List, El_Index); + El_Index := El_Index + 1; when Iir_Kind_Choice_By_Name => Element := Get_Name (Aggr_El); - El_Decl := Null_Iir; + El_Index := Natural'Last; when others => Error_Kind ("translate_signal_target_record_aggr", Aggr_El); end case; @@ -25393,10 +25426,6 @@ package body Translation is Base_Type := Get_Base_Type (Atype); Base := Get_Info (Base_Type).Type_Rti; Kind := Ghdl_Rtik_Subtype_Access; - when Iir_Kind_Unconstrained_Array_Subtype_Definition => - Base_Type := Get_Base_Type (Atype); - Base := Get_Info (Base_Type).Type_Rti; - Kind := Ghdl_Rtik_Subtype_Unconstrained_Array; when others => Error_Kind ("rti.generate_fileacc_type_definition", Atype); end case; @@ -25545,6 +25574,11 @@ package body Translation is Mark : Id_Mark_Type; Depth : Rti_Depth_Type; begin + -- FIXME: temporary work-around + if Get_Constraint_State (Atype) /= Fully_Constrained then + return; + end if; + Info := Get_Info (Atype); Base_Type := Get_Base_Type (Atype); @@ -25576,6 +25610,8 @@ package body Translation is Kind := Ghdl_Rtik_Subtype_Array; when Type_Mode_Ptr_Array => Kind := Ghdl_Rtik_Subtype_Array_Ptr; + when Type_Mode_Fat_Array => + Kind := Ghdl_Rtik_Subtype_Unconstrained_Array; when others => Error_Kind ("generate_array_subtype_definition", Atype); end case; @@ -25585,7 +25621,12 @@ package body Translation is Info.T.Rti_Max_Depth, Type_To_Mode (Info))); New_Record_Aggr_El (Aggr, New_Name_Address (Name)); New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); - New_Record_Aggr_El (Aggr, Var_Acc_To_Loc (Bounds)); + if Bounds = null then + Val := Get_Null_Loc; + else + Val := Var_Acc_To_Loc (Bounds); + end if; + New_Record_Aggr_El (Aggr, Val); for I in Mode_Value .. Mode_Signal loop case Info.Type_Mode is when Type_Mode_Array => @@ -25602,6 +25643,8 @@ package body Translation is else Val := Get_Null_Loc; end if; + when Type_Mode_Fat_Array => + Val := Get_Null_Loc; when others => Error_Kind ("generate_array_subtype_definition", Atype); end case; @@ -25614,7 +25657,7 @@ package body Translation is procedure Generate_Record_Type_Definition (Atype : Iir) is - El_Chain : Iir; + El_List : Iir_List; El : Iir; Prev : Rti_Block; El_Arr : O_Dnode; @@ -25628,13 +25671,14 @@ package body Translation is return; end if; - El_Chain := Get_Element_Declaration_Chain (Atype); + El_List := Get_Elements_Declaration_List (Atype); Max_Depth := 0; -- Generate elements. Push_Rti_Node (Prev, False); - El := El_Chain; - while El /= Null_Iir loop + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; declare Type_Rti : O_Dnode; El_Name : O_Dnode; @@ -25678,7 +25722,6 @@ package body Translation is Pop_Identifier_Prefix (Mark); end; - El := Get_Chain (El); end loop; El_Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); Pop_Rti_Node (Prev); @@ -25700,8 +25743,7 @@ package body Translation is New_Record_Aggr_El (Aggr, New_Name_Address (Name)); New_Record_Aggr_El (Aggr, New_Unsigned_Literal - (Ghdl_Index_Type, - Unsigned_64 (Get_Number_Element_Declaration (Atype)))); + (Ghdl_Index_Type, Unsigned_64 (Get_Nbr_Elements (El_List)))); New_Record_Aggr_El (Aggr, New_Global_Address (El_Arr, Ghdl_Rti_Arr_Acc)); Finish_Record_Aggr (Aggr, Res); @@ -25766,8 +25808,7 @@ package body Translation is | Iir_Kind_File_Type_Definition => Generate_Fileacc_Type_Definition (Atype); when Iir_Kind_Record_Subtype_Definition - | Iir_Kind_Access_Subtype_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => + | Iir_Kind_Access_Subtype_Definition => -- FIXME: No separate infos (yet). null; when Iir_Kind_Record_Type_Definition => @@ -28321,8 +28362,7 @@ package body Translation is Free_Info (I); end if; when Iir_Kind_Record_Subtype_Definition - | Iir_Kind_Access_Subtype_Definition - | Iir_Kind_Unconstrained_Array_Subtype_Definition => + | Iir_Kind_Access_Subtype_Definition => null; when Iir_Kind_Enumeration_Type_Definition | Iir_Kind_Array_Type_Definition @@ -28332,9 +28372,11 @@ package body Translation is | Iir_Kind_Enumeration_Subtype_Definition => Free_Type_Info (Info, True); when Iir_Kind_Array_Subtype_Definition => - Free_Var (Info.T.Array_Bounds); - Info.T := Ortho_Info_Type_Array_Init; - Free_Type_Info (Info, True); + if Get_Index_Constraint_Flag (I) then + Free_Var (Info.T.Array_Bounds); + Info.T := Ortho_Info_Type_Array_Init; + Free_Type_Info (Info, True); + end if; when others => -- By default, info are not shared. -- The exception is infos for implicit subprograms, but @@ -28493,8 +28535,7 @@ package body Translation is -- Check port. El := Get_Port_Chain (Entity); while El /= Null_Iir loop - if Get_Kind (Get_Type (El)) in - Iir_Kinds_Unconstrained_Array_Type_Definition + if not Is_Fully_Constrained_Type (Get_Type (El)) and then Get_Default_Value (El) = Null_Iir then Error ("(" & Disp_Node (El) diff --git a/xtools/check_iirs_pkg.adb b/xtools/check_iirs_pkg.adb index fc4595116..d0f581875 100644 --- a/xtools/check_iirs_pkg.adb +++ b/xtools/check_iirs_pkg.adb @@ -888,7 +888,9 @@ package body Check_Iirs_Pkg is Func_Table.Table (Func).Field := Field; else -- Field redefined for the function. - Put_Line ("** field redefined for the function"); + Put_Line (Standard_Error, + "** field redefined for function " + & Func_Table.Table (Func).Name.all); raise Err; end if; end if; |