summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorgingold2009-08-13 04:09:58 +0000
committergingold2009-08-13 04:09:58 +0000
commit891ddbc416cb7a8303bfac692441b65d272d82f5 (patch)
tree105909be9f5c878efc0d90225541e179fe1766f7
parentf67ca35dcd18b5427c55605de0129917a85a1349 (diff)
downloadghdl-891ddbc416cb7a8303bfac692441b65d272d82f5.tar.gz
ghdl-891ddbc416cb7a8303bfac692441b65d272d82f5.tar.bz2
ghdl-891ddbc416cb7a8303bfac692441b65d272d82f5.zip
Now handle vhdl 2008 arrays in the front end.
Bug fixes.
Diffstat
-rw-r--r--configuration.adb5
-rw-r--r--disp_tree.adb44
-rw-r--r--disp_vhdl.adb144
-rw-r--r--errorout.adb5
-rw-r--r--evaluation.adb27
-rw-r--r--evaluation.ads3
-rw-r--r--ieee-std_logic_1164.adb9
-rw-r--r--iir_chains.ads4
-rw-r--r--iirs.adb177
-rw-r--r--iirs.adb.in18
-rw-r--r--iirs.ads102
-rw-r--r--iirs_utils.adb7
-rw-r--r--iirs_utils.ads4
-rw-r--r--name_table.adb3
-rw-r--r--nodes.ads2
-rw-r--r--parse.adb222
-rw-r--r--sem.adb49
-rw-r--r--sem_assocs.adb94
-rw-r--r--sem_decls.adb176
-rw-r--r--sem_expr.adb471
-rw-r--r--sem_expr.ads4
-rw-r--r--sem_names.adb15
-rw-r--r--sem_stmts.adb7
-rw-r--r--sem_types.adb1196
-rw-r--r--sem_types.ads6
-rw-r--r--std_package.adb1
-rw-r--r--translate/gcc/Makefile.in1
-rw-r--r--translate/translation.adb301
-rw-r--r--xtools/check_iirs_pkg.adb4
29 files changed, 2117 insertions, 984 deletions
diff --git a/configuration.adb b/configuration.adb
index 0aa3ad2..f5d177f 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 7e72a12..6ad16d7 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 57b2d4d..57132fb 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 32b1249..544f56b 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 c543003..4742aee 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 a54ead3..282a752 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 561ed65..8ecd1ac 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 95b2f75..dc2f389 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);
diff --git a/iirs.adb b/iirs.adb
index 7e39bcc..1d6b041 100644
--- a/iirs.adb
+++ b/iirs.adb
@@ -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 06a0e58..cba22ae 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
diff --git a/iirs.ads b/iirs.ads
index 2773974..06fa587 100644
--- a/iirs.ads
+++ b/iirs.ads
@@ -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 9b441f7..46e51cc 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 67baa83..fce466c 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 85f6519..af60ec0 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.
diff --git a/nodes.ads b/nodes.ads
index 7d62c4b..bec29a9 100644
--- a/nodes.ads
+++ b/nodes.ads
@@ -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
diff --git a/parse.adb b/parse.adb
index 7a69de2..37d4103 100644
--- a/parse.adb
+++ b/parse.adb
@@ -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;
diff --git a/sem.adb b/sem.adb
index 395b67e..69a05bf 100644
--- a/sem.adb
+++ b/sem.adb
@@ -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 1b5f480..e89b29c 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 f555649..4d41c64 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 b26decd..74b7a1d 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 441e3e0..1c7713e 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 234926b..5d5fdd9 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 c5ec80b..d18a8af 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 fc8b932..4b54dd4 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 c71ebbc..dc36640 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 cc69d33..6d090fd 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 9f47e58..d5de5c7 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 1e56581..e5e9b59 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 fc45951..d0f5818 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;
generated by cgit (git 2.34.1) at 2025-03-30 08:52:22 +0000