diff options
| author | Tristan Gingold <tgingold@free.fr> | 2014-11-04 20:21:00 +0100 |
|---|---|---|
| committer | Tristan Gingold <tgingold@free.fr> | 2014-11-04 20:21:00 +0100 |
| commit | 0a088b311ed2fcebc542f8a2e42d09e2e3c9311c (patch) | |
| tree | 8ec898f38ddff616e459a0df57b3f4112bd96ffc /src/vhdl | |
| parent | 9c195bf5d86d67ea5eb419ccf6e48dc153e57c68 (diff) | |
| download | ghdl-0a088b311ed2fcebc542f8a2e42d09e2e3c9311c.tar.gz ghdl-0a088b311ed2fcebc542f8a2e42d09e2e3c9311c.tar.bz2 ghdl-0a088b311ed2fcebc542f8a2e42d09e2e3c9311c.zip | |
Create src/vhdl subdirectory.
Diffstat (limited to 'src/vhdl')
79 files changed, 76355 insertions, 0 deletions
diff --git a/src/vhdl/back_end.adb b/src/vhdl/back_end.adb new file mode 100644 index 000000000..81bc20732 --- /dev/null +++ b/src/vhdl/back_end.adb @@ -0,0 +1,38 @@ +-- Back-end specialization +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Flags; use Flags; +with Iirs_Utils; use Iirs_Utils; + +package body Back_End is + -- Transform a library identifier into a file name. + -- Very simple mechanism: just add '-simVV.cf' extension, where VV + -- is the version. + function Default_Library_To_File_Name (Library: Iir_Library_Declaration) + return String + is + begin + case Vhdl_Std is + when Vhdl_87 => + return Image_Identifier (Library) & "-obj87.cf"; + when Vhdl_93c | Vhdl_93 | Vhdl_00 | Vhdl_02 => + return Image_Identifier (Library) & "-obj93.cf"; + when Vhdl_08 => + return Image_Identifier (Library) & "-obj08.cf"; + end case; + end Default_Library_To_File_Name; +end Back_End; diff --git a/src/vhdl/back_end.ads b/src/vhdl/back_end.ads new file mode 100644 index 000000000..3ee1e686a --- /dev/null +++ b/src/vhdl/back_end.ads @@ -0,0 +1,57 @@ +-- Back-end specialization +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +package Back_End is + -- Return the name of the library file for LIBRARY. + -- The library file describe the contents of LIBRARY. + function Default_Library_To_File_Name (Library : Iir_Library_Declaration) + return String; + + type Library_To_File_Name_Acc is + access function (Library : Iir_Library_Declaration) return String; + + Library_To_File_Name : Library_To_File_Name_Acc := + Default_Library_To_File_Name'Access; + + -- Back-end options. + type Parse_Option_Acc is access function (Opt : String) return Boolean; + Parse_Option : Parse_Option_Acc := null; + + -- Disp back-end option help. + type Disp_Option_Acc is access procedure; + Disp_Option : Disp_Option_Acc := null; + + -- UNIT is a design unit from parse. + -- According to the current back-end, do what is necessary. + -- + -- If MAIN is true, then UNIT is a wanted to be analysed design unit, and + -- dump/list options can applied. + -- This avoid to dump/list units fetched (through a selected name or a + -- use clause) indirectly by the main unit. + type Finish_Compilation_Acc is access + procedure (Unit : Iir_Design_Unit; Main : Boolean := False); + + Finish_Compilation : Finish_Compilation_Acc := null; + + -- DECL is an architecture (library unit) or a subprogram (specification) + -- decorated with a FOREIGN attribute. Do back-end checks. + -- May be NULL for no additionnal checks. + type Sem_Foreign_Acc is access procedure (Decl : Iir); + Sem_Foreign : Sem_Foreign_Acc := null; +end Back_End; diff --git a/src/vhdl/canon.adb b/src/vhdl/canon.adb new file mode 100644 index 000000000..cd2dae0fd --- /dev/null +++ b/src/vhdl/canon.adb @@ -0,0 +1,2735 @@ +-- Canonicalization pass +-- Copyright (C) 2002, 2003, 2004, 2005, 2008 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Errorout; use Errorout; +with Iirs_Utils; use Iirs_Utils; +with Types; use Types; +with Name_Table; +with Sem; +with Iir_Chains; use Iir_Chains; +with Flags; use Flags; +with PSL.Nodes; +with PSL.Rewrites; +with PSL.Build; + +package body Canon is + -- Canonicalize a list of declarations. LIST can be null. + -- PARENT must be the parent of the current statements chain for LIST, + -- or NULL_IIR if LIST has no corresponding current statments. + procedure Canon_Declarations (Top : Iir_Design_Unit; + Decl_Parent : Iir; + Parent : Iir); + procedure Canon_Declaration (Top : Iir_Design_Unit; + Decl : Iir; + Parent : Iir; + Decl_Parent : Iir); + + -- Canon on expressions, mainly for function calls. + procedure Canon_Expression (Expr: Iir); + + -- Canonicalize an association list. + -- If ASSOCIATION_LIST is not null, then it is re-ordored and returned. + -- If ASSOCIATION_LIST is null then: + -- if INTERFACE_LIST is null then returns null. + -- if INTERFACE_LIST is not null, a default list is created. + function Canon_Association_Chain + (Interface_Chain: Iir; Association_Chain: Iir; Loc : Iir) + return Iir; + + -- Like Canon_Association_Chain but recurse on actuals. + function Canon_Association_Chain_And_Actuals + (Interface_Chain: Iir; Association_Chain: Iir; Loc : Iir) + return Iir; + + -- Like Canon_Subprogram_Call, but recurse on actuals. + procedure Canon_Subprogram_Call_And_Actuals (Call : Iir); + + -- Canonicalize block configuration CONF. + -- TOP is used to added dependences to the design unit which CONF + -- belongs to. + procedure Canon_Block_Configuration (Top : Iir_Design_Unit; + Conf : Iir_Block_Configuration); + + procedure Canon_Subtype_Indication (Def : Iir); + procedure Canon_Subtype_Indication_If_Anonymous (Def : Iir); + + procedure Canon_Extract_Sensitivity_Aggregate + (Aggr : Iir; + Sensitivity_List : Iir_List; + Is_Target : Boolean; + Aggr_Type : Iir; + Dim : Natural) + is + Assoc : Iir; + begin + Assoc := Get_Association_Choices_Chain (Aggr); + if Get_Nbr_Elements (Get_Index_Subtype_List (Aggr_Type)) = Dim then + while Assoc /= Null_Iir loop + Canon_Extract_Sensitivity + (Get_Associated_Expr (Assoc), Sensitivity_List, Is_Target); + Assoc := Get_Chain (Assoc); + end loop; + else + while Assoc /= Null_Iir loop + Canon_Extract_Sensitivity_Aggregate + (Get_Associated_Expr (Assoc), Sensitivity_List, + Is_Target, Aggr_Type, Dim + 1); + Assoc := Get_Chain (Assoc); + end loop; + end if; + end Canon_Extract_Sensitivity_Aggregate; + + procedure Canon_Extract_Sensitivity + (Expr: Iir; Sensitivity_List: Iir_List; Is_Target: Boolean := False) + is + El : Iir; + List: Iir_List; + begin + if Get_Expr_Staticness (Expr) /= None then + return; + end if; + + case Get_Kind (Expr) is + when Iir_Kind_Slice_Name => + if not Is_Target and then + Get_Name_Staticness (Expr) >= Globally + then + if Is_Signal_Object (Expr) then + Add_Element (Sensitivity_List, Expr); + end if; + else + declare + Suff : Iir; + begin + Canon_Extract_Sensitivity + (Get_Prefix (Expr), Sensitivity_List, Is_Target); + Suff := Get_Suffix (Expr); + if Get_Kind (Suff) not in Iir_Kinds_Scalar_Type_Definition + then + Canon_Extract_Sensitivity + (Suff, Sensitivity_List, False); + end if; + end; + end if; + + when Iir_Kind_Selected_Element => + if not Is_Target and then + Get_Name_Staticness (Expr) >= Globally + then + if Is_Signal_Object (Expr) then + Add_Element (Sensitivity_List, Expr); + end if; + else + Canon_Extract_Sensitivity (Get_Prefix (Expr), + Sensitivity_List, + Is_Target); + end if; + + when Iir_Kind_Indexed_Name => + if not Is_Target + and then Get_Name_Staticness (Expr) >= Globally + then + if Is_Signal_Object (Expr) then + Add_Element (Sensitivity_List, Expr); + end if; + else + Canon_Extract_Sensitivity (Get_Prefix (Expr), + Sensitivity_List, + Is_Target); + List := Get_Index_List (Expr); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Canon_Extract_Sensitivity (El, Sensitivity_List, False); + end loop; + end if; + + when Iir_Kind_Function_Call => + El := Get_Parameter_Association_Chain (Expr); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Association_Element_By_Expression => + Canon_Extract_Sensitivity + (Get_Actual (El), Sensitivity_List, False); + when Iir_Kind_Association_Element_Open => + null; + when others => + Error_Kind ("canon_extract_sensitivity(call)", El); + end case; + El := Get_Chain (El); + end loop; + + when Iir_Kind_Qualified_Expression + | Iir_Kind_Type_Conversion + | Iir_Kind_Allocator_By_Expression => + Canon_Extract_Sensitivity + (Get_Expression (Expr), Sensitivity_List, False); + + when Iir_Kind_Allocator_By_Subtype => + null; + + when Iir_Kinds_Monadic_Operator => + Canon_Extract_Sensitivity + (Get_Operand (Expr), Sensitivity_List, False); + when Iir_Kinds_Dyadic_Operator => + Canon_Extract_Sensitivity + (Get_Left (Expr), Sensitivity_List, False); + Canon_Extract_Sensitivity + (Get_Right (Expr), Sensitivity_List, False); + + when Iir_Kind_Range_Expression => + Canon_Extract_Sensitivity + (Get_Left_Limit (Expr), Sensitivity_List, False); + Canon_Extract_Sensitivity + (Get_Right_Limit (Expr), Sensitivity_List, False); + + when Iir_Kinds_Type_Attribute => + null; + when Iir_Kind_Event_Attribute + | Iir_Kind_Active_Attribute => + -- LRM 8.1 + -- An attribute name: [...]; otherwise, apply this rule to the + -- prefix of the attribute name. + Canon_Extract_Sensitivity + (Get_Prefix (Expr), Sensitivity_List, False); + + + when Iir_Kind_Last_Value_Attribute => + null; + + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Stable_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute => + -- LRM 8.1 + -- A simple name that denotes a signal, add the longuest static + -- prefix of the name to the sensitivity set; + -- + -- An attribute name: if the designator denotes a signal + -- attribute, add the longuest static prefix of the name of the + -- implicit signal denoted by the attribute name to the + -- sensitivity set; [...] + if not Is_Target then + Add_Element (Sensitivity_List, Expr); + end if; + + when Iir_Kind_Object_Alias_Declaration => + Canon_Extract_Sensitivity + (Get_Name (Expr), Sensitivity_List, Is_Target); + + when Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_File_Declaration => + null; + + when Iir_Kinds_Array_Attribute => + -- was Iir_Kind_Left_Array_Attribute + -- ditto Right, Low, High, Length + -- add Ascending, Range and Reverse_Range... + null; + --Canon_Extract_Sensitivity + -- (Get_Prefix (Expr), Sensitivity_List, Is_Target); + + when Iir_Kind_Value_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kinds_Scalar_Type_Attribute => + Canon_Extract_Sensitivity + (Get_Parameter (Expr), Sensitivity_List, Is_Target); + + when Iir_Kind_Aggregate => + declare + Aggr_Type : Iir; + begin + Aggr_Type := Get_Base_Type (Get_Type (Expr)); + case Get_Kind (Aggr_Type) is + when Iir_Kind_Array_Type_Definition => + Canon_Extract_Sensitivity_Aggregate + (Expr, Sensitivity_List, Is_Target, Aggr_Type, 1); + when Iir_Kind_Record_Type_Definition => + El := Get_Association_Choices_Chain (Expr); + while El /= Null_Iir loop + Canon_Extract_Sensitivity + (Get_Associated_Expr (El), Sensitivity_List, + Is_Target); + El := Get_Chain (El); + end loop; + when others => + Error_Kind ("canon_extract_sensitivity(aggr)", Aggr_Type); + end case; + end; + + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Canon_Extract_Sensitivity + (Get_Named_Entity (Expr), Sensitivity_List, Is_Target); + + when others => + Error_Kind ("canon_extract_sensitivity", Expr); + end case; + end Canon_Extract_Sensitivity; + + procedure Canon_Extract_Sensitivity_If_Not_Null + (Expr: Iir; Sensitivity_List: Iir_List; Is_Target: Boolean := False) is + begin + if Expr /= Null_Iir then + Canon_Extract_Sensitivity (Expr, Sensitivity_List, Is_Target); + end if; + end Canon_Extract_Sensitivity_If_Not_Null; + + procedure Canon_Extract_Sequential_Statement_Chain_Sensitivity + (Chain : Iir; List : Iir_List) + is + Stmt : Iir; + begin + Stmt := Chain; + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Assertion_Statement => + -- LRM08 11.3 + -- * For each assertion, report, next, exit or return + -- statement, apply the rule of 10.2 to each expression + -- in the statement, and construct the union of the + -- resulting sets. + Canon_Extract_Sensitivity + (Get_Assertion_Condition (Stmt), List); + Canon_Extract_Sensitivity + (Get_Severity_Expression (Stmt), List); + Canon_Extract_Sensitivity + (Get_Report_Expression (Stmt), List); + when Iir_Kind_Report_Statement => + -- LRM08 11.3 + -- See assertion_statement case. + Canon_Extract_Sensitivity + (Get_Severity_Expression (Stmt), List); + Canon_Extract_Sensitivity + (Get_Report_Expression (Stmt), List); + when Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement => + -- LRM08 11.3 + -- See assertion_statement case. + Canon_Extract_Sensitivity + (Get_Condition (Stmt), List); + when Iir_Kind_Return_Statement => + -- LRM08 11.3 + -- See assertion_statement case. + Canon_Extract_Sensitivity_If_Not_Null + (Get_Expression (Stmt), List); + when Iir_Kind_Variable_Assignment_Statement => + -- LRM08 11.3 + -- * For each assignment statement, apply the rule of 10.2 to + -- each expression occuring in the assignment, including any + -- expressions occuring in the index names or slice names in + -- the target, and construct the union of the resulting sets. + Canon_Extract_Sensitivity (Get_Target (Stmt), List, True); + Canon_Extract_Sensitivity (Get_Expression (Stmt), List, False); + when Iir_Kind_Signal_Assignment_Statement => + -- LRM08 11.3 + -- See variable assignment statement case. + Canon_Extract_Sensitivity (Get_Target (Stmt), List, True); + Canon_Extract_Sensitivity_If_Not_Null + (Get_Reject_Time_Expression (Stmt), List); + declare + We: Iir_Waveform_Element; + begin + We := Get_Waveform_Chain (Stmt); + while We /= Null_Iir loop + Canon_Extract_Sensitivity (Get_We_Value (We), List); + We := Get_Chain (We); + end loop; + end; + when Iir_Kind_If_Statement => + -- LRM08 11.3 + -- * For each if statement, apply the rule of 10.2 to the + -- condition and apply this rule recursively to each + -- sequence of statements within the if statement, and + -- construct the union of the resuling sets. + declare + El1 : Iir := Stmt; + Cond : Iir; + begin + loop + Cond := Get_Condition (El1); + if Cond /= Null_Iir then + Canon_Extract_Sensitivity (Cond, List); + end if; + Canon_Extract_Sequential_Statement_Chain_Sensitivity + (Get_Sequential_Statement_Chain (El1), List); + El1 := Get_Else_Clause (El1); + exit when El1 = Null_Iir; + end loop; + end; + when Iir_Kind_Case_Statement => + -- LRM08 11.3 + -- * For each case statement, apply the rule of 10.2 to the + -- expression and apply this rule recursively to each + -- sequence of statements within the case statement, and + -- construct the union of the resulting sets. + Canon_Extract_Sensitivity (Get_Expression (Stmt), List); + declare + Choice: Iir; + begin + Choice := Get_Case_Statement_Alternative_Chain (Stmt); + while Choice /= Null_Iir loop + Canon_Extract_Sequential_Statement_Chain_Sensitivity + (Get_Associated_Chain (Choice), List); + Choice := Get_Chain (Choice); + end loop; + end; + when Iir_Kind_While_Loop_Statement => + -- LRM08 11.3 + -- * For each loop statement, apply the rule of 10.2 to each + -- expression in the iteration scheme, if present, and apply + -- this rule recursively to the sequence of statements within + -- the loop statement, and construct the union of the + -- resulting sets. + Canon_Extract_Sensitivity_If_Not_Null + (Get_Condition (Stmt), List); + Canon_Extract_Sequential_Statement_Chain_Sensitivity + (Get_Sequential_Statement_Chain (Stmt), List); + when Iir_Kind_For_Loop_Statement => + -- LRM08 11.3 + -- See loop statement case. + declare + It : constant Iir := Get_Parameter_Specification (Stmt); + It_Type : constant Iir := Get_Type (It); + Rng : constant Iir := Get_Range_Constraint (It_Type); + begin + if Get_Kind (Rng) = Iir_Kind_Range_Expression then + Canon_Extract_Sensitivity (Rng, List); + end if; + end; + Canon_Extract_Sequential_Statement_Chain_Sensitivity + (Get_Sequential_Statement_Chain (Stmt), List); + when Iir_Kind_Null_Statement => + -- LRM08 11.3 + -- ? + null; + when Iir_Kind_Procedure_Call_Statement => + -- LRM08 11.3 + -- * For each procedure call statement, apply the rule of 10.2 + -- to each actual designator (other than OPEN) associated + -- with each formal parameter of mode IN or INOUT, and + -- construct the union of the resulting sets. + declare + Param : Iir; + begin + Param := Get_Parameter_Association_Chain + (Get_Procedure_Call (Stmt)); + while Param /= Null_Iir loop + if (Get_Kind (Param) + = Iir_Kind_Association_Element_By_Expression) + and then (Get_Mode (Get_Association_Interface (Param)) + /= Iir_Out_Mode) + then + Canon_Extract_Sensitivity (Get_Actual (Param), List); + end if; + Param := Get_Chain (Param); + end loop; + end; + when others => + Error_Kind + ("canon_extract_sequential_statement_chain_sensitivity", + Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Canon_Extract_Sequential_Statement_Chain_Sensitivity; + + procedure Canon_Extract_Sensitivity_From_Callees + (Callees_List : Iir_List; Sensitivity_List : Iir_List) + is + Callee : Iir; + Bod : Iir; + begin + -- LRM08 11.3 + -- Moreover, for each subprogram for which the process is a parent + -- (see 4.3), the sensitivity list includes members of the set + -- constructed by apply the preceding rule to the statements of the + -- subprogram, but excluding the members that denote formal signal + -- parameters or members of formal signal parameters of the subprogram + -- or any of its parents. + if Callees_List = Null_Iir_List then + return; + end if; + for I in Natural loop + Callee := Get_Nth_Element (Callees_List, I); + exit when Callee = Null_Iir; + if not Get_Seen_Flag (Callee) then + Set_Seen_Flag (Callee, True); + case Get_All_Sensitized_State (Callee) is + when Read_Signal => + Bod := Get_Subprogram_Body (Callee); + + -- Extract sensitivity from signals read in the body. + -- FIXME: what about signals read during in declarations ? + Canon_Extract_Sequential_Statement_Chain_Sensitivity + (Get_Sequential_Statement_Chain (Bod), Sensitivity_List); + + -- Extract sensitivity from subprograms called. + Canon_Extract_Sensitivity_From_Callees + (Get_Callees_List (Bod), Sensitivity_List); + + when No_Signal => + null; + + when Unknown | Invalid_Signal => + raise Internal_Error; + end case; + end if; + end loop; + end Canon_Extract_Sensitivity_From_Callees; + + function Canon_Extract_Process_Sensitivity + (Proc : Iir_Sensitized_Process_Statement) + return Iir_List + is + Res : Iir_List; + begin + Res := Create_Iir_List; + + -- Signals read by statements. + -- FIXME: justify why signals read in declarations don't care. + Canon_Extract_Sequential_Statement_Chain_Sensitivity + (Get_Sequential_Statement_Chain (Proc), Res); + + -- Signals read indirectly by subprograms called. + Canon_Extract_Sensitivity_From_Callees (Get_Callees_List (Proc), Res); + + Set_Seen_Flag (Proc, True); + Clear_Seen_Flag (Proc); + return Res; + end Canon_Extract_Process_Sensitivity; + +-- function Make_Aggregate (Array_Type : Iir_Array_Type_Definition; El : Iir) +-- return Iir_Aggregate +-- is +-- Res : Iir_Aggregate; +-- Choice : Iir; +-- begin +-- Res := Create_Iir (Iir_Kind_Aggregate); +-- Location_Copy (Res, El); +-- Choice := Create_Iir (Iir_Kind_Association_Choice_By_None); +-- Set_Associated (Choice, El); +-- Append_Element (Get_Association_Choices_List (Res), Choice); + +-- -- will call sem_aggregate +-- return Sem_Expr.Sem_Expression (Res, Array_Type); +-- end Make_Aggregate; + +-- procedure Canon_Concatenation_Operator (Expr : Iir) +-- is +-- Array_Type : Iir_Array_Type_Definition; +-- El_Type : Iir; +-- Left, Right : Iir; +-- Func_List : Iir_Implicit_Functions_List; +-- Func : Iir_Implicit_Function_Declaration; +-- begin +-- Array_Type := Get_Type (Expr); +-- El_Type := Get_Base_Type (Get_Element_Subtype (Array_Type)); +-- Left := Get_Left (Expr); +-- if Get_Type (Left) = El_Type then +-- Set_Left (Expr, Make_Aggregate (Array_Type, Left)); +-- end if; +-- Right := Get_Right (Expr); +-- if Get_Type (Right) = El_Type then +-- Set_Right (Expr, Make_Aggregate (Array_Type, Right)); +-- end if; + +-- -- FIXME: must convert the implementation. +-- -- Use implicit declaration list from the array_type ? +-- Func_List := Get_Implicit_Functions_List +-- (Get_Type_Declarator (Array_Type)); +-- for I in Natural loop +-- Func := Get_Nth_Element (Func_List, I); +-- if Get_Implicit_Definition (Func) +-- = Iir_Predefined_Array_Array_Concat +-- then +-- Set_Implementation (Expr, Func); +-- exit; +-- end if; +-- end loop; +-- end Canon_Concatenation_Operator; + + procedure Canon_Aggregate_Expression (Expr: Iir) + is + Assoc : Iir; + begin + Assoc := Get_Association_Choices_Chain (Expr); + while Assoc /= Null_Iir loop + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_Others + | Iir_Kind_Choice_By_None + | Iir_Kind_Choice_By_Name => + null; + when Iir_Kind_Choice_By_Expression => + Canon_Expression (Get_Choice_Expression (Assoc)); + when Iir_Kind_Choice_By_Range => + declare + Choice : constant Iir := Get_Choice_Range (Assoc); + begin + if Get_Kind (Choice) = Iir_Kind_Range_Expression then + Canon_Expression (Choice); + end if; + end; + when others => + Error_Kind ("canon_aggregate_expression", Assoc); + end case; + Canon_Expression (Get_Associated_Expr (Assoc)); + Assoc := Get_Chain (Assoc); + end loop; + end Canon_Aggregate_Expression; + + -- canon on expressions, mainly for function calls. + procedure Canon_Expression (Expr: Iir) + is + El : Iir; + List: Iir_List; + begin + if Expr = Null_Iir then + return; + end if; + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + Canon_Expression (Get_Left_Limit (Expr)); + Canon_Expression (Get_Right_Limit (Expr)); + + when Iir_Kind_Slice_Name => + declare + Suffix : Iir; + begin + Suffix := Get_Suffix (Expr); + if Get_Kind (Suffix) not in Iir_Kinds_Discrete_Type_Definition + then + Canon_Expression (Suffix); + end if; + Canon_Expression (Get_Prefix (Expr)); + end; + + when Iir_Kind_Indexed_Name => + Canon_Expression (Get_Prefix (Expr)); + List := Get_Index_List (Expr); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Canon_Expression (El); + end loop; + + when Iir_Kind_Selected_Element => + Canon_Expression (Get_Prefix (Expr)); + when Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference => + Canon_Expression (Get_Prefix (Expr)); + + when Iir_Kinds_Denoting_Name => + Canon_Expression (Get_Named_Entity (Expr)); + + when Iir_Kinds_Monadic_Operator => + Canon_Expression (Get_Operand (Expr)); + when Iir_Kinds_Dyadic_Operator => + Canon_Expression (Get_Left (Expr)); + Canon_Expression (Get_Right (Expr)); + if Get_Kind (Expr) = Iir_Kind_Concatenation_Operator + and then Canon_Concatenation + and then Get_Kind (Get_Implementation (Expr)) = + Iir_Kind_Implicit_Function_Declaration + then + --Canon_Concatenation_Operator (Expr); + raise Internal_Error; + end if; + + when Iir_Kind_Function_Call => + Canon_Subprogram_Call_And_Actuals (Expr); + -- FIXME: + -- should canon concatenation. + + when Iir_Kind_Parenthesis_Expression => + Canon_Expression (Get_Expression (Expr)); + when Iir_Kind_Type_Conversion + | Iir_Kind_Qualified_Expression => + Canon_Expression (Get_Expression (Expr)); + when Iir_Kind_Aggregate => + Canon_Aggregate_Expression (Expr); + when Iir_Kind_Allocator_By_Expression => + Canon_Expression (Get_Expression (Expr)); + when Iir_Kind_Allocator_By_Subtype => + declare + Ind : constant Iir := Get_Subtype_Indication (Expr); + begin + if Get_Kind (Ind) = Iir_Kind_Array_Subtype_Definition then + Canon_Subtype_Indication (Ind); + end if; + end; + + when Iir_Kinds_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Unit_Declaration => + null; + + when Iir_Kinds_Array_Attribute => + -- No need to canon parameter, since it is a locally static + -- expression. + declare + Prefix : constant Iir := Get_Prefix (Expr); + begin + if Get_Kind (Prefix) in Iir_Kinds_Denoting_Name + and then (Get_Kind (Get_Named_Entity (Prefix)) + in Iir_Kinds_Type_Declaration) + then + -- No canon for types. + null; + else + Canon_Expression (Prefix); + end if; + end; + + when Iir_Kinds_Type_Attribute => + null; + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute => + -- FIXME: add the default parameter ? + Canon_Expression (Get_Prefix (Expr)); + when Iir_Kind_Event_Attribute + | Iir_Kind_Last_Value_Attribute + | Iir_Kind_Active_Attribute + | Iir_Kind_Last_Event_Attribute + | Iir_Kind_Last_Active_Attribute + | Iir_Kind_Driving_Attribute + | Iir_Kind_Driving_Value_Attribute => + Canon_Expression (Get_Prefix (Expr)); + + when Iir_Kinds_Scalar_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute => + Canon_Expression (Get_Parameter (Expr)); + + when Iir_Kind_Simple_Name_Attribute + | Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + null; + + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Object_Alias_Declaration => + null; + + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Overflow_Literal => + null; + + when Iir_Kind_Element_Declaration => + null; + + when Iir_Kind_Attribute_Value + | Iir_Kind_Attribute_Name => + null; + + when others => + Error_Kind ("canon_expression", Expr); + null; + end case; + end Canon_Expression; + + procedure Canon_Discrete_Range (Rng : Iir) is + begin + case Get_Kind (Rng) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Canon_Expression (Get_Range_Constraint (Rng)); + when Iir_Kind_Enumeration_Type_Definition => + null; + when others => + Error_Kind ("canon_discrete_range", Rng); + end case; + end Canon_Discrete_Range; + + procedure Canon_Waveform_Chain + (Chain : Iir_Waveform_Element; Sensitivity_List: Iir_List) + is + We: Iir_Waveform_Element; + begin + We := Chain; + while We /= Null_Iir loop + if Sensitivity_List /= Null_Iir_List then + Canon_Extract_Sensitivity + (Get_We_Value (We), Sensitivity_List, False); + end if; + if Canon_Flag_Expressions then + Canon_Expression (Get_We_Value (We)); + if Get_Time (We) /= Null_Iir then + Canon_Expression (Get_Time (We)); + end if; + end if; + We := Get_Chain (We); + end loop; + end Canon_Waveform_Chain; + + -- Names associations by position, + -- reorder associations by name, + -- create omitted association, + function Canon_Association_Chain + (Interface_Chain : Iir; Association_Chain : Iir; Loc : Iir) + return Iir + is + -- The canon list of association. + N_Chain, Last : Iir; + Inter : Iir; + Assoc_El, Prev_Assoc_El, Next_Assoc_El : Iir; + Assoc_Chain : Iir; + + Found : Boolean; + begin + -- No argument, so return now. + if Interface_Chain = Null_Iir then + pragma Assert (Association_Chain = Null_Iir); + return Null_Iir; + end if; + + Sub_Chain_Init (N_Chain, Last); + Assoc_Chain := Association_Chain; + + -- Reorder the list of association in the interface order. + -- Add missing associations. + Inter := Interface_Chain; + while Inter /= Null_Iir loop + -- Search associations with INTERFACE. + Found := False; + Assoc_El := Assoc_Chain; + Prev_Assoc_El := Null_Iir; + while Assoc_El /= Null_Iir loop + Next_Assoc_El := Get_Chain (Assoc_El); + if Get_Formal (Assoc_El) = Null_Iir then + Set_Formal (Assoc_El, Inter); + end if; + if Get_Association_Interface (Assoc_El) = Inter then + + -- Remove ASSOC_EL from ASSOC_CHAIN + if Prev_Assoc_El /= Null_Iir then + Set_Chain (Prev_Assoc_El, Next_Assoc_El); + else + Assoc_Chain := Next_Assoc_El; + end if; + + -- Append ASSOC_EL in N_CHAIN. + Set_Chain (Assoc_El, Null_Iir); + Sub_Chain_Append (N_Chain, Last, Assoc_El); + + case Get_Kind (Assoc_El) is + when Iir_Kind_Association_Element_Open => + goto Done; + when Iir_Kind_Association_Element_By_Expression => + if Get_Whole_Association_Flag (Assoc_El) then + goto Done; + end if; + when Iir_Kind_Association_Element_By_Individual => + Found := True; + when Iir_Kind_Association_Element_Package => + goto Done; + when others => + Error_Kind ("canon_association_chain", Assoc_El); + end case; + elsif Found then + -- No more associations. + goto Done; + else + Prev_Assoc_El := Assoc_El; + end if; + Assoc_El := Next_Assoc_El; + end loop; + if Found then + goto Done; + end if; + + -- No association, use default expr. + Assoc_El := Create_Iir (Iir_Kind_Association_Element_Open); + Set_Artificial_Flag (Assoc_El, True); + Set_Whole_Association_Flag (Assoc_El, True); + Location_Copy (Assoc_El, Loc); + Set_Formal (Assoc_El, Inter); + Sub_Chain_Append (N_Chain, Last, Assoc_El); + + << Done >> null; + Inter := Get_Chain (Inter); + end loop; + pragma Assert (Assoc_Chain = Null_Iir); + + return N_Chain; + end Canon_Association_Chain; + + procedure Canon_Association_Chain_Actuals (Association_Chain : Iir) + is + Assoc_El : Iir; + begin + -- Canon actuals. + Assoc_El := Association_Chain; + while Assoc_El /= Null_Iir loop + if Get_Kind (Assoc_El) = Iir_Kind_Association_Element_By_Expression + then + Canon_Expression (Get_Actual (Assoc_El)); + end if; + Assoc_El := Get_Chain (Assoc_El); + end loop; + end Canon_Association_Chain_Actuals; + + function Canon_Association_Chain_And_Actuals + (Interface_Chain: Iir; Association_Chain: Iir; Loc : Iir) + return Iir + is + Res : Iir; + begin + Res := Canon_Association_Chain (Interface_Chain, Association_Chain, Loc); + if Canon_Flag_Expressions then + Canon_Association_Chain_Actuals (Res); + end if; + return Res; + end Canon_Association_Chain_And_Actuals; + + procedure Canon_Subprogram_Call (Call : Iir) + is + Imp : constant Iir := Get_Implementation (Call); + Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp); + Assoc_Chain : Iir; + begin + Assoc_Chain := Get_Parameter_Association_Chain (Call); + Assoc_Chain := Canon_Association_Chain (Inter_Chain, Assoc_Chain, Call); + Set_Parameter_Association_Chain (Call, Assoc_Chain); + end Canon_Subprogram_Call; + + procedure Canon_Subprogram_Call_And_Actuals (Call : Iir) is + begin + Canon_Subprogram_Call (Call); + if Canon_Flag_Expressions then + Canon_Association_Chain_Actuals + (Get_Parameter_Association_Chain (Call)); + end if; + end Canon_Subprogram_Call_And_Actuals; + + -- Create a default association list for INTERFACE_LIST. + -- The default is a list of interfaces associated with open. + function Canon_Default_Association_Chain (Interface_Chain : Iir) + return Iir + is + Res : Iir; + Last : Iir; + Assoc, El : Iir; + begin + El := Interface_Chain; + Sub_Chain_Init (Res, Last); + while El /= Null_Iir loop + Assoc := Create_Iir (Iir_Kind_Association_Element_Open); + Set_Whole_Association_Flag (Assoc, True); + Set_Artificial_Flag (Assoc, True); + Set_Formal (Assoc, El); + Location_Copy (Assoc, El); + Sub_Chain_Append (Res, Last, Assoc); + El := Get_Chain (El); + end loop; + return Res; + end Canon_Default_Association_Chain; + +-- function Canon_Default_Map_Association_List +-- (Formal_List, Actual_List : Iir_List; Loc : Location_Type) +-- return Iir_Association_List +-- is +-- Res : Iir_Association_List; +-- Formal, Actual : Iir; +-- Assoc : Iir; +-- Nbr_Assoc : Natural; +-- begin +-- -- formal is the entity port/generic. +-- if Formal_List = Null_Iir_List then +-- if Actual_List /= Null_Iir_List then +-- raise Internal_Error; +-- end if; +-- return Null_Iir_List; +-- end if; + +-- Res := Create_Iir (Iir_Kind_Association_List); +-- Set_Location (Res, Loc); +-- Nbr_Assoc := 0; +-- for I in Natural loop +-- Formal := Get_Nth_Element (Formal_List, I); +-- exit when Formal = Null_Iir; +-- Actual := Find_Name_In_List (Actual_List, Get_Identifier (Formal)); +-- if Actual /= Null_Iir then +-- Assoc := Create_Iir (Iir_Kind_Association_Element_By_Expression); +-- Set_Whole_Association_Flag (Assoc, True); +-- Set_Actual (Assoc, Actual); +-- Nbr_Assoc := Nbr_Assoc + 1; +-- else +-- Assoc := Create_Iir (Iir_Kind_Association_Element_Open); +-- end if; +-- Set_Location (Assoc, Loc); +-- Set_Formal (Assoc, Formal); +-- Set_Associated_Formal (Assoc, Formal); +-- Append_Element (Res, Assoc); +-- end loop; +-- if Nbr_Assoc /= Get_Nbr_Elements (Actual_List) then +-- -- There is non-associated actuals. +-- raise Internal_Error; +-- end if; +-- return Res; +-- end Canon_Default_Map_Association_List; + + -- Inner loop if any; used to canonicalize exit/next statement. + Cur_Loop : Iir; + + procedure Canon_Sequential_Stmts (First : Iir) + is + Stmt: Iir; + Expr: Iir; + Prev_Loop : Iir; + begin + Stmt := First; + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_If_Statement => + declare + Cond: Iir; + Clause: Iir := Stmt; + begin + while Clause /= Null_Iir loop + Cond := Get_Condition (Clause); + if Cond /= Null_Iir then + Canon_Expression (Cond); + end if; + Canon_Sequential_Stmts + (Get_Sequential_Statement_Chain (Clause)); + Clause := Get_Else_Clause (Clause); + end loop; + end; + + when Iir_Kind_Signal_Assignment_Statement => + Canon_Expression (Get_Target (Stmt)); + Canon_Waveform_Chain (Get_Waveform_Chain (Stmt), Null_Iir_List); + + when Iir_Kind_Variable_Assignment_Statement => + Canon_Expression (Get_Target (Stmt)); + Canon_Expression (Get_Expression (Stmt)); + + when Iir_Kind_Wait_Statement => + declare + Expr: Iir; + List: Iir_List; + begin + Expr := Get_Timeout_Clause (Stmt); + if Expr /= Null_Iir then + Canon_Expression (Expr); + end if; + Expr := Get_Condition_Clause (Stmt); + if Expr /= Null_Iir then + Canon_Expression (Expr); + end if; + List := Get_Sensitivity_List (Stmt); + if List = Null_Iir_List and then Expr /= Null_Iir then + List := Create_Iir_List; + Canon_Extract_Sensitivity (Expr, List, False); + Set_Sensitivity_List (Stmt, List); + end if; + end; + + when Iir_Kind_Case_Statement => + Canon_Expression (Get_Expression (Stmt)); + declare + Choice: Iir; + begin + Choice := Get_Case_Statement_Alternative_Chain (Stmt); + while Choice /= Null_Iir loop + -- FIXME: canon choice expr. + Canon_Sequential_Stmts (Get_Associated_Chain (Choice)); + Choice := Get_Chain (Choice); + end loop; + end; + + when Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement => + if Get_Kind (Stmt) = Iir_Kind_Assertion_Statement then + Canon_Expression (Get_Assertion_Condition (Stmt)); + end if; + Expr := Get_Report_Expression (Stmt); + if Expr /= Null_Iir then + Canon_Expression (Expr); + end if; + Expr := Get_Severity_Expression (Stmt); + if Expr /= Null_Iir then + Canon_Expression (Expr); + end if; + + when Iir_Kind_For_Loop_Statement => + -- FIXME: decl. + Prev_Loop := Cur_Loop; + Cur_Loop := Stmt; + if Canon_Flag_Expressions then + Canon_Discrete_Range + (Get_Type (Get_Parameter_Specification (Stmt))); + end if; + Canon_Sequential_Stmts (Get_Sequential_Statement_Chain (Stmt)); + Cur_Loop := Prev_Loop; + + when Iir_Kind_While_Loop_Statement => + Expr := Get_Condition (Stmt); + if Expr /= Null_Iir then + Canon_Expression (Expr); + end if; + Prev_Loop := Cur_Loop; + Cur_Loop := Stmt; + Canon_Sequential_Stmts (Get_Sequential_Statement_Chain (Stmt)); + Cur_Loop := Prev_Loop; + + when Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement => + declare + Loop_Label : Iir; + begin + Expr := Get_Condition (Stmt); + if Expr /= Null_Iir then + Canon_Expression (Expr); + end if; + Loop_Label := Get_Loop_Label (Stmt); + if Loop_Label = Null_Iir then + Set_Loop_Label (Stmt, Build_Simple_Name (Cur_Loop, Stmt)); + end if; + end; + + when Iir_Kind_Procedure_Call_Statement => + Canon_Subprogram_Call_And_Actuals (Get_Procedure_Call (Stmt)); + + when Iir_Kind_Null_Statement => + null; + + when Iir_Kind_Return_Statement => + Canon_Expression (Get_Expression (Stmt)); + + when others => + Error_Kind ("canon_sequential_stmts", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Canon_Sequential_Stmts; + + -- Create a statement transform from concurrent_signal_assignment + -- statement STMT (either selected or conditional). + -- waveform transformation is not done. + -- PROC is the process created. + -- PARENT is the place where signal assignment must be placed. This may + -- be PROC, or an 'if' statement if the assignment is guarded. + -- See LRM93 9.5 + procedure Canon_Concurrent_Signal_Assignment + (Stmt: Iir; + Proc: out Iir_Sensitized_Process_Statement; + Chain : out Iir) + is + If_Stmt: Iir; + Sensitivity_List : Iir_List; + begin + Proc := Create_Iir (Iir_Kind_Sensitized_Process_Statement); + Location_Copy (Proc, Stmt); + Set_Parent (Proc, Get_Parent (Stmt)); + Sensitivity_List := Create_Iir_List; + Set_Sensitivity_List (Proc, Sensitivity_List); + Set_Process_Origin (Proc, Stmt); + + -- LRM93 9.5 + -- 1. If a label appears on the concurrent signal assignment, then the + -- same label appears on the process statement. + Set_Label (Proc, Get_Label (Stmt)); + + -- LRM93 9.5 + -- 2. The equivalent process statement is a postponed process if and + -- only if the current signal assignment statement includes the + -- reserved word POSTPONED. + Set_Postponed_Flag (Proc, Get_Postponed_Flag (Proc)); + + Canon_Extract_Sensitivity (Get_Target (Stmt), Sensitivity_List, True); + + if Canon_Flag_Expressions then + Canon_Expression (Get_Target (Stmt)); + end if; + + if Get_Guard (Stmt) /= Null_Iir then + -- LRM93 9.1 + -- If the option guarded appears in the concurrent signal assignment + -- statement, then the concurrent signal assignment is called a + -- guarded assignment. + -- If the concurrent signal assignement statement is a guarded + -- assignment and the target of the concurrent signal assignment is + -- a guarded target, then the statement transform is as follow: + -- if GUARD then signal_transform else disconnect_statements end if; + -- Otherwise, if the concurrent signal assignment statement is a + -- guarded assignement, but the target if the concurrent signal + -- assignment is not a guarded target, the then statement transform + -- is as follows: + -- if GUARD then signal_transform end if; + If_Stmt := Create_Iir (Iir_Kind_If_Statement); + Set_Parent (If_Stmt, Proc); + Set_Sequential_Statement_Chain (Proc, If_Stmt); + Location_Copy (If_Stmt, Stmt); + Canon_Extract_Sensitivity (Get_Guard (Stmt), Sensitivity_List, False); + Set_Condition (If_Stmt, Get_Guard (Stmt)); + Chain := If_Stmt; + + declare + Target : Iir; + Else_Clause : Iir_Elsif; + Dis_Stmt : Iir_Signal_Assignment_Statement; + begin + Target := Get_Target (Stmt); + if Get_Guarded_Target_State (Stmt) = True then + -- The target is a guarded target. + -- create the disconnection statement. + Else_Clause := Create_Iir (Iir_Kind_Elsif); + Location_Copy (Else_Clause, Stmt); + Set_Else_Clause (If_Stmt, Else_Clause); + Dis_Stmt := Create_Iir (Iir_Kind_Signal_Assignment_Statement); + Location_Copy (Dis_Stmt, Stmt); + Set_Parent (Dis_Stmt, If_Stmt); + Set_Target (Dis_Stmt, Target); + Set_Sequential_Statement_Chain (Else_Clause, Dis_Stmt); + -- XX + Set_Waveform_Chain (Dis_Stmt, Null_Iir); + end if; + end; + else + -- LRM93 9.1 + -- Finally, if the concurrent signal assignment statement is not a + -- guarded assignment, and the traget of the concurrent signal + -- assignment is not a guarded target, then the statement transform + -- is as follows: + -- signal_transform + Chain := Proc; + end if; + end Canon_Concurrent_Signal_Assignment; + + function Canon_Concurrent_Procedure_Call (El : Iir) + return Iir_Sensitized_Process_Statement + is + Proc : Iir_Sensitized_Process_Statement; + Call_Stmt : Iir_Procedure_Call_Statement; + Wait_Stmt : Iir_Wait_Statement; + Call : constant Iir_Procedure_Call := Get_Procedure_Call (El); + Imp : constant Iir := Get_Implementation (Call); + Assoc_Chain : Iir; + Assoc : Iir; + Inter : Iir; + Sensitivity_List : Iir_List; + Is_Sensitized : Boolean; + begin + -- Optimization: the process is a sensitized process only if the + -- procedure is known not to have wait statement. + Is_Sensitized := Get_Wait_State (Imp) = False; + + -- LRM93 9.3 + -- The equivalent process statement has also no sensitivity list, an + -- empty declarative part, and a statement part that consists of a + -- procedure call statement followed by a wait statement. + if Is_Sensitized then + Proc := Create_Iir (Iir_Kind_Sensitized_Process_Statement); + else + Proc := Create_Iir (Iir_Kind_Process_Statement); + end if; + Location_Copy (Proc, El); + Set_Parent (Proc, Get_Parent (El)); + Set_Process_Origin (Proc, El); + + -- LRM93 9.3 + -- The equivalent process statement has a label if and only if the + -- concurrent procedure call statement has a label; if the equivalent + -- process statement has a label, it is the same as that of the + -- concurrent procedure call statement. + Set_Label (Proc, Get_Label (El)); + + -- LRM93 9.3 + -- The equivalent process statement is a postponed process if and only + -- if the concurrent procedure call statement includes the reserved + -- word POSTPONED. + Set_Postponed_Flag (Proc, Get_Postponed_Flag (El)); + + Set_Attribute_Value_Chain (Proc, Get_Attribute_Value_Chain (El)); + + Call_Stmt := Create_Iir (Iir_Kind_Procedure_Call_Statement); + Set_Sequential_Statement_Chain (Proc, Call_Stmt); + Location_Copy (Call_Stmt, El); + Set_Parent (Call_Stmt, Proc); + Set_Procedure_Call (Call_Stmt, Call); + Assoc_Chain := Canon_Association_Chain_And_Actuals + (Get_Interface_Declaration_Chain (Imp), + Get_Parameter_Association_Chain (Call), + Call); + Set_Parameter_Association_Chain (Call, Assoc_Chain); + Assoc := Assoc_Chain; + + -- LRM93 9.3 + -- If there exists a name that denotes a signal in the actual part of + -- any association element in the concurrent procedure call statement, + -- and that actual is associated with a formal parameter of mode IN or + -- INOUT, then the equivalent process statement includes a final wait + -- statement with a sensitivity clause that is constructed by taking + -- the union of the sets constructed by applying th rule of Section 8.1 + -- to each actual part associated with a formal parameter. + Sensitivity_List := Create_Iir_List; + while Assoc /= Null_Iir loop + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + Inter := Get_Association_Interface (Assoc); + if Get_Mode (Inter) in Iir_In_Modes then + Canon_Extract_Sensitivity + (Get_Actual (Assoc), Sensitivity_List, False); + end if; + when Iir_Kind_Association_Element_Open + | Iir_Kind_Association_Element_By_Individual => + null; + when others => + raise Internal_Error; + end case; + Assoc := Get_Chain (Assoc); + end loop; + if Is_Sensitized then + Set_Sensitivity_List (Proc, Sensitivity_List); + else + Wait_Stmt := Create_Iir (Iir_Kind_Wait_Statement); + Location_Copy (Wait_Stmt, El); + Set_Parent (Wait_Stmt, Proc); + Set_Sensitivity_List (Wait_Stmt, Sensitivity_List); + Set_Chain (Call_Stmt, Wait_Stmt); + end if; + return Proc; + end Canon_Concurrent_Procedure_Call; + + -- Return a statement from a waveform. + function Canon_Wave_Transform + (Orig_Stmt : Iir; Waveform_Chain : Iir_Waveform_Element; Proc : Iir) + return Iir + is + Stmt : Iir; + begin + if Waveform_Chain = Null_Iir then + -- LRM 9.5.1 Conditionnal Signal Assignment + -- If the waveform is of the form: + -- UNAFFECTED + -- then the wave transform in the corresponding process statement + -- is of the form: + -- NULL; + -- In this example, the final NULL causes the driver to be unchanged, + -- rather than disconnected. + -- (This is the null statement not a null waveform element). + Stmt := Create_Iir (Iir_Kind_Null_Statement); + else + -- LRM 9.5.1 Conditionnal Signal Assignment + -- If the waveform is of the form: + -- waveform_element1, waveform_element1, ..., waveform_elementN + -- then the wave transform in the corresponding process statement is + -- of the form: + -- target <= [ delay_mechanism ] waveform_element1, + -- waveform_element2, ..., waveform_elementN; + Stmt := Create_Iir (Iir_Kind_Signal_Assignment_Statement); + Set_Target (Stmt, Get_Target (Orig_Stmt)); + Canon_Waveform_Chain (Waveform_Chain, Get_Sensitivity_List (Proc)); + Set_Waveform_Chain (Stmt, Waveform_Chain); + Set_Delay_Mechanism (Stmt, Get_Delay_Mechanism (Orig_Stmt)); + Set_Reject_Time_Expression + (Stmt, Get_Reject_Time_Expression (Orig_Stmt)); + end if; + Location_Copy (Stmt, Orig_Stmt); + return Stmt; + end Canon_Wave_Transform; + + -- Create signal_transform for a conditional concurrent signal assignment. + procedure Canon_Conditional_Concurrent_Signal_Assigment + (Conc_Stmt : Iir; Proc : Iir; Parent : Iir) + is + Expr : Iir; + Stmt : Iir; + Res1 : Iir; + Last_Res : Iir; + Wf : Iir; + Cond_Wf : Iir_Conditional_Waveform; + Cond_Wf_Chain : Iir_Conditional_Waveform; + begin + Cond_Wf_Chain := Get_Conditional_Waveform_Chain (Conc_Stmt); + Stmt := Null_Iir; + Cond_Wf := Cond_Wf_Chain; + Last_Res := Null_Iir; + + while Cond_Wf /= Null_Iir loop + Expr := Get_Condition (Cond_Wf); + Wf := Canon_Wave_Transform + (Conc_Stmt, Get_Waveform_Chain (Cond_Wf), Proc); + Set_Parent (Wf, Parent); + if Expr = Null_Iir and Cond_Wf = Cond_Wf_Chain then + Res1 := Wf; + else + if Expr /= Null_Iir then + if Canon_Flag_Expressions then + Canon_Expression (Expr); + end if; + Canon_Extract_Sensitivity + (Expr, Get_Sensitivity_List (Proc), False); + end if; + if Stmt = Null_Iir then + Res1 := Create_Iir (Iir_Kind_If_Statement); + Set_Parent (Res1, Parent); + else + Res1 := Create_Iir (Iir_Kind_Elsif); + end if; + Location_Copy (Res1, Cond_Wf); + Set_Condition (Res1, Expr); + Set_Sequential_Statement_Chain (Res1, Wf); + end if; + if Stmt = Null_Iir then + Stmt := Res1; + else + Set_Else_Clause (Last_Res, Res1); + end if; + Last_Res := Res1; + Cond_Wf := Get_Chain (Cond_Wf); + end loop; + Set_Sequential_Statement_Chain (Parent, Stmt); + end Canon_Conditional_Concurrent_Signal_Assigment; + + procedure Canon_Selected_Concurrent_Signal_Assignment + (Conc_Stmt : Iir; Proc : Iir; Parent : Iir) + is + Selected_Waveform : Iir; + Case_Stmt: Iir_Case_Statement; + Expr : Iir; + Stmt : Iir; + Assoc : Iir; + begin + Case_Stmt := Create_Iir (Iir_Kind_Case_Statement); + Set_Parent (Case_Stmt, Parent); + Set_Sequential_Statement_Chain (Parent, Case_Stmt); + Location_Copy (Case_Stmt, Conc_Stmt); + Expr := Get_Expression (Conc_Stmt); + if Canon_Flag_Expressions then + Canon_Expression (Expr); + end if; + Set_Expression (Case_Stmt, Expr); + Canon_Extract_Sensitivity + (Expr, Get_Sensitivity_List (Proc), False); + + Selected_Waveform := Get_Selected_Waveform_Chain (Conc_Stmt); + Set_Case_Statement_Alternative_Chain (Case_Stmt, Selected_Waveform); + while Selected_Waveform /= Null_Iir loop + Assoc := Get_Associated_Chain (Selected_Waveform); + if Assoc /= Null_Iir then + Stmt := Canon_Wave_Transform (Conc_Stmt, Assoc, Proc); + Set_Parent (Stmt, Case_Stmt); + Set_Associated_Chain (Selected_Waveform, Stmt); + end if; + Selected_Waveform := Get_Chain (Selected_Waveform); + end loop; + end Canon_Selected_Concurrent_Signal_Assignment; + + procedure Canon_Concurrent_Stmts (Top : Iir_Design_Unit; Parent : Iir) + is + -- Current element in the chain of concurrent statements. + El: Iir; + -- Previous element or NULL_IIR if EL is the first element. + -- This is used to make Replace_Stmt efficient. + Prev_El : Iir; + + -- Replace in the chain EL by N_STMT. + procedure Replace_Stmt (N_Stmt : Iir) is + begin + if Prev_El = Null_Iir then + Set_Concurrent_Statement_Chain (Parent, N_Stmt); + else + Set_Chain (Prev_El, N_Stmt); + end if; + Set_Chain (N_Stmt, Get_Chain (El)); + end Replace_Stmt; + + Proc: Iir; + Stmt: Iir; + Sub_Chain : Iir; + Expr: Iir; + Proc_Num : Natural := 0; + Sensitivity_List : Iir_List; + begin + Prev_El := Null_Iir; + El := Get_Concurrent_Statement_Chain (Parent); + while El /= Null_Iir loop + -- Add a label if required. + if Canon_Flag_Add_Labels then + case Get_Kind (El) is + when Iir_Kind_Psl_Declaration => + null; + when others => + if Get_Label (El) = Null_Identifier then + declare + Str : String := Natural'Image (Proc_Num); + begin + -- Note: the label starts with a capitalized letter, + -- to avoid any clash with user's identifiers. + Str (1) := 'P'; + Set_Label (El, Name_Table.Get_Identifier (Str)); + end; + Proc_Num := Proc_Num + 1; + end if; + end case; + end if; + + case Get_Kind (El) is + when Iir_Kind_Concurrent_Conditional_Signal_Assignment => + Canon_Concurrent_Signal_Assignment (El, Proc, Sub_Chain); + + Canon_Conditional_Concurrent_Signal_Assigment + (El, Proc, Sub_Chain); + + Replace_Stmt (Proc); + Free_Iir (El); + El := Proc; + + when Iir_Kind_Concurrent_Selected_Signal_Assignment => + Canon_Concurrent_Signal_Assignment (El, Proc, Sub_Chain); + + Canon_Selected_Concurrent_Signal_Assignment + (El, Proc, Sub_Chain); + + Replace_Stmt (Proc); + Free_Iir (El); + El := Proc; + + when Iir_Kind_Concurrent_Assertion_Statement => + -- Create a new entry. + Proc := Create_Iir (Iir_Kind_Sensitized_Process_Statement); + Location_Copy (Proc, El); + Set_Parent (Proc, Get_Parent (El)); + Set_Process_Origin (Proc, El); + + -- LRM93 9.4 + -- The equivalent process statement has a label if and only if + -- the current assertion statement has a label; if the + -- equivalent process statement has a label; it is the same + -- as that of the concurrent assertion statement. + Set_Label (Proc, Get_Label (El)); + + -- LRM93 9.4 + -- The equivalent process statement is a postponed process if + -- and only if the current assertion statement includes the + -- reserved word POSTPONED. + Set_Postponed_Flag (Proc, Get_Postponed_Flag (El)); + + Stmt := Create_Iir (Iir_Kind_Assertion_Statement); + Set_Sequential_Statement_Chain (Proc, Stmt); + Set_Parent (Stmt, Proc); + Location_Copy (Stmt, El); + Sensitivity_List := Create_Iir_List; + Set_Sensitivity_List (Proc, Sensitivity_List); + + -- Expand the expression, fill the sensitivity list, + Canon_Extract_Sensitivity + (Get_Assertion_Condition (El), Sensitivity_List, False); + if Canon_Flag_Expressions then + Canon_Expression (Get_Assertion_Condition (El)); + end if; + Set_Assertion_Condition + (Stmt, Get_Assertion_Condition (El)); + + Expr := Get_Report_Expression (El); + if Canon_Flag_Expressions and Expr /= Null_Iir then + Canon_Expression (Expr); + end if; + Set_Report_Expression (Stmt, Expr); + + Expr := Get_Severity_Expression (El); + if Canon_Flag_Expressions and Expr /= Null_Iir then + Canon_Expression (Expr); + end if; + Set_Severity_Expression (Stmt, Expr); + + Replace_Stmt (Proc); + El := Proc; + + when Iir_Kind_Concurrent_Procedure_Call_Statement => + Proc := Canon_Concurrent_Procedure_Call (El); + Replace_Stmt (Proc); + El := Proc; + + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + Canon_Declarations (Top, El, Null_Iir); + if Canon_Flag_Sequentials_Stmts then + Canon_Sequential_Stmts (Get_Sequential_Statement_Chain (El)); + end if; + if Canon_Flag_All_Sensitivity + and then Canon_Flag_Sequentials_Stmts + and then Get_Kind (El) = Iir_Kind_Sensitized_Process_Statement + and then Get_Sensitivity_List (El) = Iir_List_All + then + Set_Sensitivity_List + (El, Canon_Extract_Process_Sensitivity (El)); + end if; + + when Iir_Kind_Component_Instantiation_Statement => + declare + Inst : Iir; + Assoc_Chain : Iir; + begin + Inst := Get_Instantiated_Unit (El); + Inst := Get_Entity_From_Entity_Aspect (Inst); + Assoc_Chain := Canon_Association_Chain_And_Actuals + (Get_Generic_Chain (Inst), + Get_Generic_Map_Aspect_Chain (El), + El); + Set_Generic_Map_Aspect_Chain (El, Assoc_Chain); + + Assoc_Chain := Canon_Association_Chain_And_Actuals + (Get_Port_Chain (Inst), + Get_Port_Map_Aspect_Chain (El), + El); + Set_Port_Map_Aspect_Chain (El, Assoc_Chain); + end; + + when Iir_Kind_Block_Statement => + declare + Header : Iir_Block_Header; + Chain : Iir; + Guard : Iir_Guard_Signal_Declaration; + begin + Guard := Get_Guard_Decl (El); + if Guard /= Null_Iir then + Expr := Get_Guard_Expression (Guard); + Set_Guard_Sensitivity_List (Guard, Create_Iir_List); + Canon_Extract_Sensitivity + (Expr, Get_Guard_Sensitivity_List (Guard), False); + if Canon_Flag_Expressions then + Canon_Expression (Expr); + end if; + end if; + Header := Get_Block_Header (El); + if Header /= Null_Iir then + -- Generics. + Chain := Get_Generic_Map_Aspect_Chain (Header); + if Chain /= Null_Iir then + Chain := Canon_Association_Chain_And_Actuals + (Get_Generic_Chain (Header), Chain, Chain); + else + Chain := Canon_Default_Association_Chain + (Get_Generic_Chain (Header)); + end if; + Set_Generic_Map_Aspect_Chain (Header, Chain); + + -- Ports. + Chain := Get_Port_Map_Aspect_Chain (Header); + if Chain /= Null_Iir then + Chain := Canon_Association_Chain_And_Actuals + (Get_Port_Chain (Header), Chain, Chain); + else + Chain := Canon_Default_Association_Chain + (Get_Port_Chain (Header)); + end if; + Set_Port_Map_Aspect_Chain (Header, Chain); + end if; + Canon_Declarations (Top, El, El); + Canon_Concurrent_Stmts (Top, El); + end; + + when Iir_Kind_Generate_Statement => + declare + Scheme : Iir; + begin + Scheme := Get_Generation_Scheme (El); + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Canon_Declaration (Top, Scheme, Null_Iir, Null_Iir); + elsif Canon_Flag_Expressions then + Canon_Expression (Scheme); + end if; + Canon_Declarations (Top, El, El); + Canon_Concurrent_Stmts (Top, El); + end; + + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + declare + use PSL.Nodes; + Prop : PSL_Node; + Fa : PSL_NFA; + begin + Prop := Get_Psl_Property (El); + Prop := PSL.Rewrites.Rewrite_Property (Prop); + Set_Psl_Property (El, Prop); + -- Generate the NFA. + Fa := PSL.Build.Build_FA (Prop); + Set_PSL_NFA (El, Fa); + + -- FIXME: report/severity. + end; + + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + declare + use PSL.Nodes; + Decl : PSL_Node; + Prop : PSL_Node; + Fa : PSL_NFA; + begin + Decl := Get_Psl_Declaration (El); + case Get_Kind (Decl) is + when N_Property_Declaration => + Prop := Get_Property (Decl); + Prop := PSL.Rewrites.Rewrite_Property (Prop); + Set_Property (Decl, Prop); + if Get_Parameter_List (Decl) = Null_Node then + -- Generate the NFA. + Fa := PSL.Build.Build_FA (Prop); + Set_PSL_NFA (El, Fa); + end if; + when N_Sequence_Declaration + | N_Endpoint_Declaration => + Prop := Get_Sequence (Decl); + Prop := PSL.Rewrites.Rewrite_SERE (Prop); + Set_Sequence (Decl, Prop); + when others => + Error_Kind ("canon psl_declaration", Decl); + end case; + end; + + when Iir_Kind_Simple_Simultaneous_Statement => + if Canon_Flag_Expressions then + Canon_Expression (Get_Simultaneous_Left (El)); + Canon_Expression (Get_Simultaneous_Right (El)); + end if; + + when others => + Error_Kind ("canon_concurrent_stmts", El); + end case; + Prev_El := El; + El := Get_Chain (El); + end loop; + end Canon_Concurrent_Stmts; + +-- procedure Canon_Binding_Indication +-- (Component: Iir; Binding : Iir_Binding_Indication) +-- is +-- List : Iir_Association_List; +-- begin +-- if Binding = Null_Iir then +-- return; +-- end if; +-- List := Get_Generic_Map_Aspect_List (Binding); +-- List := Canon_Association_List (Get_Generic_List (Component), List); +-- Set_Generic_Map_Aspect_List (Binding, List); +-- List := Get_Port_Map_Aspect_List (Binding); +-- List := Canon_Association_List (Get_Port_List (Component), List); +-- Set_Port_Map_Aspect_List (Binding, List); +-- end Canon_Binding_Indication; + + procedure Add_Binding_Indication_Dependence (Top : Iir_Design_Unit; + Binding : Iir) + is + Aspect : Iir; + begin + if Binding = Null_Iir then + return; + end if; + Aspect := Get_Entity_Aspect (Binding); + if Aspect = Null_Iir then + return; + end if; + case Get_Kind (Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + if Get_Architecture (Aspect) /= Null_Iir then + Add_Dependence (Top, Aspect); + else + Add_Dependence (Top, Get_Design_Unit (Get_Entity (Aspect))); + end if; + when Iir_Kind_Entity_Aspect_Configuration => + Add_Dependence (Top, Get_Design_Unit (Get_Configuration (Aspect))); + when Iir_Kind_Entity_Aspect_Open => + null; + when others => + Error_Kind ("add_binding_indication_dependence", Aspect); + end case; + end Add_Binding_Indication_Dependence; + + -- Canon the component_configuration or configuration_specification CFG. + procedure Canon_Component_Configuration (Top : Iir_Design_Unit; Cfg : Iir) + is + -- True iff CFG is a component_configuration. + -- False iff CFG is a configuration_specification. + Is_Config : constant Boolean := + Get_Kind (Cfg) = Iir_Kind_Component_Configuration; + + Bind : Iir; + Instances : Iir_List; + Entity_Aspect : Iir; + Block : Iir_Block_Configuration; + Map_Chain : Iir; + Entity : Iir; + begin + Bind := Get_Binding_Indication (Cfg); + if Bind = Null_Iir then + -- Add a default binding indication + -- Extract a component instantiation + Instances := Get_Instantiation_List (Cfg); + if Instances = Iir_List_All or Instances = Iir_List_Others then + -- designator_all and designator_others must have been replaced + -- by a list during canon. + raise Internal_Error; + else + Bind := Get_Default_Binding_Indication + (Get_Named_Entity (Get_First_Element (Instances))); + end if; + if Bind = Null_Iir then + -- Component is not bound. + return; + end if; + Set_Binding_Indication (Cfg, Bind); + Add_Binding_Indication_Dependence (Top, Bind); + return; + else + Entity_Aspect := Get_Entity_Aspect (Bind); + if Entity_Aspect = Null_Iir then + Entity_Aspect := Get_Default_Entity_Aspect (Bind); + Set_Entity_Aspect (Bind, Entity_Aspect); + end if; + if Entity_Aspect /= Null_Iir then + Add_Binding_Indication_Dependence (Top, Bind); + Entity := Get_Entity_From_Entity_Aspect (Entity_Aspect); + Map_Chain := Get_Generic_Map_Aspect_Chain (Bind); + if Map_Chain = Null_Iir then + if Is_Config then + Map_Chain := Get_Default_Generic_Map_Aspect_Chain (Bind); + end if; + else + Map_Chain := Canon_Association_Chain + (Get_Generic_Chain (Entity), Map_Chain, Map_Chain); + end if; + Set_Generic_Map_Aspect_Chain (Bind, Map_Chain); + + Map_Chain := Get_Port_Map_Aspect_Chain (Bind); + if Map_Chain = Null_Iir then + if Is_Config then + Map_Chain := Get_Default_Port_Map_Aspect_Chain (Bind); + end if; + else + Map_Chain := Canon_Association_Chain + (Get_Port_Chain (Entity), Map_Chain, Map_Chain); + end if; + Set_Port_Map_Aspect_Chain (Bind, Map_Chain); + + if Get_Kind (Cfg) = Iir_Kind_Component_Configuration then + Block := Get_Block_Configuration (Cfg); + if Block /= Null_Iir then + -- If there is no architecture_identifier in the binding, + -- set it from the block_configuration. + if Get_Kind (Entity_Aspect) = Iir_Kind_Entity_Aspect_Entity + and then Get_Architecture (Entity_Aspect) = Null_Iir + then + Entity := Get_Entity (Entity_Aspect); + if Get_Kind (Entity) /= Iir_Kind_Entity_Declaration then + raise Internal_Error; + end if; + Set_Architecture + (Entity_Aspect, Get_Block_Specification (Block)); + end if; + Canon_Block_Configuration (Top, Block); + end if; + end if; + end if; + end if; + end Canon_Component_Configuration; + + procedure Canon_Incremental_Binding + (Conf_Spec : Iir_Configuration_Specification; + Comp_Conf : Iir_Component_Configuration; + Parent : Iir) + is + function Merge_Association_Chain + (Inter_Chain : Iir; First_Chain : Iir; Sec_Chain : Iir) + return Iir + is + -- Result (chain). + First, Last : Iir; + + -- Copy an association and append new elements to FIRST/LAST. + procedure Copy_Association (Assoc : in out Iir; Inter : Iir) + is + El : Iir; + begin + loop + El := Create_Iir (Get_Kind (Assoc)); + Location_Copy (El, Assoc); + Set_Formal (El, Get_Formal (Assoc)); + Set_Whole_Association_Flag + (El, Get_Whole_Association_Flag (Assoc)); + + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_Open => + null; + when Iir_Kind_Association_Element_By_Expression => + Set_Actual (El, Get_Actual (Assoc)); + Set_In_Conversion (El, Get_In_Conversion (Assoc)); + Set_Out_Conversion (El, Get_Out_Conversion (Assoc)); + Set_Collapse_Signal_Flag + (Assoc, + Sem.Can_Collapse_Signals (Assoc, Get_Formal (Assoc))); + when Iir_Kind_Association_Element_By_Individual => + Set_Actual_Type (El, Get_Actual_Type (Assoc)); + Set_Individual_Association_Chain + (El, Get_Individual_Association_Chain (Assoc)); + when others => + Error_Kind ("copy_association", Assoc); + end case; + + Sub_Chain_Append (First, Last, El); + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + exit when Get_Association_Interface (Assoc) /= Inter; + end loop; + end Copy_Association; + + procedure Advance (Assoc : in out Iir; Inter : Iir) + is + begin + loop + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + exit when Get_Association_Interface (Assoc) /= Inter; + end loop; + end Advance; + + Inter : Iir; + F_El : Iir; + S_El : Iir; + begin + if Sec_Chain = Null_Iir then + -- Short-cut. + return First_Chain; + end if; + F_El := First_Chain; + Sub_Chain_Init (First, Last); + Inter := Inter_Chain; + while Inter /= Null_Iir loop + -- Consistency check. + pragma Assert (Get_Association_Interface (F_El) = Inter); + + -- Find the associated in the second chain. + S_El := Sec_Chain; + while S_El /= Null_Iir loop + exit when Get_Association_Interface (S_El) = Inter; + S_El := Get_Chain (S_El); + end loop; + if S_El /= Null_Iir + and then Get_Kind (S_El) /= Iir_Kind_Association_Element_Open + then + Copy_Association (S_El, Inter); + Advance (F_El, Inter); + else + Copy_Association (F_El, Inter); + end if; + Inter := Get_Chain (Inter); + end loop; + return First; + end Merge_Association_Chain; + + Res : Iir_Component_Configuration; + Cs_Binding : Iir_Binding_Indication; + Cc_Binding : Iir_Binding_Indication; + Cs_Chain : Iir; + Res_Binding : Iir_Binding_Indication; + Entity : Iir; + Instance_List : Iir_List; + Conf_Instance_List : Iir_List; + Instance : Iir; + Instance_Name : Iir; + N_Nbr : Natural; + begin + -- Create the new component configuration + Res := Create_Iir (Iir_Kind_Component_Configuration); + Location_Copy (Res, Comp_Conf); + Set_Parent (Res, Parent); + Set_Component_Name (Res, Get_Component_Name (Conf_Spec)); + +-- -- Keep in the designator list only the non-incrementally +-- -- bound instances. +-- Inst_List := Get_Instantiation_List (Comp_Conf); +-- Designator_List := Create_Iir_List; +-- for I in 0 .. Get_Nbr_Elements (Inst_List) - 1 loop +-- Inst := Get_Nth_Element (Inst_List, I); +-- if Get_Component_Configuration (Inst) = Comp_Conf then +-- Set_Component_Configuration (Inst, Res); +-- Append_Element (Designator_List, Inst); +-- end if; +-- end loop; +-- Set_Instantiation_List (Res, Designator_List); +-- Set_Binding_Indication +-- (Res, Get_Binding_Indication (Comp_Conf)); +-- Append (Last_Item, Conf, Comp_Conf); + + Cs_Binding := Get_Binding_Indication (Conf_Spec); + Cc_Binding := Get_Binding_Indication (Comp_Conf); + Res_Binding := Create_Iir (Iir_Kind_Binding_Indication); + Location_Copy (Res_Binding, Res); + Set_Binding_Indication (Res, Res_Binding); + + Entity := Get_Entity_From_Entity_Aspect (Get_Entity_Aspect (Cs_Binding)); + + -- Merge generic map aspect. + Cs_Chain := Get_Generic_Map_Aspect_Chain (Cs_Binding); + if Cs_Chain = Null_Iir then + Cs_Chain := Get_Default_Generic_Map_Aspect_Chain (Cs_Binding); + end if; + Set_Generic_Map_Aspect_Chain + (Res_Binding, + Merge_Association_Chain (Get_Generic_Chain (Entity), + Cs_Chain, + Get_Generic_Map_Aspect_Chain (Cc_Binding))); + + -- merge port map aspect + Cs_Chain := Get_Port_Map_Aspect_Chain (Cs_Binding); + if Cs_Chain = Null_Iir then + Cs_Chain := Get_Default_Port_Map_Aspect_Chain (Cs_Binding); + end if; + Set_Port_Map_Aspect_Chain + (Res_Binding, + Merge_Association_Chain (Get_Port_Chain (Entity), + Cs_Chain, + Get_Port_Map_Aspect_Chain (Cc_Binding))); + + -- set entity aspect + Set_Entity_Aspect (Res_Binding, Get_Entity_Aspect (Cs_Binding)); + + -- create list of instances: + -- * keep common instances + -- replace component_configuration of them + -- remove them in the instance list of COMP_CONF + Instance_List := Create_Iir_List; + Set_Instantiation_List (Res, Instance_List); + Conf_Instance_List := Get_Instantiation_List (Comp_Conf); + N_Nbr := 0; + for I in 0 .. Get_Nbr_Elements (Conf_Instance_List) - 1 loop + Instance_Name := Get_Nth_Element (Conf_Instance_List, I); + Instance := Get_Named_Entity (Instance_Name); + if Get_Component_Configuration (Instance) = Conf_Spec then + -- The incremental binding applies to this instance. + Set_Component_Configuration (Instance, Res); + Append_Element (Instance_List, Instance_Name); + else + Replace_Nth_Element (Conf_Instance_List, N_Nbr, Instance_Name); + N_Nbr := N_Nbr + 1; + end if; + end loop; + Set_Nbr_Elements (Conf_Instance_List, N_Nbr); + + -- Insert RES. + Set_Chain (Res, Get_Chain (Comp_Conf)); + Set_Chain (Comp_Conf, Res); + end Canon_Incremental_Binding; + + procedure Canon_Component_Specification_All_Others + (Conf : Iir; Parent : Iir; Spec : Iir_List; List : Iir_List; Comp : Iir) + is + El : Iir; + Comp_Conf : Iir; + begin + El := Get_Concurrent_Statement_Chain (Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Instantiation_Statement => + if Is_Component_Instantiation (El) + and then Get_Named_Entity (Get_Instantiated_Unit (El)) = Comp + then + Comp_Conf := Get_Component_Configuration (El); + if Comp_Conf = Null_Iir then + -- The component is not yet configured. + Append_Element (List, Build_Simple_Name (El, El)); + Set_Component_Configuration (El, Conf); + else + -- The component is already configured. + -- Handle incremental configuration. + if (Get_Kind (Comp_Conf) + = Iir_Kind_Configuration_Specification) + and then Spec = Iir_List_All + then + -- FIXME: handle incremental configuration. + raise Internal_Error; + end if; + if Spec = Iir_List_All then + -- Several component configuration for an instance. + -- Must have been caught by sem. + raise Internal_Error; + elsif Spec = Iir_List_Others then + null; + else + raise Internal_Error; + end if; + end if; + end if; + when Iir_Kind_Generate_Statement => + if False + and then Vhdl_Std = Vhdl_87 + and then + Get_Kind (Conf) = Iir_Kind_Configuration_Specification + then + Canon_Component_Specification_All_Others + (Conf, El, Spec, List, Comp); + end if; + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end Canon_Component_Specification_All_Others; + + procedure Canon_Component_Specification_List + (Conf : Iir; Parent : Iir; Spec : Iir_List) + is + El : Iir; + Comp_Conf : Iir; + begin + -- Already has a designator list. + for I in Natural loop + El := Get_Nth_Element (Spec, I); + exit when El = Null_Iir; + El := Get_Named_Entity (El); + Comp_Conf := Get_Component_Configuration (El); + if Comp_Conf /= Null_Iir and then Comp_Conf /= Conf then + if Get_Kind (Comp_Conf) /= Iir_Kind_Configuration_Specification + or else Get_Kind (Conf) /= Iir_Kind_Component_Configuration + then + raise Internal_Error; + end if; + Canon_Incremental_Binding (Comp_Conf, Conf, Parent); + else + Set_Component_Configuration (El, Conf); + end if; + end loop; + end Canon_Component_Specification_List; + + -- PARENT is the parent for the chain of concurrent statements. + procedure Canon_Component_Specification (Conf : Iir; Parent : Iir) + is + Spec : constant Iir_List := Get_Instantiation_List (Conf); + List : Iir_Designator_List; + begin + if Spec = Iir_List_All or Spec = Iir_List_Others then + List := Create_Iir_List; + Canon_Component_Specification_All_Others + (Conf, Parent, Spec, List, + Get_Named_Entity (Get_Component_Name (Conf))); + Set_Instantiation_List (Conf, List); + else + -- Has Already a designator list. + Canon_Component_Specification_List (Conf, Parent, Spec); + end if; + end Canon_Component_Specification; + + -- Replace ALL/OTHERS with the explicit list of signals. + procedure Canon_Disconnection_Specification + (Dis : Iir_Disconnection_Specification; Decl_Parent : Iir) + is + Signal_List : Iir_List; + Force : Boolean; + El : Iir; + N_List : Iir_Designator_List; + Dis_Type : Iir; + begin + if Canon_Flag_Expressions then + Canon_Expression (Get_Expression (Dis)); + end if; + Signal_List := Get_Signal_List (Dis); + if Signal_List = Iir_List_All then + Force := True; + elsif Signal_List = Iir_List_Others then + Force := False; + else + return; + end if; + Dis_Type := Get_Type (Get_Type_Mark (Dis)); + N_List := Create_Iir_List; + Set_Signal_List (Dis, N_List); + El := Get_Declaration_Chain (Decl_Parent); + while El /= Null_Iir loop + if Get_Kind (El) = Iir_Kind_Signal_Declaration + and then Get_Type (El) = Dis_Type + and then Get_Signal_Kind (El) /= Iir_No_Signal_Kind + then + if not Get_Has_Disconnect_Flag (El) then + Set_Has_Disconnect_Flag (El, True); + Append_Element (N_List, El); + else + if Force then + raise Internal_Error; + end if; + end if; + end if; + El := Get_Chain (El); + end loop; + end Canon_Disconnection_Specification; + + procedure Canon_Subtype_Indication (Def : Iir) is + begin + case Get_Kind (Def) is + when Iir_Kind_Array_Subtype_Definition => + declare + Indexes : constant Iir_List := Get_Index_Subtype_List (Def); + Index : Iir; + begin + for I in Natural loop + Index := Get_Nth_Element (Indexes, I); + exit when Index = Null_Iir; + Canon_Subtype_Indication_If_Anonymous (Index); + end loop; + end; + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + declare + Rng : constant Iir := Get_Range_Constraint (Def); + begin + if Get_Kind (Rng) = Iir_Kind_Range_Expression then + Canon_Expression (Rng); + end if; + end; + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Record_Type_Definition => + null; + when Iir_Kind_Access_Subtype_Definition => + null; + when others => + Error_Kind ("canon_subtype_indication", Def); + end case; + end Canon_Subtype_Indication; + + procedure Canon_Subtype_Indication_If_Anonymous (Def : Iir) is + begin + if Is_Anonymous_Type_Definition (Def) then + Canon_Subtype_Indication (Def); + end if; + end Canon_Subtype_Indication_If_Anonymous; + + procedure Canon_Declaration (Top : Iir_Design_Unit; + Decl : Iir; + Parent : Iir; + Decl_Parent : Iir) + is + begin + case Get_Kind (Decl) is + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + Canon_Declarations (Top, Decl, Null_Iir); + if Canon_Flag_Sequentials_Stmts then + Canon_Sequential_Stmts (Get_Sequential_Statement_Chain (Decl)); + end if; + + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + null; + + when Iir_Kind_Type_Declaration => + declare + Def : Iir; + begin + Def := Get_Type_Definition (Decl); + if Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration then + Canon_Declarations (Decl, Def, Null_Iir); + end if; + end; + + when Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration => + null; + + when Iir_Kind_Protected_Type_Body => + Canon_Declarations (Top, Decl, Null_Iir); + + when Iir_Kind_Variable_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Constant_Declaration => + if Canon_Flag_Expressions then + Canon_Subtype_Indication_If_Anonymous (Get_Type (Decl)); + Canon_Expression (Get_Default_Value (Decl)); + end if; + + when Iir_Kind_Iterator_Declaration => + null; + + when Iir_Kind_Object_Alias_Declaration => + null; + when Iir_Kind_Non_Object_Alias_Declaration => + null; + + when Iir_Kind_File_Declaration => + -- FIXME + null; + + when Iir_Kind_Attribute_Declaration => + null; + when Iir_Kind_Attribute_Specification => + if Canon_Flag_Expressions then + Canon_Expression (Get_Expression (Decl)); + end if; + when Iir_Kind_Disconnection_Specification => + Canon_Disconnection_Specification (Decl, Decl_Parent); + + when Iir_Kind_Group_Template_Declaration => + null; + when Iir_Kind_Group_Declaration => + null; + + when Iir_Kind_Use_Clause => + null; + + when Iir_Kind_Component_Declaration => + null; + + when Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Implicit_Function_Declaration => + null; + + when Iir_Kind_Configuration_Specification => + Canon_Component_Specification (Decl, Parent); + Canon_Component_Configuration (Top, Decl); +-- declare +-- List : Iir_List; +-- Binding : Iir_Binding_Indication; +-- Component : Iir_Component_Declaration; +-- Aspect : Iir; +-- Entity : Iir; +-- begin +-- Binding := Get_Binding_Indication (Decl); +-- Component := Get_Component_Name (Decl); +-- Aspect := Get_Entity_Aspect (Binding); +-- case Get_Kind (Aspect) is +-- when Iir_Kind_Entity_Aspect_Entity => +-- Entity := Get_Entity (Aspect); +-- when others => +-- Error_Kind ("configuration_specification", Aspect); +-- end case; +-- Entity := Get_Library_Unit (Entity); +-- List := Get_Generic_Map_Aspect_List (Binding); +-- if List = Null_Iir_List then +-- Set_Generic_Map_Aspect_List +-- (Binding, +-- Canon_Default_Map_Association_List +-- (Get_Generic_List (Entity), Get_Generic_List (Component), +-- Get_Location (Decl))); +-- end if; +-- List := Get_Port_Map_Aspect_List (Binding); +-- if List = Null_Iir_List then +-- Set_Port_Map_Aspect_List +-- (Binding, +-- Canon_Default_Map_Association_List +-- (Get_Port_List (Entity), Get_Port_List (Component), +-- Get_Location (Decl))); +-- end if; +-- end; + + when Iir_Kinds_Signal_Attribute => + null; + + when Iir_Kind_Nature_Declaration => + null; + when Iir_Kind_Terminal_Declaration => + null; + when Iir_Kinds_Quantity_Declaration => + null; + when others => + Error_Kind ("canon_declaration", Decl); + end case; + end Canon_Declaration; + + procedure Canon_Declarations (Top : Iir_Design_Unit; + Decl_Parent : Iir; + Parent : Iir) + is + Decl : Iir; + begin + if Parent /= Null_Iir then + Clear_Instantiation_Configuration (Parent, True); + end if; + Decl := Get_Declaration_Chain (Decl_Parent); + while Decl /= Null_Iir loop + Canon_Declaration (Top, Decl, Parent, Decl_Parent); + Decl := Get_Chain (Decl); + end loop; + end Canon_Declarations; + + procedure Canon_Block_Configuration (Top : Iir_Design_Unit; + Conf : Iir_Block_Configuration) + is + use Iir_Chains.Configuration_Item_Chain_Handling; + Spec : constant Iir := Get_Block_Specification (Conf); + Blk : constant Iir := Get_Block_From_Block_Specification (Spec); + Stmts : constant Iir := Get_Concurrent_Statement_Chain (Blk); + El : Iir; + Sub_Blk : Iir; + Last_Item : Iir; + begin + -- Note: the only allowed declarations are use clauses, which are not + -- canonicalized. + + -- FIXME: handle indexed/sliced name? + + Clear_Instantiation_Configuration (Blk, False); + + Build_Init (Last_Item, Conf); + + -- 1) Configure instantiations with configuration specifications. + -- TODO: merge. + El := Get_Declaration_Chain (Blk); + while El /= Null_Iir loop + if Get_Kind (El) = Iir_Kind_Configuration_Specification then + -- Already canoncalized during canon of block declarations. + -- But need to set configuration on instantiations. + Canon_Component_Specification (El, Blk); + end if; + El := Get_Chain (El); + end loop; + + -- 2) Configure instantations with component configurations, + -- and map block configurations with block/generate statements. + El := Get_Configuration_Item_Chain (Conf); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Configuration_Specification => + raise Internal_Error; + when Iir_Kind_Component_Configuration => + Canon_Component_Specification (El, Blk); + when Iir_Kind_Block_Configuration => + Sub_Blk := Strip_Denoting_Name (Get_Block_Specification (El)); + case Get_Kind (Sub_Blk) is + when Iir_Kind_Block_Statement => + Set_Block_Block_Configuration (Sub_Blk, El); + when Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name => + Sub_Blk := Strip_Denoting_Name (Get_Prefix (Sub_Blk)); + Set_Prev_Block_Configuration + (El, Get_Generate_Block_Configuration (Sub_Blk)); + Set_Generate_Block_Configuration (Sub_Blk, El); + when Iir_Kind_Generate_Statement => + Set_Generate_Block_Configuration (Sub_Blk, El); + when others => + Error_Kind ("canon_block_configuration(0)", Sub_Blk); + end case; + when others => + Error_Kind ("canon_block_configuration(1)", El); + end case; + El := Get_Chain (El); + end loop; + + -- 3) Add default component configuration for unspecified component + -- instantiation statements, + -- Add default block configuration for unconfigured block statements. + El := Stmts; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Instantiation_Statement => + declare + Comp_Conf : Iir; + Res : Iir_Component_Configuration; + Designator_List : Iir_List; + Inst_List : Iir_List; + Inst : Iir; + Inst_Name : Iir; + begin + Comp_Conf := Get_Component_Configuration (El); + if Comp_Conf = Null_Iir then + if Is_Component_Instantiation (El) then + -- Create a component configuration. + -- FIXME: should merge all these default configuration + -- of the same component. + Res := Create_Iir (Iir_Kind_Component_Configuration); + Location_Copy (Res, El); + Set_Parent (Res, Conf); + Set_Component_Name (Res, Get_Instantiated_Unit (El)); + Designator_List := Create_Iir_List; + Append_Element + (Designator_List, Build_Simple_Name (El, El)); + Set_Instantiation_List (Res, Designator_List); + Append (Last_Item, Conf, Res); + end if; + elsif Get_Kind (Comp_Conf) + = Iir_Kind_Configuration_Specification + then + -- Create component configuration + Res := Create_Iir (Iir_Kind_Component_Configuration); + Location_Copy (Res, Comp_Conf); + Set_Parent (Res, Conf); + Set_Component_Name (Res, Get_Component_Name (Comp_Conf)); + -- Keep in the designator list only the non-incrementally + -- bound instances, and only the instances in the current + -- statements parts (vhdl-87 generate issue). + Inst_List := Get_Instantiation_List (Comp_Conf); + Designator_List := Create_Iir_List; + for I in 0 .. Get_Nbr_Elements (Inst_List) - 1 loop + Inst_Name := Get_Nth_Element (Inst_List, I); + Inst := Get_Named_Entity (Inst_Name); + if Get_Component_Configuration (Inst) = Comp_Conf + and then Get_Parent (Inst) = Blk + then + Set_Component_Configuration (Inst, Res); + Append_Element (Designator_List, Inst_Name); + end if; + end loop; + Set_Instantiation_List (Res, Designator_List); + Set_Binding_Indication + (Res, Get_Binding_Indication (Comp_Conf)); + Append (Last_Item, Conf, Res); + end if; + end; + when Iir_Kind_Block_Statement => + declare + Res : Iir_Block_Configuration; + begin + if Get_Block_Block_Configuration (El) = Null_Iir then + Res := Create_Iir (Iir_Kind_Block_Configuration); + Location_Copy (Res, El); + Set_Parent (Res, Conf); + Set_Block_Specification (Res, El); + Append (Last_Item, Conf, Res); + end if; + end; + when Iir_Kind_Generate_Statement => + declare + Res : Iir_Block_Configuration; + Scheme : Iir; + Blk_Config : Iir_Block_Configuration; + Blk_Spec : Iir; + begin + Scheme := Get_Generation_Scheme (El); + Blk_Config := Get_Generate_Block_Configuration (El); + if Blk_Config = Null_Iir then + -- No block configuration for the (implicit) internal + -- block. Create one. + Res := Create_Iir (Iir_Kind_Block_Configuration); + Location_Copy (Res, El); + Set_Parent (Res, Conf); + Set_Block_Specification (Res, El); + Append (Last_Item, Conf, Res); + elsif Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Blk_Spec := Strip_Denoting_Name + (Get_Block_Specification (Blk_Config)); + if Get_Kind (Blk_Spec) /= Iir_Kind_Generate_Statement then + -- There are partial configurations. + -- Create a default block configuration. + Res := Create_Iir (Iir_Kind_Block_Configuration); + Location_Copy (Res, El); + Set_Parent (Res, Conf); + Blk_Spec := Create_Iir (Iir_Kind_Indexed_Name); + Location_Copy (Blk_Spec, Res); + Set_Index_List (Blk_Spec, Iir_List_Others); + Set_Base_Name (Blk_Spec, El); + Set_Prefix (Blk_Spec, Build_Simple_Name (El, Res)); + Set_Block_Specification (Res, Blk_Spec); + Append (Last_Item, Conf, Res); + end if; + end if; + end; + + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Declaration + | Iir_Kind_Simple_Simultaneous_Statement => + null; + + when others => + Error_Kind ("canon_block_configuration(3)", El); + end case; + El := Get_Chain (El); + end loop; + + -- 4) Canon component configuration and block configuration (recursion). + El := Get_Configuration_Item_Chain (Conf); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Block_Configuration => + Canon_Block_Configuration (Top, El); + when Iir_Kind_Component_Configuration => + Canon_Component_Configuration (Top, El); + when others => + Error_Kind ("canon_block_configuration", El); + end case; + El := Get_Chain (El); + end loop; + end Canon_Block_Configuration; + + procedure Canon_Interface_List (Chain : Iir) + is + Inter : Iir; + begin + if Canon_Flag_Expressions then + Inter := Chain; + while Inter /= Null_Iir loop + Canon_Expression (Get_Default_Value (Inter)); + Inter := Get_Chain (Inter); + end loop; + end if; + end Canon_Interface_List; + + procedure Canonicalize (Unit: Iir_Design_Unit) + is + El: Iir; + begin + if False then + -- Canon context clauses. + -- This code is not executed since context clauses are already + -- canonicalized. + El := Get_Context_Items (Unit); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Library_Clause => + null; + when others => + Error_Kind ("canonicalize1", El); + end case; + El := Get_Chain (El); + end loop; + end if; + + El := Get_Library_Unit (Unit); + case Get_Kind (El) is + when Iir_Kind_Entity_Declaration => + Canon_Interface_List (Get_Generic_Chain (El)); + Canon_Interface_List (Get_Port_Chain (El)); + Canon_Declarations (Unit, El, El); + Canon_Concurrent_Stmts (Unit, El); + when Iir_Kind_Architecture_Body => + Canon_Declarations (Unit, El, El); + Canon_Concurrent_Stmts (Unit, El); + when Iir_Kind_Package_Declaration => + Canon_Declarations (Unit, El, Null_Iir); + when Iir_Kind_Package_Body => + Canon_Declarations (Unit, El, Null_Iir); + when Iir_Kind_Configuration_Declaration => + Canon_Declarations (Unit, El, Null_Iir); + Canon_Block_Configuration (Unit, Get_Block_Configuration (El)); + when Iir_Kind_Package_Instantiation_Declaration => + declare + Pkg : constant Iir := + Get_Named_Entity (Get_Uninstantiated_Package_Name (El)); + Hdr : constant Iir := Get_Package_Header (Pkg); + begin + Set_Generic_Map_Aspect_Chain + (El, + Canon_Association_Chain_And_Actuals + (Get_Generic_Chain (Hdr), + Get_Generic_Map_Aspect_Chain (El), El)); + end; + when others => + Error_Kind ("canonicalize2", El); + end case; + end Canonicalize; + +-- -- Create a default component configuration for component instantiation +-- -- statement INST. +-- function Create_Default_Component_Configuration +-- (Inst : Iir_Component_Instantiation_Statement; +-- Parent : Iir; +-- Config_Unit : Iir_Design_Unit) +-- return Iir_Component_Configuration +-- is +-- Res : Iir_Component_Configuration; +-- Designator : Iir; +-- Comp : Iir_Component_Declaration; +-- Bind : Iir; +-- Aspect : Iir; +-- begin +-- Bind := Get_Default_Binding_Indication (Inst); + +-- if Bind = Null_Iir then +-- -- Component is not bound. +-- return Null_Iir; +-- end if; + +-- Res := Create_Iir (Iir_Kind_Component_Configuration); +-- Location_Copy (Res, Inst); +-- Set_Parent (Res, Parent); +-- Comp := Get_Instantiated_Unit (Inst); + +-- Set_Component_Name (Res, Comp); +-- -- Create the instantiation list with only one element: INST. +-- Designator := Create_Iir (Iir_Kind_Designator_List); +-- Append_Element (Designator, Inst); +-- Set_Instantiation_List (Res, Designator); + +-- Set_Binding_Indication (Res, Bind); +-- Aspect := Get_Entity_Aspect (Bind); +-- case Get_Kind (Aspect) is +-- when Iir_Kind_Entity_Aspect_Entity => +-- Add_Dependence (Config_Unit, Get_Entity (Aspect)); +-- if Get_Architecture (Aspect) /= Null_Iir then +-- raise Internal_Error; +-- end if; +-- when others => +-- Error_Kind ("Create_Default_Component_Configuration", Aspect); +-- end case; + +-- return Res; +-- end Create_Default_Component_Configuration; + + -- Create a default configuration declaration for architecture ARCH. + function Create_Default_Configuration_Declaration + (Arch : Iir_Architecture_Body) + return Iir_Design_Unit + is + Loc : constant Location_Type := Get_Location (Arch); + Config : Iir_Configuration_Declaration; + Res : Iir_Design_Unit; + Blk_Cfg : Iir_Block_Configuration; + begin + Res := Create_Iir (Iir_Kind_Design_Unit); + Set_Location (Res, Loc); + Set_Parent (Res, Get_Parent (Get_Design_Unit (Arch))); + Set_Date_State (Res, Date_Analyze); + Set_Date (Res, Date_Uptodate); + + Config := Create_Iir (Iir_Kind_Configuration_Declaration); + Set_Location (Config, Loc); + Set_Library_Unit (Res, Config); + Set_Design_Unit (Config, Res); + Set_Entity_Name (Config, Get_Entity_Name (Arch)); + Set_Dependence_List (Res, Create_Iir_List); + Add_Dependence (Res, Get_Design_Unit (Get_Entity (Config))); + Add_Dependence (Res, Get_Design_Unit (Arch)); + + Blk_Cfg := Create_Iir (Iir_Kind_Block_Configuration); + Set_Location (Blk_Cfg, Loc); + Set_Parent (Blk_Cfg, Config); + Set_Block_Specification (Blk_Cfg, Arch); + Set_Block_Configuration (Config, Blk_Cfg); + + Canon_Block_Configuration (Res, Blk_Cfg); + + return Res; + end Create_Default_Configuration_Declaration; + +end Canon; diff --git a/src/vhdl/canon.ads b/src/vhdl/canon.ads new file mode 100644 index 000000000..574a31824 --- /dev/null +++ b/src/vhdl/canon.ads @@ -0,0 +1,70 @@ +-- Canonicalization pass +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +package Canon is + -- If true, a label will be added for statements which do not have a + -- label. + Canon_Flag_Add_Labels : Boolean := False; + + -- If true, canon sequentials statements (processes and subprograms). + Canon_Flag_Sequentials_Stmts : Boolean := False; + + -- If true, canon expressions. + Canon_Flag_Expressions : Boolean := False; + + -- If true, replace 'all' sensitivity list by the explicit list + -- (If true, Canon_Flag_Sequentials_Stmts must be true) + Canon_Flag_All_Sensitivity : Boolean := False; + + -- If true, operands of type array element of a concatenation operator + -- are converted (by an aggregate) into array. + Canon_Concatenation : Boolean := False; + + -- Do canonicalization: + -- Transforms concurrent statements into sensitized process statements + -- (all but component instanciation and block). + -- This computes sensivity list. + -- + -- Association list are completed: + -- * Formal are added. + -- * association are created for formal not associated (actual is open). + -- * an association is created (for block header only). + procedure Canonicalize (Unit: Iir_Design_Unit); + + -- Create a default configuration declaration for architecture ARCH. + function Create_Default_Configuration_Declaration + (Arch : Iir_Architecture_Body) + return Iir_Design_Unit; + + -- Canonicalize a subprogram call. + procedure Canon_Subprogram_Call (Call : Iir); + + -- Compute the sensivity list of EXPR and add it to SENSIVITY_LIST. + -- If IS_TARGET is true, the longuest static prefix of the signal name + -- is not added to the sensitivity list, but other static prefix (such + -- as indexes of an indexed name) are added. + procedure Canon_Extract_Sensitivity + (Expr: Iir; Sensitivity_List: Iir_List; Is_Target: Boolean := False); + + -- Compute the sensitivity list of all-sensitized process PROC. + -- Used for vhdl 08. + function Canon_Extract_Process_Sensitivity + (Proc : Iir_Sensitized_Process_Statement) + return Iir_List; +end Canon; diff --git a/src/vhdl/canon_psl.adb b/src/vhdl/canon_psl.adb new file mode 100644 index 000000000..1e1d8de18 --- /dev/null +++ b/src/vhdl/canon_psl.adb @@ -0,0 +1,43 @@ +-- Canonicalization pass for PSL. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with PSL.Nodes; use PSL.Nodes; +with PSL.Errors; use PSL.Errors; +with Canon; use Canon; +with Iirs_Utils; use Iirs_Utils; + +package body Canon_PSL is + -- Version of Canon.Canon_Extract_Sensitivity for PSL nodes. + procedure Canon_Extract_Sensitivity + (Expr: PSL_Node; Sensitivity_List: Iir_List) + is + begin + case Get_Kind (Expr) is + when N_HDL_Expr => + Canon_Extract_Sensitivity (Get_HDL_Node (Expr), Sensitivity_List); + when N_And_Bool + | N_Or_Bool => + Canon_Extract_Sensitivity (Get_Left (Expr), Sensitivity_List); + Canon_Extract_Sensitivity (Get_Right (Expr), Sensitivity_List); + when N_Not_Bool => + Canon_Extract_Sensitivity (Get_Boolean (Expr), Sensitivity_List); + when others => + Error_Kind ("PSL.Canon_extract_Sensitivity", Expr); + end case; + end Canon_Extract_Sensitivity; +end Canon_PSL; diff --git a/src/vhdl/canon_psl.ads b/src/vhdl/canon_psl.ads new file mode 100644 index 000000000..3a8c501ac --- /dev/null +++ b/src/vhdl/canon_psl.ads @@ -0,0 +1,26 @@ +-- Canonicalization pass for PSL. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with Iirs; use Iirs; + +package Canon_PSL is + -- Version of Canon.Canon_Extract_Sensitivity for PSL nodes. + procedure Canon_Extract_Sensitivity + (Expr: PSL_Node; Sensitivity_List: Iir_List); +end Canon_PSL; diff --git a/src/vhdl/configuration.adb b/src/vhdl/configuration.adb new file mode 100644 index 000000000..f570b692e --- /dev/null +++ b/src/vhdl/configuration.adb @@ -0,0 +1,614 @@ +-- Configuration generation. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Libraries; +with Errorout; use Errorout; +with Std_Package; +with Sem_Names; +with Name_Table; use Name_Table; +with Flags; +with Iirs_Utils; use Iirs_Utils; + +package body Configuration is + procedure Add_Design_Concurrent_Stmts (Parent : Iir); + procedure Add_Design_Block_Configuration (Blk : Iir_Block_Configuration); + procedure Add_Design_Aspect (Aspect : Iir; Add_Default : Boolean); + + Current_File_Dependence : Iir_List := Null_Iir_List; + Current_Configuration : Iir_Configuration_Declaration := Null_Iir; + + -- UNIT is a design unit of a configuration declaration. + -- Fill the DESIGN_UNITS table with all design units required to build + -- UNIT. + procedure Add_Design_Unit (Unit : Iir_Design_Unit; From : Iir) + is + List : Iir_List; + El : Iir; + Lib_Unit : Iir; + File : Iir_Design_File; + Prev_File_Dependence : Iir_List; + begin + if Flag_Build_File_Dependence then + File := Get_Design_File (Unit); + if Current_File_Dependence /= Null_Iir_List then + Add_Element (Current_File_Dependence, File); + end if; + end if; + + -- If already in the table, then nothing to do. + if Get_Elab_Flag (Unit) then + return; + end if; + + -- May be enabled to debug dependency construction. + if False then + if From = Null_Iir then + Warning_Msg_Elab (Disp_Node (Unit) & " added", Unit); + else + Warning_Msg_Elab + (Disp_Node (Unit) & " added by " & Disp_Node (From), From); + end if; + end if; + + Set_Elab_Flag (Unit, True); + + Lib_Unit := Get_Library_Unit (Unit); + + if Flag_Build_File_Dependence then + Prev_File_Dependence := Current_File_Dependence; + + if Get_Kind (Lib_Unit) = Iir_Kind_Configuration_Declaration + and then Get_Identifier (Lib_Unit) = Null_Identifier + then + -- Do not add dependence for default configuration. + Current_File_Dependence := Null_Iir_List; + else + File := Get_Design_File (Unit); + Current_File_Dependence := Get_File_Dependence_List (File); + -- Create a list if not yet created. + if Current_File_Dependence = Null_Iir_List then + Current_File_Dependence := Create_Iir_List; + Set_File_Dependence_List (File, Current_File_Dependence); + end if; + end if; + end if; + + if Flag_Load_All_Design_Units then + Libraries.Load_Design_Unit (Unit, From); + end if; + + -- Add packages from depend list. + -- If Flag_Build_File_Dependences is set, add design units of the + -- dependence list are added, because of LRM 11.4 Analysis Order. + -- Note: a design unit may be referenced but unused. + -- (eg: component specification which does not apply). + List := Get_Dependence_List (Unit); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El := Libraries.Find_Design_Unit (El); + if El /= Null_Iir then + Lib_Unit := Get_Library_Unit (El); + if Flag_Build_File_Dependence + or else Get_Kind (Lib_Unit) in Iir_Kinds_Package_Declaration + then + Add_Design_Unit (El, Unit); + end if; + end if; + end loop; + + -- Lib_Unit may have changed. + Lib_Unit := Get_Library_Unit (Unit); + + case Get_Kind (Lib_Unit) is + when Iir_Kind_Package_Declaration => + -- Analyze the package declaration, so that Set_Package below + -- will set the full package (and not a stub). + Libraries.Load_Design_Unit (Unit, From); + Lib_Unit := Get_Library_Unit (Unit); + when Iir_Kind_Package_Instantiation_Declaration => + -- The uninstantiated package is part of the dependency. + null; + when Iir_Kind_Configuration_Declaration => + -- Add entity and architecture. + -- find all sub-configuration + Libraries.Load_Design_Unit (Unit, From); + Lib_Unit := Get_Library_Unit (Unit); + Add_Design_Unit (Get_Design_Unit (Get_Entity (Lib_Unit)), Unit); + declare + Blk : Iir_Block_Configuration; + Prev_Configuration : Iir_Configuration_Declaration; + Arch : Iir; + begin + Prev_Configuration := Current_Configuration; + Current_Configuration := Lib_Unit; + Blk := Get_Block_Configuration (Lib_Unit); + Arch := Get_Block_Specification (Blk); + Add_Design_Block_Configuration (Blk); + Current_Configuration := Prev_Configuration; + Add_Design_Unit (Get_Design_Unit (Arch), Unit); + end; + when Iir_Kind_Architecture_Body => + -- Add entity + -- find all entity/architecture/configuration instantiation + Add_Design_Unit (Get_Design_Unit (Get_Entity (Lib_Unit)), Unit); + Add_Design_Concurrent_Stmts (Lib_Unit); + when Iir_Kind_Entity_Declaration => + null; + when Iir_Kind_Package_Body => + null; + when others => + Error_Kind ("add_design_unit", Lib_Unit); + end case; + + -- Add it in the table, after the dependencies. + Design_Units.Append (Unit); + + -- Restore now the file dependence. + -- Indeed, we may add a package body when we are in a package + -- declaration. However, the later does not depend on the former. + -- The file which depends on the package declaration also depends on + -- the package body. + if Flag_Build_File_Dependence then + Current_File_Dependence := Prev_File_Dependence; + end if; + + if Get_Kind (Lib_Unit) = Iir_Kind_Package_Declaration then + -- Add body (if any). + declare + Bod : Iir_Design_Unit; + begin + Bod := Libraries.Find_Secondary_Unit (Unit, Null_Identifier); + if Get_Need_Body (Lib_Unit) then + if not Flags.Flag_Elaborate_With_Outdated then + -- LIB_UNIT requires a body. + if Bod = Null_Iir then + Error_Msg_Elab ("body of " & Disp_Node (Lib_Unit) + & " was never analyzed", Lib_Unit); + elsif Get_Date (Bod) < Get_Date (Unit) then + Error_Msg_Elab (Disp_Node (Bod) & " is outdated"); + Bod := Null_Iir; + end if; + end if; + else + if Bod /= Null_Iir + and then Get_Date (Bod) < Get_Date (Unit) + then + -- There is a body for LIB_UNIT (which doesn't + -- require it) but it is outdated. + Bod := Null_Iir; + end if; + end if; + if Bod /= Null_Iir then + Set_Package (Get_Library_Unit (Bod), Lib_Unit); + Add_Design_Unit (Bod, Unit); + end if; + end; + end if; + end Add_Design_Unit; + + procedure Add_Design_Concurrent_Stmts (Parent : Iir) + is + Stmt : Iir; + begin + Stmt := Get_Concurrent_Statement_Chain (Parent); + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Component_Instantiation_Statement => + if Is_Entity_Instantiation (Stmt) then + -- Entity or configuration instantiation. + Add_Design_Aspect (Get_Instantiated_Unit (Stmt), True); + end if; + when Iir_Kind_Generate_Statement + | Iir_Kind_Block_Statement => + Add_Design_Concurrent_Stmts (Stmt); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Declaration + | Iir_Kind_Simple_Simultaneous_Statement => + null; + when others => + Error_Kind ("add_design_concurrent_stmts(2)", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Add_Design_Concurrent_Stmts; + + procedure Add_Design_Aspect (Aspect : Iir; Add_Default : Boolean) + is + use Libraries; + + Entity : Iir; + Arch : Iir; + Config : Iir; + Id : Name_Id; + Entity_Lib : Iir; + begin + if Aspect = Null_Iir then + return; + end if; + case Get_Kind (Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + -- Add the entity. + Entity_Lib := Get_Entity (Aspect); + Entity := Get_Design_Unit (Entity_Lib); + Add_Design_Unit (Entity, Aspect); + + -- Extract and add the architecture. + Arch := Get_Architecture (Aspect); + if Arch /= Null_Iir then + case Get_Kind (Arch) is + when Iir_Kind_Simple_Name => + Id := Get_Identifier (Arch); + Arch := Load_Secondary_Unit (Entity, Id, Aspect); + if Arch = Null_Iir then + Error_Msg_Elab + ("cannot find architecture " & Name_Table.Image (Id) + & " of " & Disp_Node (Entity_Lib)); + return; + else + Set_Architecture (Aspect, Get_Library_Unit (Arch)); + end if; + when Iir_Kind_Architecture_Body => + Arch := Get_Design_Unit (Arch); + when others => + Error_Kind ("add_design_aspect", Arch); + end case; + else + Arch := Get_Latest_Architecture (Entity_Lib); + if Arch = Null_Iir then + Error_Msg_Elab ("no architecture in library for " + & Disp_Node (Entity_Lib), Aspect); + return; + end if; + Arch := Get_Design_Unit (Arch); + end if; + Load_Design_Unit (Arch, Aspect); + Add_Design_Unit (Arch, Aspect); + + -- Add the default configuration if required. + if Add_Default then + Config := Get_Default_Configuration_Declaration + (Get_Library_Unit (Arch)); + if Config /= Null_Iir then + Add_Design_Unit (Config, Aspect); + end if; + end if; + when Iir_Kind_Entity_Aspect_Configuration => + Add_Design_Unit + (Get_Design_Unit (Get_Configuration (Aspect)), Aspect); + when Iir_Kind_Entity_Aspect_Open => + null; + when others => + Error_Kind ("add_design_aspect", Aspect); + end case; + end Add_Design_Aspect; + + -- Return TRUE is PORT must not be open, and emit an error message only if + -- LOC is not NULL_IIR. + function Check_Open_Port (Port : Iir; Loc : Iir) return Boolean is + begin + case Get_Mode (Port) is + when Iir_In_Mode => + -- LRM 1.1.1.2 Ports + -- A port of mode IN may be unconnected or unassociated only if + -- its declaration includes a default expression. + if Get_Default_Value (Port) = Null_Iir then + if Loc /= Null_Iir then + Error_Msg_Elab + ("IN " & Disp_Node (Port) & " must be connected", Loc); + end if; + return True; + end if; + when Iir_Out_Mode + | Iir_Inout_Mode + | Iir_Buffer_Mode + | Iir_Linkage_Mode => + -- LRM 1.1.1.2 Ports + -- 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_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) + & " must be connected", Loc); + end if; + return True; + end if; + when others => + Error_Kind ("check_open_port", Port); + end case; + return False; + end Check_Open_Port; + + procedure Check_Binding_Indication (Conf : Iir) + is + Assoc : Iir; + Conf_Chain : Iir; + Inst_Chain : Iir; + Bind : Iir_Binding_Indication; + Err : Boolean; + Inst : Iir; + Inst_List : Iir_List; + Formal : Iir; + Assoc_1 : Iir; + Actual : Iir; + begin + Bind := Get_Binding_Indication (Conf); + Conf_Chain := Get_Port_Map_Aspect_Chain (Bind); + + Err := False; + -- Note: the assoc chain is already canonicalized. + + -- First pass: check for open associations in configuration. + Assoc := Conf_Chain; + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then + Formal := Get_Association_Interface (Assoc); + Err := Err or Check_Open_Port (Formal, Assoc); + if Flags.Warn_Binding and then not Get_Artificial_Flag (Assoc) then + Warning_Msg_Elab + (Disp_Node (Formal) & " of " & Disp_Node (Get_Parent (Formal)) + & " is not bound", Assoc); + Warning_Msg_Elab + ("(in " & Disp_Node (Current_Configuration) & ")", + Current_Configuration); + end if; + end if; + Assoc := Get_Chain (Assoc); + end loop; + if Err then + return; + end if; + + -- Second pass: check for port connected to open in instantiation. + Inst_List := Get_Instantiation_List (Conf); + for I in Natural loop + Inst := Get_Nth_Element (Inst_List, I); + exit when Inst = Null_Iir; + Inst := Get_Named_Entity (Inst); + Err := False; + + -- Mark component ports not associated. + Inst_Chain := Get_Port_Map_Aspect_Chain (Inst); + Assoc := Inst_Chain; + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then + Formal := Get_Association_Interface (Assoc); + Set_Open_Flag (Formal, True); + Err := True; + end if; + Assoc := Get_Chain (Assoc); + end loop; + + -- If there is any component port open, search them in the + -- configuration. + if Err then + Assoc := Conf_Chain; + while Assoc /= Null_Iir loop + Formal := Get_Association_Interface (Assoc); + if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then + Actual := Null_Iir; + else + Actual := Get_Actual (Assoc); + Actual := Sem_Names.Name_To_Object (Actual); + if Actual /= Null_Iir then + Actual := Get_Object_Prefix (Actual); + end if; + end if; + if Actual /= Null_Iir + and then Get_Open_Flag (Actual) + and then Check_Open_Port (Formal, Null_Iir) + then + -- For a better message, find the location. + Assoc_1 := Inst_Chain; + while Assoc_1 /= Null_Iir loop + if Get_Kind (Assoc_1) = Iir_Kind_Association_Element_Open + and then Actual = Get_Association_Interface (Assoc_1) + then + Err := Check_Open_Port (Formal, Assoc_1); + exit; + end if; + Assoc_1 := Get_Chain (Assoc_1); + end loop; + end if; + Assoc := Get_Chain (Assoc); + end loop; + + -- Clear open flag. + Assoc := Inst_Chain; + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then + Formal := Get_Association_Interface (Assoc); + Set_Open_Flag (Formal, False); + end if; + Assoc := Get_Chain (Assoc); + end loop; + end if; + end loop; + end Check_Binding_Indication; + + -- CONF is either a configuration specification or a component + -- configuration. + -- If ADD_DEFAULT is true, then the default configuration for the design + -- binding must be added if required. + procedure Add_Design_Binding_Indication (Conf : Iir; Add_Default : Boolean) + is + Bind : constant Iir_Binding_Indication := Get_Binding_Indication (Conf); + Inst : Iir; + begin + if Bind = Null_Iir then + if Flags.Warn_Binding then + Inst := Get_First_Element (Get_Instantiation_List (Conf)); + Warning_Msg_Elab + (Disp_Node (Inst) & " is not bound", Conf); + Warning_Msg_Elab + ("(in " & Disp_Node (Current_Configuration) & ")", + Current_Configuration); + end if; + return; + end if; + Check_Binding_Indication (Conf); + Add_Design_Aspect (Get_Entity_Aspect (Bind), Add_Default); + end Add_Design_Binding_Indication; + + procedure Add_Design_Block_Configuration (Blk : Iir_Block_Configuration) + is + Item : Iir; + Sub_Config : Iir; + begin + if Blk = Null_Iir then + return; + end if; + Item := Get_Configuration_Item_Chain (Blk); + while Item /= Null_Iir loop + case Get_Kind (Item) is + when Iir_Kind_Configuration_Specification => + Add_Design_Binding_Indication (Item, True); + when Iir_Kind_Component_Configuration => + Sub_Config := Get_Block_Configuration (Item); + Add_Design_Binding_Indication (Item, Sub_Config = Null_Iir); + Add_Design_Block_Configuration (Sub_Config); + when Iir_Kind_Block_Configuration => + Add_Design_Block_Configuration (Item); + when others => + Error_Kind ("add_design_block_configuration", Item); + end case; + Item := Get_Chain (Item); + end loop; + end Add_Design_Block_Configuration; + + -- elaboration of a design hierarchy: + -- creates a list of design unit. + -- + -- find top configuration (may be a default one), add it to the list. + -- For each element of the list: + -- add direct dependences (packages, entity, arch) if not in the list + -- for architectures and configuration: find instantiations and add + -- corresponding configurations + function Configure (Primary_Id : Name_Id; Secondary_Id : Name_Id) + return Iir + is + use Libraries; + + Unit : Iir_Design_Unit; + Lib_Unit : Iir; + Top : Iir; + begin + Unit := Find_Primary_Unit (Work_Library, Primary_Id); + if Unit = Null_Iir then + Error_Msg_Elab ("cannot find entity or configuration " + & Name_Table.Image (Primary_Id)); + return Null_Iir; + end if; + Lib_Unit := Get_Library_Unit (Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Entity_Declaration => + Load_Design_Unit (Unit, Null_Iir); + Lib_Unit := Get_Library_Unit (Unit); + if Secondary_Id /= Null_Identifier then + Unit := Find_Secondary_Unit (Unit, Secondary_Id); + if Unit = Null_Iir then + Error_Msg_Elab + ("cannot find architecture " + & Name_Table.Image (Secondary_Id) + & " of " & Disp_Node (Lib_Unit)); + return Null_Iir; + end if; + else + declare + Arch_Unit : Iir_Architecture_Body; + begin + Arch_Unit := Get_Latest_Architecture (Lib_Unit); + if Arch_Unit = Null_Iir then + Error_Msg_Elab + (Disp_Node (Lib_Unit) + & " has no architecture in library " + & Name_Table.Image (Get_Identifier (Work_Library))); + return Null_Iir; + end if; + Unit := Get_Design_Unit (Arch_Unit); + end; + end if; + Load_Design_Unit (Unit, Lib_Unit); + if Nbr_Errors /= 0 then + return Null_Iir; + end if; + Lib_Unit := Get_Library_Unit (Unit); + Top := Get_Default_Configuration_Declaration (Lib_Unit); + if Top = Null_Iir then + -- No default configuration for this architecture. + raise Internal_Error; + end if; + when Iir_Kind_Configuration_Declaration => + Top := Unit; + when others => + Error_Msg_Elab (Name_Table.Image (Primary_Id) + & " is neither an entity nor a configuration"); + return Null_Iir; + end case; + + Set_Elab_Flag (Std_Package.Std_Standard_Unit, True); + + Add_Design_Unit (Top, Null_Iir); + return Top; + end Configure; + + procedure Check_Entity_Declaration_Top (Entity : Iir_Entity_Declaration) + is + Has_Error : Boolean := False; + + procedure Error (Msg : String; Loc : Iir) is + begin + if not Has_Error then + Error_Msg_Elab + (Disp_Node (Entity) & " cannot be at the top of a design"); + Has_Error := True; + end if; + Error_Msg_Elab (Msg, Loc); + end Error; + + El : Iir; + begin + -- Check generics. + El := Get_Generic_Chain (Entity); + while El /= Null_Iir loop + if Get_Default_Value (El) = Null_Iir then + Error ("(" & Disp_Node (El) & " has no default value)", El); + end if; + El := Get_Chain (El); + end loop; + + -- Check port. + El := Get_Port_Chain (Entity); + while El /= Null_Iir loop + if not Is_Fully_Constrained_Type (Get_Type (El)) + and then Get_Default_Value (El) = Null_Iir + then + Error ("(" & Disp_Node (El) + & " is unconstrained and has no default value)", El); + end if; + El := Get_Chain (El); + end loop; + end Check_Entity_Declaration_Top; +end Configuration; diff --git a/src/vhdl/configuration.ads b/src/vhdl/configuration.ads new file mode 100644 index 000000000..0a19a23c2 --- /dev/null +++ b/src/vhdl/configuration.ads @@ -0,0 +1,55 @@ +-- Configuration generation. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Iirs; use Iirs; +with GNAT.Table; + +package Configuration is + package Design_Units is new GNAT.Table + (Table_Component_Type => Iir_Design_Unit, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 16, + Table_Increment => 100); + + -- Get the top configuration to build a design hierarchy whose top is + -- PRIMARY + SECONDARY. + -- PRIMARY must designate a configuration declaration or an entity + -- declaration. In the last case, SECONDARY must be null_identifier or + -- designates an architecture declaration. + -- + -- creates a list of design unit. + -- and return the top configuration. + -- Note: this set the Elab_Flag on units. + function Configure (Primary_Id : Name_Id; Secondary_Id : Name_Id) + return Iir; + + -- Add design unit UNIT (with its dependences) in the design_units table. + procedure Add_Design_Unit (Unit : Iir_Design_Unit; From : Iir); + + -- If set, all design units (even package bodies) are loaded. + Flag_Load_All_Design_Units : Boolean := True; + + Flag_Build_File_Dependence : Boolean := False; + + -- Check if ENTITY can be at the top of a hierarchy, ie: + -- ENTITY has no generics or all generics have a default expression + -- ENTITY has no ports or all ports type are constrained. + -- If not, emit a elab error message. + procedure Check_Entity_Declaration_Top (Entity : Iir_Entity_Declaration); +end Configuration; diff --git a/src/vhdl/disp_tree.adb b/src/vhdl/disp_tree.adb new file mode 100644 index 000000000..fbaaa939b --- /dev/null +++ b/src/vhdl/disp_tree.adb @@ -0,0 +1,511 @@ +-- Node displaying (for debugging). +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +-- Display trees in raw form. Mainly used for debugging. + +with Ada.Text_IO; use Ada.Text_IO; +with Name_Table; +with Str_Table; +with Tokens; +with Errorout; +with Files_Map; +with PSL.Dump_Tree; +with Nodes_Meta; + +-- Do not add a use clause for iirs_utils, as it may crash for ill-formed +-- trees, which is annoying while debugging. + +package body Disp_Tree is + -- function Is_Anonymous_Type_Definition (Def : Iir) return Boolean + -- renames Iirs_Utils.Is_Anonymous_Type_Definition; + + procedure Disp_Iir (N : Iir; + Indent : Natural := 1; + Flat : Boolean := False); + procedure Disp_Header (N : Iir); + + procedure Disp_Tree_List_Flat (Tree_List: Iir_List; Tab: Natural); + pragma Unreferenced (Disp_Tree_List_Flat); + + procedure Put_Indent (Tab: Natural) is + Blanks : constant String (1 .. 2 * Tab) := (others => ' '); + begin + Put (Blanks); + end Put_Indent; + + procedure Disp_Iir_Number (Node: Iir) + is + Res : String (1 .. 10) := " ]"; + N : Int32 := Int32 (Node); + begin + for I in reverse 2 .. 9 loop + Res (I) := Character'Val (Character'Pos ('0') + (N mod 10)); + N := N / 10; + if N = 0 then + Res (I - 1) := '['; + Put (Res (I - 1 .. Res'Last)); + return; + end if; + end loop; + Put (Res); + end Disp_Iir_Number; + + -- For iir. + + procedure Disp_Tree_Flat (Tree: Iir; Tab: Natural) is + begin + Disp_Iir (Tree, Tab, True); + end Disp_Tree_Flat; + + procedure Disp_Iir_List + (Tree_List : Iir_List; Tab : Natural := 0; Flat : Boolean := False) + is + El: Iir; + begin + if Tree_List = Null_Iir_List then + Put_Line ("null-list"); + elsif Tree_List = Iir_List_All then + Put_Line ("list-all"); + elsif Tree_List = Iir_List_Others then + Put_Line ("list-others"); + else + New_Line; + for I in Natural loop + El := Get_Nth_Element (Tree_List, I); + exit when El = Null_Iir; + Put_Indent (Tab); + Disp_Iir (El, Tab + 1, Flat); + end loop; + end if; + end Disp_Iir_List; + + procedure Disp_Chain + (Tree_Chain: Iir; Indent: Natural; Flat : Boolean := False) + is + El: Iir; + begin + New_Line; + El := Tree_Chain; + while El /= Null_Iir loop + Put_Indent (Indent); + Disp_Iir (El, Indent + 1, Flat); + El := Get_Chain (El); + end loop; + end Disp_Chain; + + procedure Disp_Tree_Flat_Chain (Tree_Chain: Iir; Tab: Natural) + is + El: Iir; + begin + El := Tree_Chain; + while El /= Null_Iir loop + Disp_Iir (El, Tab, True); + El := Get_Chain (El); + end loop; + end Disp_Tree_Flat_Chain; + pragma Unreferenced (Disp_Tree_Flat_Chain); + + procedure Disp_Tree_List_Flat (Tree_List: Iir_List; Tab: Natural) + is + El: Iir; + begin + if Tree_List = Null_Iir_List then + Put_Indent (Tab); + Put_Line (" null-list"); + elsif Tree_List = Iir_List_All then + Put_Indent (Tab); + Put_Line (" list-all"); + elsif Tree_List = Iir_List_Others then + Put_Indent (Tab); + Put_Line (" list-others"); + else + for I in Natural loop + El := Get_Nth_Element (Tree_List, I); + exit when El = Null_Iir; + Disp_Tree_Flat (El, Tab); + end loop; + end if; + end Disp_Tree_List_Flat; + + function Image_Name_Id (Ident: Name_Id) return String + is + use Name_Table; + begin + if Ident /= Null_Identifier then + Image (Ident); + return ''' & Name_Buffer (1 .. Name_Length) & '''; + else + return "<anonymous>"; + end if; + end Image_Name_Id; + + function Image_Iir_Staticness (Static: Iir_Staticness) return String is + begin + case Static is + when Unknown => + return "???"; + when None => + return "none"; + when Globally => + return "global"; + when Locally => + return "local"; + end case; + end Image_Iir_Staticness; + + function Image_Boolean (Bool : Boolean) return String is + begin + if Bool then + return "true"; + else + return "false"; + end if; + end Image_Boolean; + + function Image_Iir_Delay_Mechanism (Mech : Iir_Delay_Mechanism) + return String is + begin + case Mech is + when Iir_Inertial_Delay => + return "inertial"; + when Iir_Transport_Delay => + return "transport"; + end case; + end Image_Iir_Delay_Mechanism; + + function Image_Iir_Lexical_Layout_Type (V : Iir_Lexical_Layout_Type) + return String is + begin + if (V and Iir_Lexical_Has_Mode) /= 0 then + return " +mode" + & Image_Iir_Lexical_Layout_Type (V and not Iir_Lexical_Has_Mode); + elsif (V and Iir_Lexical_Has_Class) /= 0 then + return " +class" + & Image_Iir_Lexical_Layout_Type (V and not Iir_Lexical_Has_Class); + elsif (V and Iir_Lexical_Has_Type) /= 0 then + return " +type" + & Image_Iir_Lexical_Layout_Type (V and not Iir_Lexical_Has_Type); + else + return ""; + end if; + end Image_Iir_Lexical_Layout_Type; + + function Image_Iir_Mode (Mode : Iir_Mode) return String is + begin + case Mode is + when Iir_Unknown_Mode => + return "???"; + when Iir_Linkage_Mode => + return "linkage"; + when Iir_Buffer_Mode => + return "buffer"; + when Iir_Out_Mode => + return "out"; + when Iir_Inout_Mode => + return "inout"; + when Iir_In_Mode => + return "in"; + end case; + end Image_Iir_Mode; + + function Image_Iir_Signal_Kind (Kind : Iir_Signal_Kind) return String is + begin + case Kind is + when Iir_No_Signal_Kind => + return "no"; + when Iir_Register_Kind => + return "register"; + when Iir_Bus_Kind => + return "bus"; + end case; + end Image_Iir_Signal_Kind; + + function Image_Iir_Pure_State (State : Iir_Pure_State) return String is + begin + case State is + when Pure => + return "pure"; + when Impure => + return "impure"; + when Maybe_Impure => + return "maybe_impure"; + when Unknown => + return "unknown"; + end case; + end Image_Iir_Pure_State; + + function Image_Iir_All_Sensitized (Sig : Iir_All_Sensitized) + return String is + begin + case Sig is + when Unknown => + return "???"; + when No_Signal => + return "no_signal"; + when Read_Signal => + return "read_signal"; + when Invalid_Signal => + return "invalid_signal"; + end case; + end Image_Iir_All_Sensitized; + + function Image_Iir_Constraint (Const : Iir_Constraint) return String is + begin + case Const is + when Unconstrained => + return "unconstrained"; + when Partially_Constrained => + return "partially constrained"; + when Fully_Constrained => + return "fully constrained"; + end case; + end Image_Iir_Constraint; + + function Image_Date_State_Type (State : Date_State_Type) return String is + begin + case State is + when Date_Extern => + return "extern"; + when Date_Disk => + return "disk"; + when Date_Parse => + return "parse"; + when Date_Analyze => + return "analyze"; + end case; + end Image_Date_State_Type; + + function Image_Tri_State_Type (State : Tri_State_Type) return String is + begin + case State is + when True => + return "true"; + when False => + return "false"; + when Unknown => + return "unknown"; + end case; + end Image_Tri_State_Type; + + function Image_Time_Stamp_Id (Id : Time_Stamp_Id) return String + renames Files_Map.Get_Time_Stamp_String; + + function Image_Iir_Predefined_Functions (F : Iir_Predefined_Functions) + return String is + begin + return Iir_Predefined_Functions'Image (F); + end Image_Iir_Predefined_Functions; + + function Image_String_Id (S : String_Id) return String + renames Str_Table.Image; + + procedure Disp_PSL_Node (N : PSL_Node; Indent : Natural) is + begin + Put_Indent (Indent); + PSL.Dump_Tree.Dump_Tree (N, True); + end Disp_PSL_Node; + + procedure Disp_PSL_NFA (N : PSL_NFA; Indent : Natural) is + begin + null; + end Disp_PSL_NFA; + + function Image_Location_Type (Loc : Location_Type) return String is + begin + return Errorout.Get_Location_Str (Loc); + end Image_Location_Type; + + function Image_Iir_Direction (Dir : Iir_Direction) return String is + begin + case Dir is + when Iir_To => + return "to"; + when Iir_Downto => + return "downto"; + end case; + end Image_Iir_Direction; + + function Image_Token_Type (Tok : Tokens.Token_Type) return String + renames Tokens.Image; + + procedure Header (Str : String; Indent : Natural) is + begin + Put_Indent (Indent); + Put (Str); + Put (": "); + end Header; + + procedure Disp_Header (N : Iir) + is + use Nodes_Meta; + K : Iir_Kind; + begin + if N = Null_Iir then + Put_Line ("*null*"); + return; + end if; + + K := Get_Kind (N); + Put (Get_Iir_Image (K)); + if Has_Identifier (K) then + Put (' '); + Put (Image_Name_Id (Get_Identifier (N))); + end if; + + Put (' '); + Disp_Iir_Number (N); + + New_Line; + end Disp_Header; + + procedure Disp_Iir (N : Iir; + Indent : Natural := 1; + Flat : Boolean := False) + is + Sub_Indent : constant Natural := Indent + 1; + begin + Disp_Header (N); + + if Flat or else N = Null_Iir then + return; + end if; + + Header ("location", Indent); + Put_Line (Image_Location_Type (Get_Location (N))); + + -- Protect against infinite recursions. + if Indent > 20 then + Put_Indent (Indent); + Put_Line ("..."); + return; + end if; + + declare + use Nodes_Meta; + Fields : constant Fields_Array := Get_Fields (Get_Kind (N)); + F : Fields_Enum; + begin + for I in Fields'Range loop + F := Fields (I); + Header (Get_Field_Image (F), Indent); + case Get_Field_Type (F) is + when Type_Iir => + case Get_Field_Attribute (F) is + when Attr_None => + Disp_Iir (Get_Iir (N, F), Sub_Indent); + when Attr_Ref => + Disp_Iir (Get_Iir (N, F), Sub_Indent, True); + when Attr_Maybe_Ref => + Disp_Iir (Get_Iir (N, F), Sub_Indent, Get_Is_Ref (N)); + when Attr_Chain => + Disp_Chain (Get_Iir (N, F), Sub_Indent); + when Attr_Chain_Next => + Disp_Iir_Number (Get_Iir (N, F)); + New_Line; + when Attr_Of_Ref => + raise Internal_Error; + end case; + when Type_Iir_List => + Disp_Iir_List (Get_Iir_List (N, F), Sub_Indent, + Get_Field_Attribute (F) = Attr_Of_Ref); + when Type_PSL_NFA => + Disp_PSL_NFA (Get_PSL_NFA (N, F), Sub_Indent); + when Type_String_Id => + Put_Line (Image_String_Id (Get_String_Id (N, F))); + when Type_PSL_Node => + Disp_PSL_Node (Get_PSL_Node (N, F), Sub_Indent); + when Type_Source_Ptr => + Put_Line (Source_Ptr'Image (Get_Source_Ptr (N, F))); + when Type_Date_Type => + Put_Line (Date_Type'Image (Get_Date_Type (N, F))); + when Type_Base_Type => + Put_Line (Base_Type'Image (Get_Base_Type (N, F))); + when Type_Iir_Constraint => + Put_Line (Image_Iir_Constraint + (Get_Iir_Constraint (N, F))); + when Type_Iir_Mode => + Put_Line (Image_Iir_Mode (Get_Iir_Mode (N, F))); + when Type_Iir_Index32 => + Put_Line (Iir_Index32'Image (Get_Iir_Index32 (N, F))); + when Type_Iir_Int64 => + Put_Line (Iir_Int64'Image (Get_Iir_Int64 (N, F))); + when Type_Boolean => + Put_Line (Image_Boolean + (Get_Boolean (N, F))); + when Type_Iir_Staticness => + Put_Line (Image_Iir_Staticness + (Get_Iir_Staticness (N, F))); + when Type_Date_State_Type => + Put_Line (Image_Date_State_Type + (Get_Date_State_Type (N, F))); + when Type_Iir_All_Sensitized => + Put_Line (Image_Iir_All_Sensitized + (Get_Iir_All_Sensitized (N, F))); + when Type_Iir_Signal_Kind => + Put_Line (Image_Iir_Signal_Kind + (Get_Iir_Signal_Kind (N, F))); + when Type_Tri_State_Type => + Put_Line (Image_Tri_State_Type + (Get_Tri_State_Type (N, F))); + when Type_Iir_Pure_State => + Put_Line (Image_Iir_Pure_State + (Get_Iir_Pure_State (N, F))); + when Type_Iir_Delay_Mechanism => + Put_Line (Image_Iir_Delay_Mechanism + (Get_Iir_Delay_Mechanism (N, F))); + when Type_Iir_Lexical_Layout_Type => + Put_Line (Image_Iir_Lexical_Layout_Type + (Get_Iir_Lexical_Layout_Type (N, F))); + when Type_Iir_Predefined_Functions => + Put_Line (Image_Iir_Predefined_Functions + (Get_Iir_Predefined_Functions (N, F))); + when Type_Iir_Direction => + Put_Line (Image_Iir_Direction + (Get_Iir_Direction (N, F))); + when Type_Location_Type => + Put_Line (Image_Location_Type + (Get_Location_Type (N, F))); + when Type_Iir_Int32 => + Put_Line (Iir_Int32'Image (Get_Iir_Int32 (N, F))); + when Type_Int32 => + Put_Line (Int32'Image (Get_Int32 (N, F))); + when Type_Iir_Fp64 => + Put_Line (Iir_Fp64'Image (Get_Iir_Fp64 (N, F))); + when Type_Time_Stamp_Id => + Put_Line (Image_Time_Stamp_Id + (Get_Time_Stamp_Id (N, F))); + when Type_Token_Type => + Put_Line (Image_Token_Type (Get_Token_Type (N, F))); + when Type_Name_Id => + Put_Line (Image_Name_Id (Get_Name_Id (N, F))); + end case; + end loop; + end; + end Disp_Iir; + + procedure Disp_Tree_For_Psl (N : Int32) is + begin + Disp_Tree_Flat (Iir (N), 1); + end Disp_Tree_For_Psl; + + procedure Disp_Tree (Tree : Iir; + Flat : Boolean := false) is + begin + Disp_Iir (Tree, 1, Flat); + end Disp_Tree; +end Disp_Tree; diff --git a/src/vhdl/disp_tree.ads b/src/vhdl/disp_tree.ads new file mode 100644 index 000000000..94b1d29e3 --- /dev/null +++ b/src/vhdl/disp_tree.ads @@ -0,0 +1,27 @@ +-- Node displaying (for debugging). +-- Copyright (C) 2002, 2003, 2004, 2005, 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Iirs; use Iirs; + +package Disp_Tree is + -- Disp TREE recursively. + procedure Disp_Tree (Tree : Iir; + Flat : Boolean := False); + + procedure Disp_Tree_For_Psl (N : Int32); +end Disp_Tree; diff --git a/src/vhdl/disp_vhdl.adb b/src/vhdl/disp_vhdl.adb new file mode 100644 index 000000000..73a8e420f --- /dev/null +++ b/src/vhdl/disp_vhdl.adb @@ -0,0 +1,3247 @@ +-- VHDL regeneration from internal nodes. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +-- Re-print a tree as VHDL sources. Except for comments and parenthesis, the +-- sequence of tokens displayed is the same as the sequence of tokens in the +-- input file. If parenthesis are kept by the parser, the only differences +-- are comments and layout. +with GNAT.OS_Lib; +with Std_Package; +with Flags; use Flags; +with Errorout; use Errorout; +with Iirs_Utils; use Iirs_Utils; +with Name_Table; +with Std_Names; +with Tokens; +with PSL.Nodes; +with PSL.Prints; +with PSL.NFAs; + +package body Disp_Vhdl is + + subtype Count is Positive; + + Col : Count := 1; + + IO_Error : exception; + + -- Disp the name of DECL. + procedure Disp_Name_Of (Decl: Iir); + + -- Indentation for nested declarations and statements. + Indentation: constant Count := 2; + + -- Line length (used to try to have a nice display). + Line_Length : constant Count := 80; + + -- If True, display extra parenthesis to make priority of operators + -- explicit. + Flag_Parenthesis : constant Boolean := False; + + -- If set, disp after a string literal the type enclosed into brackets. + Disp_String_Literal_Type: constant Boolean := False; + + -- If set, disp position number of associations + --Disp_Position_Number: constant Boolean := False; + +-- procedure Disp_Tab (Tab: Natural) is +-- Blanks : String (1 .. Tab) := (others => ' '); +-- begin +-- Put (Blanks); +-- end Disp_Tab; + + procedure Disp_Type (A_Type: Iir); + procedure Disp_Nature (Nature : Iir); + procedure Disp_Range (Rng : Iir); + + procedure Disp_Concurrent_Statement (Stmt: Iir); + procedure Disp_Concurrent_Statement_Chain (Parent: Iir; Indent : Count); + procedure Disp_Declaration_Chain (Parent : Iir; Indent: Count); + procedure Disp_Process_Statement (Process: Iir); + procedure Disp_Sequential_Statements (First : Iir); + procedure Disp_Choice (Choice: in out Iir); + procedure Disp_Association_Chain (Chain : Iir); + procedure Disp_Block_Configuration + (Block: Iir_Block_Configuration; Indent: Count); + procedure Disp_Subprogram_Declaration (Subprg: Iir); + procedure Disp_Binding_Indication (Bind : Iir; Indent : Count); + procedure Disp_Subtype_Indication (Def : Iir; Full_Decl : Boolean := False); + procedure Disp_Parametered_Attribute (Name : String; Expr : Iir); + + procedure Put (Str : String) + is + use GNAT.OS_Lib; + Len : constant Natural := Str'Length; + begin + if Write (Standout, Str'Address, Len) /= Len then + raise IO_Error; + end if; + Col := Col + Len; + end Put; + + procedure Put (C : Character) is + begin + Put ((1 => C)); + end Put; + + procedure New_Line is + begin + Put (ASCII.LF); + Col := 1; + end New_Line; + + procedure Put_Line (Str : String) is + begin + Put (Str); + New_Line; + end Put_Line; + + procedure Set_Col (P : Count) is + begin + if Col = P then + return; + end if; + if Col >= P then + New_Line; + end if; + Put ((Col .. P - 1 => ' ')); + end Set_Col; + + procedure Disp_Ident (Id: Name_Id) is + begin + Put (Name_Table.Image (Id)); + end Disp_Ident; + + procedure Disp_Identifier (Node : Iir) + is + Ident : Name_Id; + begin + Ident := Get_Identifier (Node); + if Ident /= Null_Identifier then + Disp_Ident (Ident); + else + Put ("<anonymous>"); + end if; + end Disp_Identifier; + + procedure Disp_Character_Literal (Lit: Iir_Character_Literal) is + begin + Put (''' & Name_Table.Get_Character (Get_Identifier (Lit)) & '''); + end Disp_Character_Literal; + + procedure Disp_Function_Name (Func: Iir) + is + use Name_Table; + use Std_Names; + Id: Name_Id; + begin + Id := Get_Identifier (Func); + case Id is + when Name_Id_Operators + | Name_Word_Operators + | Name_Xnor + | Name_Shift_Operators => + Put (""""); + Put (Image (Id)); + Put (""""); + when others => + Disp_Ident (Id); + end case; + end Disp_Function_Name; + + -- Disp the name of DECL. + procedure Disp_Name_Of (Decl: Iir) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Component_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Type_Declaration + | 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 + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Library_Declaration + | Iir_Kind_Unit_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kinds_Quantity_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Character_Literal + | Iir_Kinds_Process_Statement => + Disp_Identifier (Decl); + when Iir_Kind_Anonymous_Type_Declaration => + Put ('<'); + Disp_Ident (Get_Identifier (Decl)); + Put ('>'); + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration => + Disp_Function_Name (Decl); + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + Disp_Identifier (Decl); + when Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Protected_Type_Declaration => + -- Used for 'end' DECL_NAME. + Disp_Identifier (Get_Type_Declarator (Decl)); + when Iir_Kind_Component_Instantiation_Statement => + Disp_Ident (Get_Label (Decl)); + when Iir_Kind_Design_Unit => + Disp_Name_Of (Get_Library_Unit (Decl)); + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Simple_Name => + Disp_Identifier (Decl); + when Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + declare + Ident : constant Name_Id := Get_Label (Decl); + begin + if Ident /= Null_Identifier then + Disp_Ident (Ident); + else + Put ("<anonymous>"); + end if; + end; + when Iir_Kind_Package_Body => + Disp_Identifier (Get_Package (Decl)); + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + Disp_Function_Name (Get_Subprogram_Specification (Decl)); + when Iir_Kind_Protected_Type_Body => + Disp_Identifier + (Get_Type_Declarator (Get_Protected_Type_Declaration (Decl))); + when others => + Error_Kind ("disp_name_of", Decl); + end case; + end Disp_Name_Of; + + procedure Disp_Name (Name: Iir) is + begin + case Get_Kind (Name) is + when Iir_Kind_Selected_By_All_Name => + Disp_Name (Get_Prefix (Name)); + Put (".all"); + when Iir_Kind_Dereference => + Disp_Name (Get_Prefix (Name)); + Put (".all"); + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal => + Put (Iirs_Utils.Image_Identifier (Name)); + when Iir_Kind_Operator_Symbol => + Disp_Function_Name (Name); + when Iir_Kind_Selected_Name => + Disp_Name (Get_Prefix (Name)); + Put ("."); + Disp_Function_Name (Name); + when Iir_Kind_Parenthesis_Name => + Disp_Name (Get_Prefix (Name)); + Disp_Association_Chain (Get_Association_Chain (Name)); + when Iir_Kind_Base_Attribute => + Disp_Name (Get_Prefix (Name)); + Put ("'base"); + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kinds_Interface_Object_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Group_Template_Declaration => + Disp_Name_Of (Name); + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Disp_Range (Name); + when others => + Error_Kind ("disp_name", Name); + end case; + end Disp_Name; + + procedure Disp_Range (Rng : Iir) is + begin + case Get_Kind (Rng) is + when Iir_Kind_Range_Expression => + declare + Origin : constant Iir := Get_Range_Origin (Rng); + begin + if Origin /= Null_Iir then + Disp_Expression (Origin); + else + Disp_Expression (Get_Left_Limit (Rng)); + if Get_Direction (Rng) = Iir_To then + Put (" to "); + else + Put (" downto "); + end if; + Disp_Expression (Get_Right_Limit (Rng)); + end if; + end; + when Iir_Kind_Range_Array_Attribute => + Disp_Parametered_Attribute ("range", Rng); + when Iir_Kind_Reverse_Range_Array_Attribute => + Disp_Parametered_Attribute ("reverse_range", Rng); + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Disp_Name (Rng); + when others => + Disp_Subtype_Indication (Rng); + -- Disp_Name_Of (Get_Type_Declarator (Decl)); + end case; + end Disp_Range; + + procedure Disp_After_End (Decl : Iir; Name : String) is + begin + if Get_End_Has_Reserved_Id (Decl) then + Put (' '); + Put (Name); + end if; + if Get_End_Has_Identifier (Decl) then + Put (' '); + Disp_Name_Of (Decl); + end if; + Put (';'); + New_Line; + end Disp_After_End; + + procedure Disp_End (Decl : Iir; Name : String) is + begin + Put ("end"); + Disp_After_End (Decl, Name); + end Disp_End; + + procedure Disp_End_Label (Stmt : Iir; Name : String) is + begin + Put ("end"); + Put (' '); + Put (Name); + if Get_End_Has_Identifier (Stmt) then + Put (' '); + Disp_Ident (Get_Label (Stmt)); + end if; + Put (';'); + New_Line; + end Disp_End_Label; + + procedure Disp_Use_Clause (Clause: Iir_Use_Clause) + is + Name : Iir; + begin + Put ("use "); + Name := Clause; + loop + Disp_Name (Get_Selected_Name (Name)); + Name := Get_Use_Clause_Chain (Name); + exit when Name = Null_Iir; + Put (", "); + end loop; + Put_Line (";"); + end Disp_Use_Clause; + + -- Disp the resolution function (if any) of type definition DEF. + procedure Disp_Resolution_Indication (Subtype_Def: Iir) + is + procedure Inner (Ind : Iir) is + begin + case Get_Kind (Ind) is + when Iir_Kinds_Denoting_Name => + Disp_Name (Ind); + when Iir_Kind_Array_Element_Resolution => + Put ("("); + Inner (Get_Resolution_Indication (Ind)); + Put (")"); + when others => + Error_Kind ("disp_resolution_indication", Ind); + end case; + end Inner; + + Ind : Iir; + begin + case Get_Kind (Subtype_Def) is + when Iir_Kind_Access_Subtype_Definition => + -- No resolution indication on access subtype. + return; + when others => + Ind := Get_Resolution_Indication (Subtype_Def); + if Ind = Null_Iir then + -- No resolution indication. + return; + end if; + end case; + + declare + Type_Mark : constant Iir := Get_Denoted_Type_Mark (Subtype_Def); + begin + if Get_Kind (Type_Mark) in Iir_Kinds_Subtype_Definition + and then Get_Resolution_Indication (Type_Mark) = Ind + then + -- Resolution indication was inherited from the type_mark. + return; + end if; + end; + + Inner (Ind); + Put (" "); + end Disp_Resolution_Indication; + + procedure Disp_Integer_Subtype_Definition + (Def: Iir_Integer_Subtype_Definition) + is + Base_Type: Iir_Integer_Type_Definition; + Decl: Iir; + begin + if Def /= Std_Package.Universal_Integer_Subtype_Definition then + Base_Type := Get_Base_Type (Def); + Decl := Get_Type_Declarator (Base_Type); + if Base_Type /= Std_Package.Universal_Integer_Subtype_Definition + and then Def /= Decl + then + Disp_Name_Of (Decl); + Put (" "); + end if; + end if; + Disp_Resolution_Indication (Def); + Put ("range "); + Disp_Expression (Get_Range_Constraint (Def)); + Put (";"); + end Disp_Integer_Subtype_Definition; + + procedure Disp_Floating_Subtype_Definition + (Def: Iir_Floating_Subtype_Definition) + is + Base_Type: Iir_Floating_Type_Definition; + Decl: Iir; + begin + if Def /= Std_Package.Universal_Real_Subtype_Definition then + Base_Type := Get_Base_Type (Def); + Decl := Get_Type_Declarator (Base_Type); + if Base_Type /= Std_Package.Universal_Real_Subtype_Definition + and then Def /= Decl + then + Disp_Name_Of (Decl); + Put (" "); + end if; + end if; + Disp_Resolution_Indication (Def); + Put ("range "); + Disp_Expression (Get_Range_Constraint (Def)); + Put (";"); + end Disp_Floating_Subtype_Definition; + + procedure Disp_Element_Constraint (Def : Iir; Type_Mark : Iir); + + procedure Disp_Array_Element_Constraint (Def : Iir; Type_Mark : Iir) + is + Def_El : constant Iir := Get_Element_Subtype (Def); + Tm_El : constant Iir := Get_Element_Subtype (Type_Mark); + Has_Index : constant Boolean := Get_Index_Constraint_Flag (Def); + Has_Own_Element_Subtype : constant Boolean := Def_El /= Tm_El; + Index : Iir; + begin + if not Has_Index and not Has_Own_Element_Subtype then + return; + end if; + + if Get_Constraint_State (Type_Mark) /= Fully_Constrained + and then Has_Index + then + 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 (Index); + end loop; + Put (")"); + end if; + + 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_Tolerance_Opt (N : Iir) is + Tol : constant Iir := Get_Tolerance (N); + begin + if Tol /= Null_Iir then + Put ("tolerance "); + Disp_Expression (Tol); + end if; + end Disp_Tolerance_Opt; + + procedure Disp_Subtype_Indication (Def : Iir; Full_Decl : Boolean := False) + is + Type_Mark : Iir; + Base_Type : Iir; + Decl : Iir; + begin + if Get_Kind (Def) in Iir_Kinds_Denoting_Name then + Disp_Name (Def); + return; + end if; + + Decl := Get_Type_Declarator (Def); + if not Full_Decl and then Decl /= Null_Iir then + Disp_Name_Of (Decl); + return; + end if; + + -- Resolution function name. + Disp_Resolution_Indication (Def); + + -- type mark. + Type_Mark := Get_Subtype_Type_Mark (Def); + if Type_Mark /= Null_Iir then + Disp_Name (Type_Mark); + Type_Mark := Get_Type (Type_Mark); + end if; + + Base_Type := Get_Base_Type (Def); + case Get_Kind (Base_Type) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + if Type_Mark = Null_Iir + or else Get_Range_Constraint (Def) + /= Get_Range_Constraint (Type_Mark) + then + if Type_Mark /= Null_Iir then + Put (" range "); + end if; + Disp_Expression (Get_Range_Constraint (Def)); + end if; + if Get_Kind (Base_Type) = Iir_Kind_Floating_Type_Definition then + Disp_Tolerance_Opt (Def); + end if; + when Iir_Kind_Access_Type_Definition => + declare + Des_Ind : constant Iir := + Get_Designated_Subtype_Indication (Def); + begin + if Des_Ind /= Null_Iir then + pragma Assert + (Get_Kind (Des_Ind) = Iir_Kind_Array_Subtype_Definition); + Disp_Array_Element_Constraint + (Des_Ind, Get_Designated_Type (Base_Type)); + end if; + end; + when Iir_Kind_Array_Type_Definition => + if Type_Mark = Null_Iir then + Disp_Array_Element_Constraint (Def, Def); + else + Disp_Array_Element_Constraint (Def, Type_Mark); + end if; + when Iir_Kind_Record_Type_Definition => + Disp_Record_Element_Constraint (Def); + when others => + Error_Kind ("disp_subtype_indication", Base_Type); + end case; + end Disp_Subtype_Indication; + + procedure Disp_Enumeration_Type_Definition + (Def: Iir_Enumeration_Type_Definition) + is + Len : Count; + Start_Col: Count; + Decl: Name_Id; + A_Lit: Iir; --Enumeration_Literal_Acc; + begin + for I in Natural loop + A_Lit := Get_Nth_Element (Get_Enumeration_Literal_List (Def), I); + exit when A_Lit = Null_Iir; + if I = Natural'first then + Put ("("); + Start_Col := Col; + else + Put (", "); + end if; + Decl := Get_Identifier (A_Lit); + if Name_Table.Is_Character (Decl) then + Len := 3; + else + Len := Count (Name_Table.Get_Name_Length (Decl)); + end if; + if Col + Len + 2 > Line_Length then + New_Line; + Set_Col (Start_Col); + end if; + Disp_Name_Of (A_Lit); + end loop; + Put (");"); + end Disp_Enumeration_Type_Definition; + + procedure Disp_Enumeration_Subtype_Definition + (Def: Iir_Enumeration_Subtype_Definition) + is + begin + Disp_Resolution_Indication (Def); + Put ("range "); + Disp_Range (Def); + Put (";"); + end Disp_Enumeration_Subtype_Definition; + + procedure Disp_Discrete_Range (Iterator: Iir) is + begin + if Get_Kind (Iterator) in Iir_Kinds_Subtype_Definition then + Disp_Subtype_Indication (Iterator); + else + Disp_Range (Iterator); + end if; + end Disp_Discrete_Range; + + procedure Disp_Array_Subtype_Definition (Def: Iir_Array_Subtype_Definition) + is + Index: Iir; + begin + Disp_Resolution_Indication (Def); + + Put ("array ("); + 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_Discrete_Range (Index); + end loop; + Put (") of "); + Disp_Subtype_Indication (Get_Element_Subtype (Def)); + end Disp_Array_Subtype_Definition; + + procedure Disp_Array_Type_Definition (Def: Iir_Array_Type_Definition) is + Index: Iir; + begin + Put ("array ("); + 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_Name (Index); + Put (" range <>"); + end loop; + Put (") of "); + Disp_Subtype_Indication (Get_Element_Subtype_Indication (Def)); + Put (";"); + end Disp_Array_Type_Definition; + + procedure Disp_Physical_Literal (Lit: Iir) is + begin + case Get_Kind (Lit) is + when Iir_Kind_Physical_Int_Literal => + Disp_Int64 (Get_Value (Lit)); + when Iir_Kind_Physical_Fp_Literal => + Disp_Fp64 (Get_Fp_Value (Lit)); + when Iir_Kind_Unit_Declaration => + Disp_Identifier (Lit); + return; + when others => + Error_Kind ("disp_physical_literal", Lit); + end case; + Put (' '); + Disp_Name (Get_Unit_Name (Lit)); + end Disp_Physical_Literal; + + procedure Disp_Physical_Subtype_Definition + (Def: Iir_Physical_Subtype_Definition) is + begin + Disp_Resolution_Indication (Def); + Put ("range "); + Disp_Expression (Get_Range_Constraint (Def)); + end Disp_Physical_Subtype_Definition; + + procedure Disp_Record_Type_Definition + (Def: Iir_Record_Type_Definition; Indent: Count) + is + List : Iir_List; + El: Iir_Element_Declaration; + Reindent : Boolean; + begin + Put_Line ("record"); + Set_Col (Indent); + List := Get_Elements_Declaration_List (Def); + Reindent := True; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if Reindent then + Set_Col (Indent + Indentation); + end if; + Disp_Identifier (El); + if Get_Has_Identifier_List (El) then + Put (", "); + Reindent := False; + else + Put (" : "); + Disp_Subtype_Indication (Get_Type (El)); + Put_Line (";"); + Reindent := True; + end if; + end loop; + Set_Col (Indent); + Disp_End (Def, "record"); + end Disp_Record_Type_Definition; + + procedure Disp_Designator_List (List: Iir_List) is + El: Iir; + begin + if List = Null_Iir_List then + return; + elsif List = Iir_List_All then + Put ("all"); + return; + end if; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if I > 0 then + Put (", "); + end if; + Disp_Expression (El); + --Disp_Text_Literal (El); + end loop; + end Disp_Designator_List; + + -- Display the full definition of a type, ie the sequence that can create + -- such a type. + procedure Disp_Type_Definition (Def: Iir; Indent: Count) is + begin + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition => + Disp_Enumeration_Type_Definition (Def); + when Iir_Kind_Enumeration_Subtype_Definition => + Disp_Enumeration_Subtype_Definition (Def); + when Iir_Kind_Integer_Subtype_Definition => + Disp_Integer_Subtype_Definition (Def); + when Iir_Kind_Floating_Subtype_Definition => + Disp_Floating_Subtype_Definition (Def); + when Iir_Kind_Array_Type_Definition => + Disp_Array_Type_Definition (Def); + when Iir_Kind_Array_Subtype_Definition => + Disp_Array_Subtype_Definition (Def); + when Iir_Kind_Physical_Subtype_Definition => + Disp_Physical_Subtype_Definition (Def); + when Iir_Kind_Record_Type_Definition => + Disp_Record_Type_Definition (Def, Indent); + when Iir_Kind_Access_Type_Definition => + Put ("access "); + Disp_Subtype_Indication (Get_Designated_Subtype_Indication (Def)); + Put (';'); + when Iir_Kind_File_Type_Definition => + Put ("file of "); + Disp_Subtype_Indication (Get_File_Type_Mark (Def)); + Put (';'); + when Iir_Kind_Protected_Type_Declaration => + Put_Line ("protected"); + Disp_Declaration_Chain (Def, Indent + Indentation); + Set_Col (Indent); + Disp_End (Def, "protected"); + when Iir_Kind_Integer_Type_Definition => + Put ("<integer base type>"); + when Iir_Kind_Floating_Type_Definition => + Put ("<floating base type>"); + when Iir_Kind_Physical_Type_Definition => + Put ("<physical base type>"); + when others => + Error_Kind ("disp_type_definition", Def); + end case; + end Disp_Type_Definition; + + procedure Disp_Type_Declaration (Decl: Iir_Type_Declaration) + is + Indent: Count; + Def : Iir; + begin + Indent := Col; + Put ("type "); + Disp_Name_Of (Decl); + Def := Get_Type_Definition (Decl); + if Def = Null_Iir + or else Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition + then + Put_Line (";"); + else + Put (" is "); + Disp_Type_Definition (Def, Indent); + New_Line; + end if; + end Disp_Type_Declaration; + + procedure Disp_Anonymous_Type_Declaration + (Decl: Iir_Anonymous_Type_Declaration) + is + Def : constant Iir := Get_Type_Definition (Decl); + Indent: constant Count := Col; + begin + Put ("type "); + Disp_Identifier (Decl); + Put (" is "); + case Get_Kind (Def) is + when Iir_Kind_Array_Type_Definition => + declare + St : constant Iir := Get_Subtype_Definition (Decl); + Indexes : constant Iir_List := Get_Index_Subtype_List (St); + Index : Iir; + begin + Put ("array ("); + for I in Natural loop + Index := Get_Nth_Element (Indexes, I); + exit when Index = Null_Iir; + if I /= 0 then + Put (", "); + end if; + Disp_Discrete_Range (Index); + end loop; + Put (") of "); + Disp_Subtype_Indication (Get_Element_Subtype_Indication (Def)); + Put (";"); + end; + when Iir_Kind_Physical_Type_Definition => + declare + St : constant Iir := Get_Subtype_Definition (Decl); + Unit : Iir_Unit_Declaration; + begin + Put ("range "); + Disp_Expression (Get_Range_Constraint (St)); + Put_Line (" units"); + Set_Col (Indent + Indentation); + Unit := Get_Unit_Chain (Def); + Disp_Identifier (Unit); + Put_Line (";"); + Unit := Get_Chain (Unit); + while Unit /= Null_Iir loop + Set_Col (Indent + Indentation); + Disp_Identifier (Unit); + Put (" = "); + Disp_Expression (Get_Physical_Literal (Unit)); + Put_Line (";"); + Unit := Get_Chain (Unit); + end loop; + Set_Col (Indent); + Disp_End (Def, "units"); + end; + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Integer_Type_Definition => + declare + St : constant Iir := Get_Subtype_Definition (Decl); + begin + Put ("range "); + Disp_Expression (Get_Range_Constraint (St)); + Put (";"); + end; + when others => + Disp_Type_Definition (Def, Indent); + end case; + New_Line; + end Disp_Anonymous_Type_Declaration; + + procedure Disp_Subtype_Declaration (Decl: in Iir_Subtype_Declaration) + is + Def : constant Iir := Get_Type (Decl); + Bt_Decl : constant Iir := Get_Type_Declarator (Get_Base_Type (Def)); + begin + if Get_Identifier (Decl) = Get_Identifier (Bt_Decl) then + Put ("-- "); + end if; + Put ("subtype "); + Disp_Name_Of (Decl); + Put (" is "); + Disp_Subtype_Indication (Def, True); + Put_Line (";"); + end Disp_Subtype_Declaration; + + procedure Disp_Type (A_Type: Iir) + is + Decl: Iir; + begin + Decl := Get_Type_Declarator (A_Type); + if Decl /= Null_Iir then + Disp_Name_Of (Decl); + else + case Get_Kind (A_Type) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition => + raise Program_Error; + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition => + Disp_Subtype_Indication (A_Type); + when Iir_Kind_Array_Subtype_Definition => + Disp_Subtype_Indication (A_Type); + when others => + Error_Kind ("disp_type", A_Type); + end case; + end if; + end Disp_Type; + + procedure Disp_Nature_Definition (Def : Iir) is + begin + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + Disp_Subtype_Indication (Get_Across_Type (Def)); + Put (" across "); + Disp_Subtype_Indication (Get_Through_Type (Def)); + Put (" through "); + Disp_Name_Of (Get_Reference (Def)); + Put (" reference"); + when others => + Error_Kind ("disp_nature_definition", Def); + end case; + end Disp_Nature_Definition; + + procedure Disp_Nature_Declaration (Decl : Iir) is + begin + Put ("nature "); + Disp_Name_Of (Decl); + Put (" is "); + Disp_Nature_Definition (Get_Nature (Decl)); + Put_Line (";"); + end Disp_Nature_Declaration; + + procedure Disp_Nature (Nature : Iir) + is + Decl: Iir; + begin + Decl := Get_Nature_Declarator (Nature); + if Decl /= Null_Iir then + Disp_Name_Of (Decl); + else + Error_Kind ("disp_nature", Nature); + end if; + end Disp_Nature; + + procedure Disp_Mode (Mode: Iir_Mode) is + begin + case Mode is + when Iir_In_Mode => + Put ("in "); + when Iir_Out_Mode => + Put ("out "); + when Iir_Inout_Mode => + Put ("inout "); + when Iir_Buffer_Mode => + Put ("buffer "); + when Iir_Linkage_Mode => + Put ("linkage "); + when Iir_Unknown_Mode => + Put ("<unknown> "); + end case; + end Disp_Mode; + + procedure Disp_Signal_Kind (Kind: Iir_Signal_Kind) is + begin + case Kind is + when Iir_No_Signal_Kind => + null; + when Iir_Register_Kind => + Put (" register"); + when Iir_Bus_Kind => + Put (" bus"); + end case; + end Disp_Signal_Kind; + + procedure Disp_Interface_Class (Inter: Iir) is + begin + if (Get_Lexical_Layout (Inter) and Iir_Lexical_Has_Class) /= 0 then + case Get_Kind (Inter) is + when Iir_Kind_Interface_Signal_Declaration => + Put ("signal "); + when Iir_Kind_Interface_Variable_Declaration => + Put ("variable "); + when Iir_Kind_Interface_Constant_Declaration => + Put ("constant "); + when Iir_Kind_Interface_File_Declaration => + Put ("file "); + when others => + Error_Kind ("disp_interface_class", Inter); + end case; + end if; + end Disp_Interface_Class; + + procedure Disp_Interface_Mode_And_Type (Inter: Iir) + is + Default: constant Iir := Get_Default_Value (Inter); + Ind : constant Iir := Get_Subtype_Indication (Inter); + begin + Put (": "); + if (Get_Lexical_Layout (Inter) and Iir_Lexical_Has_Mode) /= 0 then + Disp_Mode (Get_Mode (Inter)); + end if; + if Ind = Null_Iir then + -- For implicit subprogram + Disp_Type (Get_Type (Inter)); + else + Disp_Subtype_Indication (Get_Subtype_Indication (Inter)); + end if; + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then + Disp_Signal_Kind (Get_Signal_Kind (Inter)); + end if; + if Default /= Null_Iir then + Put (" := "); + Disp_Expression (Default); + end if; + end Disp_Interface_Mode_And_Type; + + -- Disp interfaces, followed by END_STR (';' in general). + procedure Disp_Interface_Chain (Chain: Iir; + End_Str: String := ""; + Comment_Col : Natural := 0) + is + Inter: Iir; + Next_Inter : Iir; + Start: Count; + begin + if Chain = Null_Iir then + return; + end if; + Put (" ("); + Start := Col; + Inter := Chain; + loop + Next_Inter := Get_Chain (Inter); + Set_Col (Start); + + case Get_Kind (Inter) is + when Iir_Kinds_Interface_Object_Declaration => + Disp_Interface_Class (Inter); + Disp_Name_Of (Inter); + while (Get_Lexical_Layout (Inter) and Iir_Lexical_Has_Type) = 0 + loop + Put (", "); + Inter := Next_Inter; + Next_Inter := Get_Chain (Inter); + Disp_Name_Of (Inter); + end loop; + Disp_Interface_Mode_And_Type (Inter); + when Iir_Kind_Interface_Package_Declaration => + Put ("package "); + Disp_Identifier (Inter); + Put (" is new "); + Disp_Name (Get_Uninstantiated_Package_Name (Inter)); + Put (" generic map "); + declare + Assoc_Chain : constant Iir := + Get_Generic_Map_Aspect_Chain (Inter); + begin + if Assoc_Chain = Null_Iir then + Put ("(<>)"); + else + Disp_Association_Chain (Assoc_Chain); + end if; + end; + when others => + Error_Kind ("disp_interface_chain", Inter); + end case; + + if Next_Inter /= Null_Iir then + Put (";"); + if Comment_Col /= 0 then + New_Line; + Set_Col (Comment_Col); + Put ("--"); + end if; + else + Put (')'); + Put (End_Str); + exit; + end if; + + Inter := Next_Inter; + Next_Inter := Get_Chain (Inter); + end loop; + end Disp_Interface_Chain; + + procedure Disp_Ports (Parent : Iir) is + begin + Put ("port"); + Disp_Interface_Chain (Get_Port_Chain (Parent), ";"); + end Disp_Ports; + + procedure Disp_Generics (Parent : Iir) is + begin + Put ("generic"); + Disp_Interface_Chain (Get_Generic_Chain (Parent), ";"); + end Disp_Generics; + + procedure Disp_Entity_Declaration (Decl: Iir_Entity_Declaration) is + Start: constant Count := Col; + begin + Put ("entity "); + Disp_Name_Of (Decl); + Put_Line (" is"); + if Get_Generic_Chain (Decl) /= Null_Iir then + Set_Col (Start + Indentation); + Disp_Generics (Decl); + end if; + if Get_Port_Chain (Decl) /= Null_Iir then + Set_Col (Start + Indentation); + Disp_Ports (Decl); + end if; + Disp_Declaration_Chain (Decl, Start + Indentation); + if Get_Has_Begin (Decl) then + Set_Col (Start); + Put_Line ("begin"); + end if; + if Get_Concurrent_Statement_Chain (Decl) /= Null_Iir then + Disp_Concurrent_Statement_Chain (Decl, Start + Indentation); + end if; + Set_Col (Start); + Disp_End (Decl, "entity"); + end Disp_Entity_Declaration; + + procedure Disp_Component_Declaration (Decl: Iir_Component_Declaration) + is + Indent: Count; + begin + Indent := Col; + Put ("component "); + Disp_Name_Of (Decl); + if Get_Has_Is (Decl) then + Put (" is"); + end if; + if Get_Generic_Chain (Decl) /= Null_Iir then + Set_Col (Indent + Indentation); + Disp_Generics (Decl); + end if; + if Get_Port_Chain (Decl) /= Null_Iir then + Set_Col (Indent + Indentation); + Disp_Ports (Decl); + end if; + Set_Col (Indent); + Disp_End (Decl, "component"); + end Disp_Component_Declaration; + + procedure Disp_Concurrent_Statement_Chain (Parent : Iir; Indent : Count) + is + El: Iir; + begin + El := Get_Concurrent_Statement_Chain (Parent); + while El /= Null_Iir loop + Set_Col (Indent); + Disp_Concurrent_Statement (El); + El := Get_Chain (El); + end loop; + end Disp_Concurrent_Statement_Chain; + + procedure Disp_Architecture_Body (Arch: Iir_Architecture_Body) + is + Start: Count; + begin + Start := Col; + Put ("architecture "); + Disp_Name_Of (Arch); + Put (" of "); + Disp_Name (Get_Entity_Name (Arch)); + Put_Line (" is"); + Disp_Declaration_Chain (Arch, Start + Indentation); + Set_Col (Start); + Put_Line ("begin"); + Disp_Concurrent_Statement_Chain (Arch, Start + Indentation); + Set_Col (Start); + Disp_End (Arch, "architecture"); + end Disp_Architecture_Body; + + procedure Disp_Signature (Sig : Iir) + is + List : Iir_List; + El : Iir; + begin + Disp_Name (Get_Signature_Prefix (Sig)); + Put (" ["); + List := Get_Type_Marks_List (Sig); + if List /= Null_Iir_List then + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if I /= 0 then + Put (", "); + end if; + Disp_Name (El); + end loop; + end if; + El := Get_Return_Type_Mark (Sig); + if El /= Null_Iir then + Put (" return "); + Disp_Name (El); + end if; + Put ("]"); + end Disp_Signature; + + procedure Disp_Object_Alias_Declaration (Decl: Iir_Object_Alias_Declaration) + is + begin + Put ("alias "); + Disp_Name_Of (Decl); + Put (": "); + Disp_Type (Get_Type (Decl)); + Put (" is "); + Disp_Expression (Get_Name (Decl)); + Put_Line (";"); + end Disp_Object_Alias_Declaration; + + procedure Disp_Non_Object_Alias_Declaration + (Decl: Iir_Non_Object_Alias_Declaration) + is + Sig : constant Iir := Get_Alias_Signature (Decl); + begin + if Get_Implicit_Alias_Flag (Decl) then + Put ("-- "); + end if; + + Put ("alias "); + Disp_Function_Name (Decl); + Put (" is "); + if Sig /= Null_Iir then + Disp_Signature (Sig); + else + Disp_Name (Get_Name (Decl)); + end if; + Put_Line (";"); + end Disp_Non_Object_Alias_Declaration; + + procedure Disp_File_Declaration (Decl: Iir_File_Declaration) + is + Next_Decl : Iir; + Expr: Iir; + begin + Put ("file "); + Disp_Name_Of (Decl); + Next_Decl := Decl; + while Get_Has_Identifier_List (Next_Decl) loop + Next_Decl := Get_Chain (Next_Decl); + Put (", "); + Disp_Name_Of (Next_Decl); + end loop; + Put (": "); + Disp_Type (Get_Type (Decl)); + if Vhdl_Std = Vhdl_87 then + Put (" is "); + if Get_Has_Mode (Decl) then + Disp_Mode (Get_Mode (Decl)); + end if; + Disp_Expression (Get_File_Logical_Name (Decl)); + else + Expr := Get_File_Open_Kind (Decl); + if Expr /= Null_Iir then + Put (" open "); + Disp_Expression (Expr); + end if; + Expr := Get_File_Logical_Name (Decl); + if Expr /= Null_Iir then + Put (" is "); + Disp_Expression (Expr); + end if; + end if; + Put (';'); + end Disp_File_Declaration; + + procedure Disp_Quantity_Declaration (Decl: Iir) + is + Expr : Iir; + Term : Iir; + begin + Put ("quantity "); + Disp_Name_Of (Decl); + + case Get_Kind (Decl) is + when Iir_Kinds_Branch_Quantity_Declaration => + Disp_Tolerance_Opt (Decl); + Expr := Get_Default_Value (Decl); + if Expr /= Null_Iir then + Put (":= "); + Disp_Expression (Expr); + end if; + if Get_Kind (Decl) = Iir_Kind_Across_Quantity_Declaration then + Put (" across "); + else + Put (" through "); + end if; + Disp_Name_Of (Get_Plus_Terminal (Decl)); + Term := Get_Minus_Terminal (Decl); + if Term /= Null_Iir then + Put (" to "); + Disp_Name_Of (Term); + end if; + when Iir_Kind_Free_Quantity_Declaration => + Put (": "); + Disp_Type (Get_Type (Decl)); + Expr := Get_Default_Value (Decl); + if Expr /= Null_Iir then + Put (":= "); + Disp_Expression (Expr); + end if; + when others => + raise Program_Error; + end case; + Put (';'); + end Disp_Quantity_Declaration; + + procedure Disp_Terminal_Declaration (Decl: Iir) is + begin + Put ("terminal "); + Disp_Name_Of (Decl); + Put (": "); + Disp_Nature (Get_Nature (Decl)); + Put (';'); + end Disp_Terminal_Declaration; + + procedure Disp_Object_Declaration (Decl: Iir) + is + Next_Decl : Iir; + begin + case Get_Kind (Decl) is + when Iir_Kind_Variable_Declaration => + if Get_Shared_Flag (Decl) then + Put ("shared "); + end if; + Put ("variable "); + when Iir_Kind_Constant_Declaration => + Put ("constant "); + when Iir_Kind_Signal_Declaration => + Put ("signal "); + when Iir_Kind_File_Declaration => + Disp_File_Declaration (Decl); + return; + when others => + raise Internal_Error; + end case; + Disp_Name_Of (Decl); + Next_Decl := Decl; + while Get_Has_Identifier_List (Next_Decl) loop + Next_Decl := Get_Chain (Next_Decl); + Put (", "); + Disp_Name_Of (Next_Decl); + end loop; + Put (": "); + Disp_Subtype_Indication (Get_Subtype_Indication (Decl)); + if Get_Kind (Decl) = Iir_Kind_Signal_Declaration then + Disp_Signal_Kind (Get_Signal_Kind (Decl)); + end if; + + if Get_Default_Value (Decl) /= Null_Iir then + Put (" := "); + Disp_Expression (Get_Default_Value (Decl)); + end if; + Put_Line (";"); + end Disp_Object_Declaration; + + procedure Disp_Pure (Subprg : Iir) is + begin + if Get_Pure_Flag (Subprg) then + Put ("pure"); + else + Put ("impure"); + end if; + end Disp_Pure; + + procedure Disp_Subprogram_Declaration (Subprg: Iir) + is + Start : constant Count := Col; + Implicit : constant Boolean := + Get_Kind (Subprg) in Iir_Kinds_Implicit_Subprogram_Declaration; + Inter : Iir; + begin + if Implicit + and then + Get_Implicit_Definition (Subprg) /= Iir_Predefined_Now_Function + then + Put ("-- "); + end if; + + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration => + if Get_Has_Pure (Subprg) then + Disp_Pure (Subprg); + Put (' '); + end if; + Put ("function"); + when Iir_Kind_Implicit_Function_Declaration => + Put ("function"); + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + Put ("procedure"); + when others => + raise Internal_Error; + end case; + + Put (' '); + Disp_Function_Name (Subprg); + + Inter := Get_Interface_Declaration_Chain (Subprg); + if Implicit then + Disp_Interface_Chain (Inter, "", Start); + else + Disp_Interface_Chain (Inter, "", 0); + end if; + + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration => + Put (" return "); + if Implicit then + Disp_Type (Get_Return_Type (Subprg)); + else + Disp_Name (Get_Return_Type_Mark (Subprg)); + end if; + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + null; + when others => + raise Internal_Error; + end case; + end Disp_Subprogram_Declaration; + + procedure Disp_Subprogram_Body (Subprg : Iir) + is + Indent : constant Count := Col; + begin + Disp_Declaration_Chain (Subprg, Indent + Indentation); + Set_Col (Indent); + Put_Line ("begin"); + Set_Col (Indent + Indentation); + Disp_Sequential_Statements (Get_Sequential_Statement_Chain (Subprg)); + Set_Col (Indent); + if Get_Kind (Subprg) = Iir_Kind_Function_Body then + Disp_End (Subprg, "function"); + else + Disp_End (Subprg, "procedure"); + end if; + end Disp_Subprogram_Body; + + procedure Disp_Instantiation_List (Insts: Iir_List) is + El : Iir; + begin + if Insts = Iir_List_All then + Put ("all"); + elsif Insts = Iir_List_Others then + Put ("others"); + else + for I in Natural loop + El := Get_Nth_Element (Insts, I); + exit when El = Null_Iir; + if I /= Natural'First then + Put (", "); + end if; + Disp_Name_Of (El); + end loop; + end if; + end Disp_Instantiation_List; + + procedure Disp_Configuration_Specification + (Spec : Iir_Configuration_Specification) + is + Indent : Count; + begin + Indent := Col; + Put ("for "); + Disp_Instantiation_List (Get_Instantiation_List (Spec)); + Put (": "); + Disp_Name (Get_Component_Name (Spec)); + New_Line; + Disp_Binding_Indication (Get_Binding_Indication (Spec), + Indent + Indentation); + Put_Line (";"); + end Disp_Configuration_Specification; + + procedure Disp_Disconnection_Specification + (Dis : Iir_Disconnection_Specification) + is + begin + Put ("disconnect "); + Disp_Instantiation_List (Get_Signal_List (Dis)); + Put (": "); + Disp_Name (Get_Type_Mark (Dis)); + Put (" after "); + Disp_Expression (Get_Expression (Dis)); + Put_Line (";"); + end Disp_Disconnection_Specification; + + procedure Disp_Attribute_Declaration (Attr : Iir_Attribute_Declaration) + is + begin + Put ("attribute "); + Disp_Identifier (Attr); + Put (": "); + Disp_Name (Get_Type_Mark (Attr)); + Put_Line (";"); + end Disp_Attribute_Declaration; + + procedure Disp_Attribute_Value (Attr : Iir) is + begin + Disp_Name_Of (Get_Designated_Entity (Attr)); + Put ("'"); + Disp_Identifier + (Get_Attribute_Designator (Get_Attribute_Specification (Attr))); + end Disp_Attribute_Value; + + procedure Disp_Attribute_Name (Attr : Iir) + is + Sig : constant Iir := Get_Attribute_Signature (Attr); + begin + if Sig /= Null_Iir then + Disp_Signature (Sig); + else + Disp_Name (Get_Prefix (Attr)); + end if; + Put ("'"); + Disp_Ident (Get_Identifier (Attr)); + end Disp_Attribute_Name; + + procedure Disp_Entity_Kind (Tok : Tokens.Token_Type) is + begin + Put (Tokens.Image (Tok)); + end Disp_Entity_Kind; + + procedure Disp_Entity_Name_List (List : Iir_List) + is + El : Iir; + begin + if List = Iir_List_All then + Put ("all"); + elsif List = Iir_List_Others then + Put ("others"); + else + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if I /= 0 then + Put (", "); + end if; + if Get_Kind (El) = Iir_Kind_Signature then + Disp_Signature (El); + else + Disp_Name (El); + end if; + end loop; + end if; + end Disp_Entity_Name_List; + + procedure Disp_Attribute_Specification (Attr : Iir_Attribute_Specification) + is + begin + Put ("attribute "); + Disp_Identifier (Get_Attribute_Designator (Attr)); + Put (" of "); + Disp_Entity_Name_List (Get_Entity_Name_List (Attr)); + Put (": "); + Disp_Entity_Kind (Get_Entity_Class (Attr)); + Put (" is "); + Disp_Expression (Get_Expression (Attr)); + Put_Line (";"); + end Disp_Attribute_Specification; + + procedure Disp_Protected_Type_Body + (Bod : Iir_Protected_Type_Body; Indent : Count) + is + begin + Put ("type "); + Disp_Identifier (Bod); + Put (" is protected body"); + New_Line; + Disp_Declaration_Chain (Bod, Indent + Indentation); + Set_Col (Indent); + Disp_End (Bod, "protected body"); + end Disp_Protected_Type_Body; + + procedure Disp_Group_Template_Declaration (Decl : Iir) + is + use Tokens; + Ent : Iir; + begin + Put ("group "); + Disp_Identifier (Decl); + Put (" is ("); + Ent := Get_Entity_Class_Entry_Chain (Decl); + loop + Disp_Entity_Kind (Get_Entity_Class (Ent)); + Ent := Get_Chain (Ent); + exit when Ent = Null_Iir; + if Get_Entity_Class (Ent) = Tok_Box then + Put (" <>"); + exit; + else + Put (", "); + end if; + end loop; + Put_Line (");"); + end Disp_Group_Template_Declaration; + + procedure Disp_Group_Declaration (Decl : Iir) + is + List : Iir_List; + El : Iir; + begin + Put ("group "); + Disp_Identifier (Decl); + Put (" : "); + Disp_Name (Get_Group_Template_Name (Decl)); + Put (" ("); + List := Get_Group_Constituent_List (Decl); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if I /= 0 then + Put (", "); + end if; + Disp_Name_Of (El); + end loop; + Put_Line (");"); + end Disp_Group_Declaration; + + procedure Disp_Declaration_Chain (Parent : Iir; Indent: Count) + is + Decl: Iir; + begin + Decl := Get_Declaration_Chain (Parent); + while Decl /= Null_Iir loop + Set_Col (Indent); + case Get_Kind (Decl) is + when Iir_Kind_Type_Declaration => + Disp_Type_Declaration (Decl); + when Iir_Kind_Anonymous_Type_Declaration => + Disp_Anonymous_Type_Declaration (Decl); + when Iir_Kind_Subtype_Declaration => + Disp_Subtype_Declaration (Decl); + when Iir_Kind_Use_Clause => + Disp_Use_Clause (Decl); + when Iir_Kind_Component_Declaration => + Disp_Component_Declaration (Decl); + when Iir_Kind_File_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration => + Disp_Object_Declaration (Decl); + while Get_Has_Identifier_List (Decl) loop + Decl := Get_Chain (Decl); + end loop; + when Iir_Kind_Object_Alias_Declaration => + Disp_Object_Alias_Declaration (Decl); + when Iir_Kind_Terminal_Declaration => + Disp_Terminal_Declaration (Decl); + when Iir_Kinds_Quantity_Declaration => + Disp_Quantity_Declaration (Decl); + when Iir_Kind_Nature_Declaration => + Disp_Nature_Declaration (Decl); + when Iir_Kind_Non_Object_Alias_Declaration => + Disp_Non_Object_Alias_Declaration (Decl); + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + Disp_Subprogram_Declaration (Decl); + Put_Line (";"); + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Disp_Subprogram_Declaration (Decl); + if not Get_Has_Body (Decl) then + Put_Line (";"); + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + -- The declaration was just displayed. + Put_Line (" is"); + Set_Col (Indent); + Disp_Subprogram_Body (Decl); + when Iir_Kind_Protected_Type_Body => + Disp_Protected_Type_Body (Decl, Indent); + when Iir_Kind_Configuration_Specification => + Disp_Configuration_Specification (Decl); + when Iir_Kind_Disconnection_Specification => + Disp_Disconnection_Specification (Decl); + when Iir_Kind_Attribute_Declaration => + Disp_Attribute_Declaration (Decl); + when Iir_Kind_Attribute_Specification => + Disp_Attribute_Specification (Decl); + when Iir_Kinds_Signal_Attribute => + null; + when Iir_Kind_Group_Template_Declaration => + Disp_Group_Template_Declaration (Decl); + when Iir_Kind_Group_Declaration => + Disp_Group_Declaration (Decl); + when others => + Error_Kind ("disp_declaration_chain", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + end Disp_Declaration_Chain; + + procedure Disp_Waveform (Chain : Iir_Waveform_Element) + is + We: Iir_Waveform_Element; + Val : Iir; + begin + if Chain = Null_Iir then + Put ("null after {disconnection_time}"); + return; + end if; + We := Chain; + while We /= Null_Iir loop + if We /= Chain then + Put (", "); + end if; + Val := Get_We_Value (We); + Disp_Expression (Val); + if Get_Time (We) /= Null_Iir then + Put (" after "); + Disp_Expression (Get_Time (We)); + end if; + We := Get_Chain (We); + end loop; + end Disp_Waveform; + + procedure Disp_Delay_Mechanism (Stmt: Iir) is + Expr: Iir; + begin + case Get_Delay_Mechanism (Stmt) is + when Iir_Transport_Delay => + Put ("transport "); + when Iir_Inertial_Delay => + Expr := Get_Reject_Time_Expression (Stmt); + if Expr /= Null_Iir then + Put ("reject "); + Disp_Expression (Expr); + Put (" inertial "); + end if; + end case; + end Disp_Delay_Mechanism; + + procedure Disp_Signal_Assignment (Stmt: Iir) is + begin + Disp_Expression (Get_Target (Stmt)); + Put (" <= "); + Disp_Delay_Mechanism (Stmt); + Disp_Waveform (Get_Waveform_Chain (Stmt)); + Put_Line (";"); + end Disp_Signal_Assignment; + + procedure Disp_Variable_Assignment (Stmt: Iir) is + begin + Disp_Expression (Get_Target (Stmt)); + Put (" := "); + Disp_Expression (Get_Expression (Stmt)); + Put_Line (";"); + end Disp_Variable_Assignment; + + procedure Disp_Label (Stmt : Iir) + is + Label: constant Name_Id := Get_Label (Stmt); + begin + if Label /= Null_Identifier then + Disp_Ident (Label); + Put (": "); + end if; + end Disp_Label; + + procedure Disp_Postponed (Stmt : Iir) is + begin + if Get_Postponed_Flag (Stmt) then + Put ("postponed "); + end if; + end Disp_Postponed; + + procedure Disp_Concurrent_Selected_Signal_Assignment (Stmt: Iir) + is + Indent: constant Count := Col; + Assoc: Iir; + Assoc_Chain : Iir; + begin + Set_Col (Indent); + Disp_Label (Stmt); + Disp_Postponed (Stmt); + Put ("with "); + Disp_Expression (Get_Expression (Stmt)); + Put (" select "); + Disp_Expression (Get_Target (Stmt)); + Put (" <= "); + if Get_Guard (Stmt) /= Null_Iir then + Put ("guarded "); + end if; + Disp_Delay_Mechanism (Stmt); + Assoc_Chain := Get_Selected_Waveform_Chain (Stmt); + Assoc := Assoc_Chain; + while Assoc /= Null_Iir loop + if Assoc /= Assoc_Chain then + Put_Line (","); + end if; + Set_Col (Indent + Indentation); + Disp_Waveform (Get_Associated_Chain (Assoc)); + Put (" when "); + Disp_Choice (Assoc); + end loop; + Put_Line (";"); + end Disp_Concurrent_Selected_Signal_Assignment; + + procedure Disp_Concurrent_Conditional_Signal_Assignment (Stmt: Iir) + is + Indent: Count; + Cond_Wf : Iir_Conditional_Waveform; + Expr : Iir; + begin + Disp_Label (Stmt); + Disp_Postponed (Stmt); + Disp_Expression (Get_Target (Stmt)); + Put (" <= "); + if Get_Guard (Stmt) /= Null_Iir then + Put ("guarded "); + end if; + Disp_Delay_Mechanism (Stmt); + Indent := Col; + Set_Col (Indent); + Cond_Wf := Get_Conditional_Waveform_Chain (Stmt); + while Cond_Wf /= Null_Iir loop + Disp_Waveform (Get_Waveform_Chain (Cond_Wf)); + Expr := Get_Condition (Cond_Wf); + if Expr /= Null_Iir then + Put (" when "); + Disp_Expression (Expr); + Put_Line (" else"); + Set_Col (Indent); + end if; + Cond_Wf := Get_Chain (Cond_Wf); + end loop; + + Put_Line (";"); + end Disp_Concurrent_Conditional_Signal_Assignment; + + procedure Disp_Assertion_Statement (Stmt: Iir) + is + Start: constant Count := Col; + Expr: Iir; + begin + if Get_Kind (Stmt) = Iir_Kind_Concurrent_Assertion_Statement then + Disp_Label (Stmt); + Disp_Postponed (Stmt); + end if; + Put ("assert "); + Disp_Expression (Get_Assertion_Condition (Stmt)); + Expr := Get_Report_Expression (Stmt); + if Expr /= Null_Iir then + Set_Col (Start + Indentation); + Put ("report "); + Disp_Expression (Expr); + end if; + Expr := Get_Severity_Expression (Stmt); + if Expr /= Null_Iir then + Set_Col (Start + Indentation); + Put ("severity "); + Disp_Expression (Expr); + end if; + Put_Line (";"); + end Disp_Assertion_Statement; + + procedure Disp_Report_Statement (Stmt: Iir) + is + Start: Count; + Expr: Iir; + begin + Start := Col; + Put ("report "); + Expr := Get_Report_Expression (Stmt); + Disp_Expression (Expr); + Expr := Get_Severity_Expression (Stmt); + if Expr /= Null_Iir then + Set_Col (Start + Indentation); + Put ("severity "); + Disp_Expression (Expr); + end if; + Put_Line (";"); + end Disp_Report_Statement; + + procedure Disp_Dyadic_Operator (Expr: Iir) is + begin + if Flag_Parenthesis then + Put ("("); + end if; + Disp_Expression (Get_Left (Expr)); + Put (' ' & Name_Table.Image (Iirs_Utils.Get_Operator_Name (Expr)) & ' '); + Disp_Expression (Get_Right (Expr)); + if Flag_Parenthesis then + Put (")"); + end if; + end Disp_Dyadic_Operator; + + procedure Disp_Monadic_Operator (Expr: Iir) is + begin + Put (Name_Table.Image (Iirs_Utils.Get_Operator_Name (Expr))); + Put (' '); + if Flag_Parenthesis then + Put ('('); + end if; + Disp_Expression (Get_Operand (Expr)); + if Flag_Parenthesis then + Put (')'); + end if; + end Disp_Monadic_Operator; + + procedure Disp_Case_Statement (Stmt: Iir_Case_Statement) + is + Indent: Count; + Assoc: Iir; + Sel_Stmt : Iir; + begin + Indent := Col; + Put ("case "); + Disp_Expression (Get_Expression (Stmt)); + Put_Line (" is"); + Assoc := Get_Case_Statement_Alternative_Chain (Stmt); + while Assoc /= Null_Iir loop + Set_Col (Indent + Indentation); + Put ("when "); + Sel_Stmt := Get_Associated_Chain (Assoc); + Disp_Choice (Assoc); + Put_Line (" =>"); + Set_Col (Indent + 2 * Indentation); + Disp_Sequential_Statements (Sel_Stmt); + end loop; + Set_Col (Indent); + Disp_End_Label (Stmt, "case"); + end Disp_Case_Statement; + + procedure Disp_Wait_Statement (Stmt: Iir_Wait_Statement) is + List: Iir_List; + Expr: Iir; + begin + Put ("wait"); + List := Get_Sensitivity_List (Stmt); + if List /= Null_Iir_List then + Put (" on "); + Disp_Designator_List (List); + end if; + Expr := Get_Condition_Clause (Stmt); + if Expr /= Null_Iir then + Put (" until "); + Disp_Expression (Expr); + end if; + Expr := Get_Timeout_Clause (Stmt); + if Expr /= Null_Iir then + Put (" for "); + Disp_Expression (Expr); + end if; + Put_Line (";"); + end Disp_Wait_Statement; + + procedure Disp_If_Statement (Stmt: Iir_If_Statement) is + Clause: Iir; + Expr: Iir; + Start: Count; + begin + Start := Col; + Put ("if "); + Clause := Stmt; + Disp_Expression (Get_Condition (Clause)); + Put_Line (" then"); + while Clause /= Null_Iir loop + Set_Col (Start + Indentation); + Disp_Sequential_Statements (Get_Sequential_Statement_Chain (Clause)); + Clause := Get_Else_Clause (Clause); + exit when Clause = Null_Iir; + Expr := Get_Condition (Clause); + Set_Col (Start); + if Expr /= Null_Iir then + Put ("elsif "); + Disp_Expression (Expr); + Put_Line (" then"); + else + Put_Line ("else"); + end if; + end loop; + Set_Col (Start); + Disp_End_Label (Stmt, "if"); + end Disp_If_Statement; + + procedure Disp_Parameter_Specification + (Iterator : Iir_Iterator_Declaration) is + begin + Disp_Identifier (Iterator); + Put (" in "); + Disp_Discrete_Range (Get_Discrete_Range (Iterator)); + end Disp_Parameter_Specification; + + procedure Disp_Method_Object (Call : Iir) + is + Obj : Iir; + begin + Obj := Get_Method_Object (Call); + if Obj /= Null_Iir then + Disp_Name (Obj); + Put ('.'); + end if; + end Disp_Method_Object; + + procedure Disp_Procedure_Call (Call : Iir) is + begin + if True then + Disp_Name (Get_Prefix (Call)); + else + Disp_Method_Object (Call); + Disp_Identifier (Get_Implementation (Call)); + Put (' '); + end if; + Disp_Association_Chain (Get_Parameter_Association_Chain (Call)); + Put_Line (";"); + end Disp_Procedure_Call; + + procedure Disp_Sequential_Statements (First : Iir) + is + Stmt: Iir; + Start: constant Count := Col; + begin + Stmt := First; + while Stmt /= Null_Iir loop + Set_Col (Start); + Disp_Label (Stmt); + case Get_Kind (Stmt) is + when Iir_Kind_Null_Statement => + Put_Line ("null;"); + when Iir_Kind_If_Statement => + Disp_If_Statement (Stmt); + when Iir_Kind_For_Loop_Statement => + Put ("for "); + Disp_Parameter_Specification + (Get_Parameter_Specification (Stmt)); + Put_Line (" loop"); + Set_Col (Start + Indentation); + Disp_Sequential_Statements + (Get_Sequential_Statement_Chain (Stmt)); + Set_Col (Start); + Disp_End_Label (Stmt, "loop"); + when Iir_Kind_While_Loop_Statement => + if Get_Condition (Stmt) /= Null_Iir then + Put ("while "); + Disp_Expression (Get_Condition (Stmt)); + Put (" "); + end if; + Put_Line ("loop"); + Set_Col (Start + Indentation); + Disp_Sequential_Statements + (Get_Sequential_Statement_Chain (Stmt)); + Set_Col (Start); + Disp_End_Label (Stmt, "loop"); + when Iir_Kind_Signal_Assignment_Statement => + Disp_Signal_Assignment (Stmt); + when Iir_Kind_Variable_Assignment_Statement => + Disp_Variable_Assignment (Stmt); + when Iir_Kind_Assertion_Statement => + Disp_Assertion_Statement (Stmt); + when Iir_Kind_Report_Statement => + Disp_Report_Statement (Stmt); + when Iir_Kind_Return_Statement => + if Get_Expression (Stmt) /= Null_Iir then + Put ("return "); + Disp_Expression (Get_Expression (Stmt)); + Put_Line (";"); + else + Put_Line ("return;"); + end if; + when Iir_Kind_Case_Statement => + Disp_Case_Statement (Stmt); + when Iir_Kind_Wait_Statement => + Disp_Wait_Statement (Stmt); + when Iir_Kind_Procedure_Call_Statement => + Disp_Procedure_Call (Get_Procedure_Call (Stmt)); + when Iir_Kind_Exit_Statement + | Iir_Kind_Next_Statement => + declare + Label : constant Iir := Get_Loop_Label (Stmt); + Cond : constant Iir := Get_Condition (Stmt); + begin + if Get_Kind (Stmt) = Iir_Kind_Exit_Statement then + Put ("exit"); + else + Put ("next"); + end if; + if Label /= Null_Iir then + Put (" "); + Disp_Name (Label); + end if; + if Cond /= Null_Iir then + Put (" when "); + Disp_Expression (Cond); + end if; + Put_Line (";"); + end; + + when others => + Error_Kind ("disp_sequential_statements", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Disp_Sequential_Statements; + + procedure Disp_Process_Statement (Process: Iir) + is + Start: constant Count := Col; + begin + Disp_Label (Process); + Disp_Postponed (Process); + + Put ("process "); + if Get_Kind (Process) = Iir_Kind_Sensitized_Process_Statement then + Put ("("); + Disp_Designator_List (Get_Sensitivity_List (Process)); + Put (")"); + end if; + if Get_Has_Is (Process) then + Put (" is"); + end if; + New_Line; + Disp_Declaration_Chain (Process, Start + Indentation); + Set_Col (Start); + Put_Line ("begin"); + Set_Col (Start + Indentation); + Disp_Sequential_Statements (Get_Sequential_Statement_Chain (Process)); + Set_Col (Start); + Put ("end"); + if Get_End_Has_Postponed (Process) then + Put (" postponed"); + end if; + Disp_After_End (Process, "process"); + end Disp_Process_Statement; + + procedure Disp_Conversion (Conv : Iir) is + begin + case Get_Kind (Conv) is + when Iir_Kind_Function_Call => + Disp_Function_Name (Get_Implementation (Conv)); + when Iir_Kind_Type_Conversion => + Disp_Name_Of (Get_Type_Mark (Conv)); + when others => + Error_Kind ("disp_conversion", Conv); + end case; + end Disp_Conversion; + + procedure Disp_Association_Chain (Chain : Iir) + is + El: Iir; + Formal: Iir; + Need_Comma : Boolean; + Conv : Iir; + begin + if Chain = Null_Iir then + return; + end if; + Put ("("); + Need_Comma := False; + + El := Chain; + while El /= Null_Iir loop + if Get_Kind (El) /= Iir_Kind_Association_Element_By_Individual then + if Need_Comma then + Put (", "); + end if; + + -- Formal part. + if Get_Kind (El) = Iir_Kind_Association_Element_By_Expression then + Conv := Get_Out_Conversion (El); + if Conv /= Null_Iir then + Disp_Conversion (Conv); + Put (" ("); + end if; + else + Conv := Null_Iir; + end if; + Formal := Get_Formal (El); + if Formal /= Null_Iir then + Disp_Expression (Formal); + if Conv /= Null_Iir then + Put (")"); + end if; + Put (" => "); + end if; + + case Get_Kind (El) is + when Iir_Kind_Association_Element_Open => + Put ("open"); + when Iir_Kind_Association_Element_Package => + Disp_Name (Get_Actual (El)); + when others => + Conv := Get_In_Conversion (El); + if Conv /= Null_Iir then + Disp_Conversion (Conv); + Put (" ("); + end if; + Disp_Expression (Get_Actual (El)); + if Conv /= Null_Iir then + Put (")"); + end if; + end case; + Need_Comma := True; + end if; + El := Get_Chain (El); + end loop; + Put (")"); + end Disp_Association_Chain; + + procedure Disp_Generic_Map_Aspect (Parent : Iir) is + begin + Put ("generic map "); + Disp_Association_Chain (Get_Generic_Map_Aspect_Chain (Parent)); + end Disp_Generic_Map_Aspect; + + procedure Disp_Port_Map_Aspect (Parent : Iir) is + begin + Put ("port map "); + Disp_Association_Chain (Get_Port_Map_Aspect_Chain (Parent)); + end Disp_Port_Map_Aspect; + + procedure Disp_Entity_Aspect (Aspect : Iir) is + Arch : Iir; + begin + case Get_Kind (Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + Put ("entity "); + Disp_Name (Get_Entity_Name (Aspect)); + Arch := Get_Architecture (Aspect); + if Arch /= Null_Iir then + Put (" ("); + Disp_Name_Of (Arch); + Put (")"); + end if; + when Iir_Kind_Entity_Aspect_Configuration => + Put ("configuration "); + Disp_Name (Get_Configuration_Name (Aspect)); + when Iir_Kind_Entity_Aspect_Open => + Put ("open"); + when others => + Error_Kind ("disp_entity_aspect", Aspect); + end case; + end Disp_Entity_Aspect; + + procedure Disp_Component_Instantiation_Statement + (Stmt: Iir_Component_Instantiation_Statement) + is + Component: constant Iir := Get_Instantiated_Unit (Stmt); + Alist: Iir; + begin + Disp_Label (Stmt); + if Get_Kind (Component) in Iir_Kinds_Denoting_Name then + Disp_Name (Component); + else + Disp_Entity_Aspect (Component); + end if; + Alist := Get_Generic_Map_Aspect_Chain (Stmt); + if Alist /= Null_Iir then + Put (" "); + Disp_Generic_Map_Aspect (Stmt); + end if; + Alist := Get_Port_Map_Aspect_Chain (Stmt); + if Alist /= Null_Iir then + Put (" "); + Disp_Port_Map_Aspect (Stmt); + end if; + Put (";"); + end Disp_Component_Instantiation_Statement; + + procedure Disp_Function_Call (Expr: Iir_Function_Call) is + begin + if True then + Disp_Name (Get_Prefix (Expr)); + else + Disp_Method_Object (Expr); + Disp_Function_Name (Get_Implementation (Expr)); + end if; + Disp_Association_Chain (Get_Parameter_Association_Chain (Expr)); + end Disp_Function_Call; + + procedure Disp_Indexed_Name (Indexed: Iir) + is + List : Iir_List; + El: Iir; + begin + Disp_Expression (Get_Prefix (Indexed)); + Put (" ("); + List := Get_Index_List (Indexed); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if I /= 0 then + Put (", "); + end if; + Disp_Expression (El); + end loop; + Put (")"); + end Disp_Indexed_Name; + + procedure Disp_Choice (Choice: in out Iir) is + begin + loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + Put ("others"); + when Iir_Kind_Choice_By_None => + null; + when Iir_Kind_Choice_By_Expression => + Disp_Expression (Get_Choice_Expression (Choice)); + when Iir_Kind_Choice_By_Range => + Disp_Range (Get_Choice_Range (Choice)); + when Iir_Kind_Choice_By_Name => + Disp_Name_Of (Get_Choice_Name (Choice)); + when others => + Error_Kind ("disp_choice", Choice); + end case; + Choice := Get_Chain (Choice); + exit when Choice = Null_Iir; + exit when Get_Same_Alternative_Flag (Choice) = False; + --exit when Choice = Null_Iir; + Put (" | "); + end loop; + end Disp_Choice; + + procedure Disp_Aggregate (Aggr: Iir_Aggregate) + is + Indent: Count; + Assoc: Iir; + Expr : Iir; + begin + Indent := Col; + if Indent > Line_Length - 10 then + Indent := 2 * Indentation; + end if; + Put ("("); + Assoc := Get_Association_Choices_Chain (Aggr); + loop + Expr := Get_Associated_Expr (Assoc); + if Get_Kind (Assoc) /= Iir_Kind_Choice_By_None then + Disp_Choice (Assoc); + Put (" => "); + else + Assoc := Get_Chain (Assoc); + end if; + if Get_Kind (Expr) = Iir_Kind_Aggregate + or else Get_Kind (Expr) = Iir_Kind_String_Literal then + Set_Col (Indent); + end if; + Disp_Expression (Expr); + exit when Assoc = Null_Iir; + Put (", "); + end loop; + Put (")"); + end Disp_Aggregate; + + procedure Disp_Simple_Aggregate (Aggr: Iir_Simple_Aggregate) + is + List : Iir_List; + El : Iir; + First : Boolean := True; + begin + Put ("("); + List := Get_Simple_Aggregate_List (Aggr); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if First then + First := False; + else + Put (", "); + end if; + Disp_Expression (El); + end loop; + Put (")"); + end Disp_Simple_Aggregate; + + procedure Disp_Parametered_Attribute (Name : String; Expr : Iir) + is + Param : Iir; + Pfx : Iir; + begin + Pfx := Get_Prefix (Expr); + case Get_Kind (Pfx) is + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + Disp_Name_Of (Pfx); + when others => + Disp_Expression (Pfx); + end case; + Put ("'"); + Put (Name); + Param := Get_Parameter (Expr); + if Param /= Null_Iir + and then Param /= Std_Package.Universal_Integer_One + then + Put (" ("); + Disp_Expression (Param); + Put (")"); + end if; + end Disp_Parametered_Attribute; + + procedure Disp_Parametered_Type_Attribute (Name : String; Expr : Iir) is + begin + Disp_Name (Get_Prefix (Expr)); + Put ("'"); + Put (Name); + Put (" ("); + Disp_Expression (Get_Parameter (Expr)); + Put (")"); + end Disp_Parametered_Type_Attribute; + + procedure Disp_String_Literal (Str : Iir) + is + Ptr : constant String_Fat_Acc := Get_String_Fat_Acc (Str); + Len : constant Int32 := Get_String_Length (Str); + begin + for I in 1 .. Len loop + if Ptr (I) = '"' then + Put ('"'); + end if; + Put (Ptr (I)); + end loop; + end Disp_String_Literal; + + procedure Disp_Expression (Expr: Iir) + is + Orig : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal => + Orig := Get_Literal_Origin (Expr); + if Orig /= Null_Iir then + Disp_Expression (Orig); + else + Disp_Int64 (Get_Value (Expr)); + end if; + when Iir_Kind_Floating_Point_Literal => + Orig := Get_Literal_Origin (Expr); + if Orig /= Null_Iir then + Disp_Expression (Orig); + else + Disp_Fp64 (Get_Fp_Value (Expr)); + end if; + when Iir_Kind_String_Literal => + Orig := Get_Literal_Origin (Expr); + if Orig /= Null_Iir then + Disp_Expression (Orig); + else + Put (""""); + Disp_String_Literal (Expr); + Put (""""); + if Disp_String_Literal_Type or Flags.List_Verbose then + Put ("[type: "); + Disp_Type (Get_Type (Expr)); + Put ("]"); + end if; + end if; + when Iir_Kind_Bit_String_Literal => + Orig := Get_Literal_Origin (Expr); + if Orig /= Null_Iir then + Disp_Expression (Orig); + else + if False then + case Get_Bit_String_Base (Expr) is + when Base_2 => + Put ('B'); + when Base_8 => + Put ('O'); + when Base_16 => + Put ('X'); + end case; + end if; + Put ("B"""); + Disp_String_Literal (Expr); + Put (""""); + end if; + when Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Physical_Int_Literal => + Orig := Get_Literal_Origin (Expr); + if Orig /= Null_Iir then + Disp_Expression (Orig); + else + Disp_Physical_Literal (Expr); + end if; + when Iir_Kind_Unit_Declaration => + Disp_Name_Of (Expr); + when Iir_Kind_Character_Literal => + Disp_Identifier (Expr); + when Iir_Kind_Enumeration_Literal => + Orig := Get_Literal_Origin (Expr); + if Orig /= Null_Iir then + Disp_Expression (Orig); + else + Disp_Name_Of (Expr); + end if; + when Iir_Kind_Overflow_Literal => + Orig := Get_Literal_Origin (Expr); + if Orig /= Null_Iir then + Disp_Expression (Orig); + else + Put ("*OVERFLOW*"); + end if; + + when Iir_Kind_Object_Alias_Declaration => + Disp_Name_Of (Expr); + when Iir_Kind_Aggregate => + Disp_Aggregate (Expr); + when Iir_Kind_Null_Literal => + Put ("null"); + when Iir_Kind_Simple_Aggregate => + Orig := Get_Literal_Origin (Expr); + if Orig /= Null_Iir then + Disp_Expression (Orig); + else + Disp_Simple_Aggregate (Expr); + end if; + + when Iir_Kind_Attribute_Value => + Disp_Attribute_Value (Expr); + when Iir_Kind_Attribute_Name => + Disp_Attribute_Name (Expr); + + when Iir_Kind_Element_Declaration => + Disp_Name_Of (Expr); + + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Iterator_Declaration => + Disp_Name_Of (Expr); + return; + + when Iir_Kinds_Dyadic_Operator => + Disp_Dyadic_Operator (Expr); + when Iir_Kinds_Monadic_Operator => + Disp_Monadic_Operator (Expr); + when Iir_Kind_Function_Call => + Disp_Function_Call (Expr); + when Iir_Kind_Parenthesis_Expression => + Put ("("); + Disp_Expression (Get_Expression (Expr)); + Put (")"); + when Iir_Kind_Type_Conversion => + Disp_Name (Get_Type_Mark (Expr)); + Put (" ("); + Disp_Expression (Get_Expression (Expr)); + Put (")"); + when Iir_Kind_Qualified_Expression => + declare + Qexpr : constant Iir := Get_Expression (Expr); + Has_Paren : constant Boolean := + Get_Kind (Qexpr) = Iir_Kind_Parenthesis_Expression + or else Get_Kind (Qexpr) = Iir_Kind_Aggregate; + begin + Disp_Name (Get_Type_Mark (Expr)); + Put ("'"); + if not Has_Paren then + Put ("("); + end if; + Disp_Expression (Qexpr); + if not Has_Paren then + Put (")"); + end if; + end; + when Iir_Kind_Allocator_By_Expression => + Put ("new "); + Disp_Expression (Get_Expression (Expr)); + when Iir_Kind_Allocator_By_Subtype => + Put ("new "); + Disp_Subtype_Indication (Get_Subtype_Indication (Expr)); + + when Iir_Kind_Indexed_Name => + Disp_Indexed_Name (Expr); + when Iir_Kind_Slice_Name => + Disp_Expression (Get_Prefix (Expr)); + Put (" ("); + Disp_Range (Get_Suffix (Expr)); + Put (")"); + when Iir_Kind_Selected_Element => + Disp_Expression (Get_Prefix (Expr)); + Put ("."); + Disp_Name_Of (Get_Selected_Element (Expr)); + when Iir_Kind_Implicit_Dereference => + Disp_Expression (Get_Prefix (Expr)); + when Iir_Kind_Dereference => + Disp_Expression (Get_Prefix (Expr)); + Put (".all"); + + when Iir_Kind_Left_Type_Attribute => + Disp_Name (Get_Prefix (Expr)); + Put ("'left"); + when Iir_Kind_Right_Type_Attribute => + Disp_Name (Get_Prefix (Expr)); + Put ("'right"); + when Iir_Kind_High_Type_Attribute => + Disp_Name (Get_Prefix (Expr)); + Put ("'high"); + when Iir_Kind_Low_Type_Attribute => + Disp_Name (Get_Prefix (Expr)); + Put ("'low"); + when Iir_Kind_Ascending_Type_Attribute => + Disp_Name (Get_Prefix (Expr)); + Put ("'ascending"); + + when Iir_Kind_Stable_Attribute => + Disp_Parametered_Attribute ("stable", Expr); + when Iir_Kind_Quiet_Attribute => + Disp_Parametered_Attribute ("quiet", Expr); + when Iir_Kind_Delayed_Attribute => + Disp_Parametered_Attribute ("delayed", Expr); + when Iir_Kind_Transaction_Attribute => + Disp_Expression (Get_Prefix (Expr)); + Put ("'transaction"); + when Iir_Kind_Event_Attribute => + Disp_Expression (Get_Prefix (Expr)); + Put ("'event"); + when Iir_Kind_Active_Attribute => + Disp_Expression (Get_Prefix (Expr)); + Put ("'active"); + when Iir_Kind_Driving_Attribute => + Disp_Expression (Get_Prefix (Expr)); + Put ("'driving"); + when Iir_Kind_Driving_Value_Attribute => + Disp_Expression (Get_Prefix (Expr)); + Put ("'driving_value"); + when Iir_Kind_Last_Value_Attribute => + Disp_Expression (Get_Prefix (Expr)); + Put ("'last_value"); + when Iir_Kind_Last_Active_Attribute => + Disp_Expression (Get_Prefix (Expr)); + Put ("'last_active"); + when Iir_Kind_Last_Event_Attribute => + Disp_Expression (Get_Prefix (Expr)); + Put ("'last_event"); + + when Iir_Kind_Pos_Attribute => + Disp_Parametered_Type_Attribute ("pos", Expr); + when Iir_Kind_Val_Attribute => + Disp_Parametered_Type_Attribute ("val", Expr); + when Iir_Kind_Succ_Attribute => + Disp_Parametered_Type_Attribute ("succ", Expr); + when Iir_Kind_Pred_Attribute => + Disp_Parametered_Type_Attribute ("pred", Expr); + when Iir_Kind_Leftof_Attribute => + Disp_Parametered_Type_Attribute ("leftof", Expr); + when Iir_Kind_Rightof_Attribute => + Disp_Parametered_Type_Attribute ("rightof", Expr); + + when Iir_Kind_Length_Array_Attribute => + Disp_Parametered_Attribute ("length", Expr); + when Iir_Kind_Range_Array_Attribute => + Disp_Parametered_Attribute ("range", Expr); + when Iir_Kind_Reverse_Range_Array_Attribute => + Disp_Parametered_Attribute ("reverse_range", Expr); + when Iir_Kind_Left_Array_Attribute => + Disp_Parametered_Attribute ("left", Expr); + when Iir_Kind_Right_Array_Attribute => + Disp_Parametered_Attribute ("right", Expr); + when Iir_Kind_Low_Array_Attribute => + Disp_Parametered_Attribute ("low", Expr); + when Iir_Kind_High_Array_Attribute => + Disp_Parametered_Attribute ("high", Expr); + when Iir_Kind_Ascending_Array_Attribute => + Disp_Parametered_Attribute ("ascending", Expr); + + when Iir_Kind_Image_Attribute => + Disp_Parametered_Attribute ("image", Expr); + when Iir_Kind_Value_Attribute => + Disp_Parametered_Attribute ("value", Expr); + when Iir_Kind_Simple_Name_Attribute => + Disp_Name (Get_Prefix (Expr)); + Put ("'simple_name"); + when Iir_Kind_Instance_Name_Attribute => + Disp_Name (Get_Prefix (Expr)); + Put ("'instance_name"); + when Iir_Kind_Path_Name_Attribute => + Disp_Name (Get_Prefix (Expr)); + Put ("'path_name"); + + when Iir_Kind_Selected_By_All_Name => + Disp_Expression (Get_Prefix (Expr)); + when Iir_Kind_Selected_Name => + Disp_Name (Expr); + when Iir_Kind_Simple_Name => + Disp_Name (Expr); + + when Iir_Kinds_Type_And_Subtype_Definition => + Disp_Type (Expr); + + when Iir_Kind_Range_Expression => + Disp_Range (Expr); + when Iir_Kind_Subtype_Declaration => + Disp_Name_Of (Expr); + + when others => + Error_Kind ("disp_expression", Expr); + end case; + end Disp_Expression; + + procedure Disp_PSL_HDL_Expr (N : PSL.Nodes.HDL_Node) is + begin + Disp_Expression (Iir (N)); + end Disp_PSL_HDL_Expr; + + procedure Disp_Psl_Expression (Expr : PSL_Node) is + begin + PSL.Prints.HDL_Expr_Printer := Disp_PSL_HDL_Expr'Access; + PSL.Prints.Print_Property (Expr); + end Disp_Psl_Expression; + + procedure Disp_Block_Header (Header : Iir_Block_Header; Indent: Count) + is + Chain : Iir; + begin + if Header = Null_Iir then + return; + end if; + Chain := Get_Generic_Chain (Header); + if Chain /= Null_Iir then + Set_Col (Indent + Indentation); + Disp_Generics (Header); + Chain := Get_Generic_Map_Aspect_Chain (Header); + if Chain /= Null_Iir then + Set_Col (Indent + Indentation); + Disp_Generic_Map_Aspect (Header); + Put_Line (";"); + end if; + end if; + Chain := Get_Port_Chain (Header); + if Chain /= Null_Iir then + Set_Col (Indent + Indentation); + Disp_Ports (Header); + Chain := Get_Port_Map_Aspect_Chain (Header); + if Chain /= Null_Iir then + Set_Col (Indent + Indentation); + Disp_Port_Map_Aspect (Header); + Put_Line (";"); + end if; + end if; + end Disp_Block_Header; + + procedure Disp_Block_Statement (Block: Iir_Block_Statement) + is + Indent: Count; + Sensitivity: Iir_List; + Guard : Iir_Guard_Signal_Declaration; + begin + Indent := Col; + Disp_Label (Block); + Put ("block"); + Guard := Get_Guard_Decl (Block); + if Guard /= Null_Iir then + Put (" ("); + Disp_Expression (Get_Guard_Expression (Guard)); + Put_Line (")"); + Sensitivity := Get_Guard_Sensitivity_List (Guard); + if Sensitivity /= Null_Iir_List then + Set_Col (Indent + Indentation); + Put ("-- guard sensitivity list "); + Disp_Designator_List (Sensitivity); + end if; + else + New_Line; + end if; + Disp_Block_Header (Get_Block_Header (Block), + Indent + Indentation); + Disp_Declaration_Chain (Block, Indent + Indentation); + Set_Col (Indent); + Put_Line ("begin"); + Disp_Concurrent_Statement_Chain (Block, Indent + Indentation); + Set_Col (Indent); + Disp_End (Block, "block"); + end Disp_Block_Statement; + + procedure Disp_Generate_Statement (Stmt : Iir_Generate_Statement) + is + Indent : Count; + Scheme : Iir; + begin + Indent := Col; + Disp_Label (Stmt); + Scheme := Get_Generation_Scheme (Stmt); + case Get_Kind (Scheme) is + when Iir_Kind_Iterator_Declaration => + Put ("for "); + Disp_Parameter_Specification (Scheme); + when others => + Put ("if "); + Disp_Expression (Scheme); + end case; + Put_Line (" generate"); + Disp_Declaration_Chain (Stmt, Indent); + if Get_Has_Begin (Stmt) then + Set_Col (Indent); + Put_Line ("begin"); + end if; + Disp_Concurrent_Statement_Chain (Stmt, Indent + Indentation); + Set_Col (Indent); + Disp_End (Stmt, "generate"); + end Disp_Generate_Statement; + + procedure Disp_Psl_Default_Clock (Stmt : Iir) is + begin + Put ("--psl default clock is "); + Disp_Psl_Expression (Get_Psl_Boolean (Stmt)); + Put_Line (";"); + end Disp_Psl_Default_Clock; + + procedure Disp_PSL_NFA (N : PSL.Nodes.NFA) + is + use PSL.NFAs; + use PSL.Nodes; + + procedure Disp_State (S : NFA_State) is + Str : constant String := Int32'Image (Get_State_Label (S)); + begin + Put (Str (2 .. Str'Last)); + end Disp_State; + + S : NFA_State; + E : NFA_Edge; + begin + if N /= No_NFA then + S := Get_First_State (N); + while S /= No_State loop + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + Put ("-- "); + Disp_State (S); + Put (" -> "); + Disp_State (Get_Edge_Dest (E)); + Put (": "); + Disp_Psl_Expression (Get_Edge_Expr (E)); + New_Line; + E := Get_Next_Src_Edge (E); + end loop; + S := Get_Next_State (S); + end loop; + end if; + end Disp_PSL_NFA; + + procedure Disp_Psl_Assert_Statement (Stmt : Iir) is + begin + Put ("--psl assert "); + Disp_Psl_Expression (Get_Psl_Property (Stmt)); + Put_Line (";"); + Disp_PSL_NFA (Get_PSL_NFA (Stmt)); + end Disp_Psl_Assert_Statement; + + procedure Disp_Psl_Cover_Statement (Stmt : Iir) is + begin + Put ("--psl cover "); + Disp_Psl_Expression (Get_Psl_Property (Stmt)); + Put_Line (";"); + Disp_PSL_NFA (Get_PSL_NFA (Stmt)); + end Disp_Psl_Cover_Statement; + + procedure Disp_Simple_Simultaneous_Statement (Stmt : Iir) + is + begin + Disp_Label (Stmt); + Disp_Expression (Get_Simultaneous_Left (Stmt)); + Put (" == "); + Disp_Expression (Get_Simultaneous_Right (Stmt)); + Put_Line (";"); + end Disp_Simple_Simultaneous_Statement; + + procedure Disp_Concurrent_Statement (Stmt: Iir) is + begin + case Get_Kind (Stmt) is + when Iir_Kind_Concurrent_Conditional_Signal_Assignment => + Disp_Concurrent_Conditional_Signal_Assignment (Stmt); + when Iir_Kind_Concurrent_Selected_Signal_Assignment => + Disp_Concurrent_Selected_Signal_Assignment (Stmt); + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + Disp_Process_Statement (Stmt); + when Iir_Kind_Concurrent_Assertion_Statement => + Disp_Assertion_Statement (Stmt); + when Iir_Kind_Component_Instantiation_Statement => + Disp_Component_Instantiation_Statement (Stmt); + when Iir_Kind_Concurrent_Procedure_Call_Statement => + Disp_Label (Stmt); + Disp_Postponed (Stmt); + Disp_Procedure_Call (Get_Procedure_Call (Stmt)); + when Iir_Kind_Block_Statement => + Disp_Block_Statement (Stmt); + when Iir_Kind_Generate_Statement => + Disp_Generate_Statement (Stmt); + when Iir_Kind_Psl_Default_Clock => + Disp_Psl_Default_Clock (Stmt); + when Iir_Kind_Psl_Assert_Statement => + Disp_Psl_Assert_Statement (Stmt); + when Iir_Kind_Psl_Cover_Statement => + Disp_Psl_Cover_Statement (Stmt); + when Iir_Kind_Simple_Simultaneous_Statement => + Disp_Simple_Simultaneous_Statement (Stmt); + when others => + Error_Kind ("disp_concurrent_statement", Stmt); + end case; + end Disp_Concurrent_Statement; + + procedure Disp_Package_Declaration (Decl: Iir_Package_Declaration) + is + Header : constant Iir := Get_Package_Header (Decl); + begin + Put ("package "); + Disp_Identifier (Decl); + Put_Line (" is"); + if Header /= Null_Iir then + Disp_Generics (Header); + New_Line; + end if; + Disp_Declaration_Chain (Decl, Col + Indentation); + Disp_End (Decl, "package"); + end Disp_Package_Declaration; + + procedure Disp_Package_Body (Decl: Iir) + is + begin + Put ("package body "); + Disp_Identifier (Decl); + Put_Line (" is"); + Disp_Declaration_Chain (Decl, Col + Indentation); + Disp_End (Decl, "package body"); + end Disp_Package_Body; + + procedure Disp_Package_Instantiation_Declaration (Decl: Iir) is + begin + Put ("package "); + Disp_Identifier (Decl); + Put_Line (" is new "); + Disp_Name (Get_Uninstantiated_Package_Name (Decl)); + Put (" "); + Disp_Generic_Map_Aspect (Decl); + Put_Line (";"); + end Disp_Package_Instantiation_Declaration; + + procedure Disp_Binding_Indication (Bind : Iir; Indent : Count) + is + El : Iir; + begin + El := Get_Entity_Aspect (Bind); + if El /= Null_Iir then + Set_Col (Indent); + Put ("use "); + Disp_Entity_Aspect (El); + end if; + El := Get_Generic_Map_Aspect_Chain (Bind); + if El /= Null_Iir then + Set_Col (Indent); + Disp_Generic_Map_Aspect (Bind); + end if; + El := Get_Port_Map_Aspect_Chain (Bind); + if El /= Null_Iir then + Set_Col (Indent); + Disp_Port_Map_Aspect (Bind); + end if; + end Disp_Binding_Indication; + + procedure Disp_Component_Configuration + (Conf : Iir_Component_Configuration; Indent : Count) + is + Block : Iir_Block_Configuration; + Binding : Iir; + begin + Set_Col (Indent); + Put ("for "); + Disp_Instantiation_List (Get_Instantiation_List (Conf)); + Put (" : "); + Disp_Name_Of (Get_Component_Name (Conf)); + New_Line; + Binding := Get_Binding_Indication (Conf); + if Binding /= Null_Iir then + Disp_Binding_Indication (Binding, Indent + Indentation); + Put (";"); + end if; + Block := Get_Block_Configuration (Conf); + if Block /= Null_Iir then + Disp_Block_Configuration (Block, Indent + Indentation); + end if; + Set_Col (Indent); + Put_Line ("end for;"); + end Disp_Component_Configuration; + + procedure Disp_Configuration_Items + (Conf : Iir_Block_Configuration; Indent : Count) + is + El : Iir; + begin + El := Get_Configuration_Item_Chain (Conf); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Block_Configuration => + Disp_Block_Configuration (El, Indent); + when Iir_Kind_Component_Configuration => + Disp_Component_Configuration (El, Indent); + when Iir_Kind_Configuration_Specification => + -- This may be created by canon. + Set_Col (Indent); + Disp_Configuration_Specification (El); + Set_Col (Indent); + Put_Line ("end for;"); + when others => + Error_Kind ("disp_configuration_item_list", El); + end case; + El := Get_Chain (El); + end loop; + end Disp_Configuration_Items; + + procedure Disp_Block_Configuration + (Block: Iir_Block_Configuration; Indent: Count) + is + Spec : Iir; + begin + Set_Col (Indent); + Put ("for "); + Spec := Get_Block_Specification (Block); + case Get_Kind (Spec) is + when Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Architecture_Body => + Disp_Name_Of (Spec); + when Iir_Kind_Indexed_Name => + declare + Index_List : constant Iir_List := Get_Index_List (Spec); + begin + Disp_Name_Of (Get_Prefix (Spec)); + Put (" ("); + if Index_List = Iir_List_Others then + Put ("others"); + else + Disp_Expression (Get_First_Element (Index_List)); + end if; + Put (")"); + end; + when Iir_Kind_Slice_Name => + Disp_Name_Of (Get_Prefix (Spec)); + Put (" ("); + Disp_Range (Get_Suffix (Spec)); + Put (")"); + when Iir_Kind_Simple_Name => + Disp_Name (Spec); + when others => + Error_Kind ("disp_block_configuration", Spec); + end case; + New_Line; + Disp_Declaration_Chain (Block, Indent + Indentation); + Disp_Configuration_Items (Block, Indent + Indentation); + Set_Col (Indent); + Put_Line ("end for;"); + end Disp_Block_Configuration; + + procedure Disp_Configuration_Declaration + (Decl: Iir_Configuration_Declaration) + is + begin + Put ("configuration "); + Disp_Name_Of (Decl); + Put (" of "); + Disp_Name (Get_Entity_Name (Decl)); + Put_Line (" is"); + Disp_Declaration_Chain (Decl, Col); + Disp_Block_Configuration (Get_Block_Configuration (Decl), + Col + Indentation); + Disp_End (Decl, "configuration"); + end Disp_Configuration_Declaration; + + procedure Disp_Design_Unit (Unit: Iir_Design_Unit) + is + Indent: constant Count := Col; + Decl: Iir; + Next_Decl : Iir; + begin + Decl := Get_Context_Items (Unit); + while Decl /= Null_Iir loop + Next_Decl := Get_Chain (Decl); + + Set_Col (Indent); + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + Disp_Use_Clause (Decl); + when Iir_Kind_Library_Clause => + Put ("library "); + Disp_Identifier (Decl); + while Get_Has_Identifier_List (Decl) loop + Decl := Next_Decl; + Next_Decl := Get_Chain (Decl); + Put (", "); + Disp_Identifier (Decl); + end loop; + Put_Line (";"); + when others => + Error_Kind ("disp_design_unit1", Decl); + end case; + Decl := Next_Decl; + end loop; + + Decl := Get_Library_Unit (Unit); + Set_Col (Indent); + case Get_Kind (Decl) is + when Iir_Kind_Entity_Declaration => + Disp_Entity_Declaration (Decl); + when Iir_Kind_Architecture_Body => + Disp_Architecture_Body (Decl); + when Iir_Kind_Package_Declaration => + Disp_Package_Declaration (Decl); + when Iir_Kind_Package_Body => + Disp_Package_Body (Decl); + when Iir_Kind_Package_Instantiation_Declaration => + Disp_Package_Instantiation_Declaration (Decl); + when Iir_Kind_Configuration_Declaration => + Disp_Configuration_Declaration (Decl); + when others => + Error_Kind ("disp_design_unit2", Decl); + end case; + New_Line; + New_Line; + end Disp_Design_Unit; + + procedure Disp_Vhdl (An_Iir: Iir) is + begin + -- Put (Count'Image (Line_Length)); + case Get_Kind (An_Iir) is + when Iir_Kind_Design_Unit => + Disp_Design_Unit (An_Iir); + when Iir_Kind_Character_Literal => + Disp_Character_Literal (An_Iir); + when Iir_Kind_Enumeration_Type_Definition => + Disp_Enumeration_Type_Definition (An_Iir); + when Iir_Kind_Enumeration_Subtype_Definition => + Disp_Enumeration_Subtype_Definition (An_Iir); + when Iir_Kind_Concurrent_Conditional_Signal_Assignment => + Disp_Concurrent_Conditional_Signal_Assignment (An_Iir); + when Iir_Kinds_Dyadic_Operator => + Disp_Dyadic_Operator (An_Iir); + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Object_Alias_Declaration => + Disp_Name_Of (An_Iir); + when Iir_Kind_Enumeration_Literal => + Disp_Identifier (An_Iir); + when Iir_Kind_Component_Instantiation_Statement => + Disp_Component_Instantiation_Statement (An_Iir); + when Iir_Kind_Integer_Subtype_Definition => + Disp_Integer_Subtype_Definition (An_Iir); + when Iir_Kind_Array_Subtype_Definition => + Disp_Array_Subtype_Definition (An_Iir); + when Iir_Kind_Array_Type_Definition => + Disp_Array_Type_Definition (An_Iir); + when Iir_Kind_Package_Declaration => + Disp_Package_Declaration (An_Iir); + when Iir_Kind_Wait_Statement => + Disp_Wait_Statement (An_Iir); + when Iir_Kind_Selected_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name => + Disp_Expression (An_Iir); + when others => + Error_Kind ("disp", An_Iir); + end case; + end Disp_Vhdl; + + procedure Disp_Int64 (Val: Iir_Int64) + is + Str: constant String := Iir_Int64'Image (Val); + begin + if Str(Str'First) = ' ' then + Put (Str (Str'First + 1 .. Str'Last)); + else + Put (Str); + end if; + end Disp_Int64; + + procedure Disp_Int32 (Val: Iir_Int32) + is + Str: constant String := Iir_Int32'Image (Val); + begin + if Str(Str'First) = ' ' then + Put (Str (Str'First + 1 .. Str'Last)); + else + Put (Str); + end if; + end Disp_Int32; + + procedure Disp_Fp64 (Val: Iir_Fp64) + is + Str: constant String := Iir_Fp64'Image (Val); + begin + if Str(Str'First) = ' ' then + Put (Str (Str'First + 1 .. Str'Last)); + else + Put (Str); + end if; + end Disp_Fp64; +end Disp_Vhdl; diff --git a/src/vhdl/disp_vhdl.ads b/src/vhdl/disp_vhdl.ads new file mode 100644 index 000000000..880290efd --- /dev/null +++ b/src/vhdl/disp_vhdl.ads @@ -0,0 +1,38 @@ +-- VHDL regeneration from internal nodes. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Iirs; use Iirs; + +package Disp_Vhdl is + -- General procedure to display a node. + -- Mainly used to dispatch to other functions according to the kind of + -- the node. + procedure Disp_Vhdl (An_Iir: Iir); + + procedure Disp_Expression (Expr: Iir); + -- Display an expression. + + -- Disp an iir_int64, without the leading blank. + procedure Disp_Int64 (Val: Iir_Int64); + + -- Disp an iir_int32, without the leading blank. + procedure Disp_Int32 (Val: Iir_Int32); + + -- Disp an iir_Fp64, without the leading blank. + procedure Disp_Fp64 (Val: Iir_Fp64); +end Disp_Vhdl; diff --git a/src/vhdl/errorout.adb b/src/vhdl/errorout.adb new file mode 100644 index 000000000..1652bb43e --- /dev/null +++ b/src/vhdl/errorout.adb @@ -0,0 +1,1113 @@ +-- Error message handling. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Text_IO; +with Ada.Command_Line; +with Scanner; +with Tokens; use Tokens; +with Name_Table; +with Iirs_Utils; use Iirs_Utils; +with Files_Map; use Files_Map; +with Ada.Strings.Unbounded; +with Std_Names; +with Flags; +with PSL.Nodes; + +package body Errorout is + procedure Put (Str : String) + is + use Ada.Text_IO; + begin + Put (Standard_Error, Str); + end Put; + + procedure Put (C : Character) + is + use Ada.Text_IO; + begin + Put (Standard_Error, C); + end Put; + + procedure Put_Line (Str : String) + is + use Ada.Text_IO; + begin + Put_Line (Standard_Error, Str); + end Put_Line; + + procedure Disp_Natural (Val: Natural) + is + Str: constant String := Natural'Image (Val); + begin + Put (Str(Str'First + 1 .. Str'Last)); + end Disp_Natural; + + procedure Error_Msg (Msg: String) is + begin + Put (Ada.Command_Line.Command_Name); + Put (": "); + Put_Line (Msg); + end Error_Msg; + + procedure Error_Kind (Msg : String; An_Iir : Iir) is + begin + Put_Line (Msg & ": cannot handle " + & Iir_Kind'Image (Get_Kind (An_Iir)) + & " (" & Disp_Location (An_Iir) & ')'); + raise Internal_Error; + end Error_Kind; + + procedure Error_Kind (Msg : String; Def : Iir_Predefined_Functions) is + begin + Put_Line (Msg & ": cannot handle " + & Iir_Predefined_Functions'Image (Def)); + raise Internal_Error; + end Error_Kind; + + procedure Error_Kind (Msg : String; N : PSL_Node) is + begin + Put (Msg); + Put (": cannot handle "); + Put_Line (PSL.Nodes.Nkind'Image (PSL.Nodes.Get_Kind (N))); + raise Internal_Error; + end Error_Kind; + + procedure Error_Msg_Option_NR (Msg: String) is + begin + Put (Ada.Command_Line.Command_Name); + Put (": "); + Put_Line (Msg); + end Error_Msg_Option_NR; + + procedure Error_Msg_Option (Msg: String) is + begin + Error_Msg_Option_NR (Msg); + raise Option_Error; + end Error_Msg_Option; + + procedure Disp_Location + (File: Name_Id; Line: Natural; Col: Natural) is + begin + Put (Name_Table.Image (File)); + Put (':'); + Disp_Natural (Line); + Put (':'); + Disp_Natural (Col); + Put (':'); + end Disp_Location; + + procedure Disp_Current_Location is + begin + Disp_Location (Scanner.Get_Current_File, + Scanner.Get_Current_Line, + Scanner.Get_Current_Column); + end Disp_Current_Location; + + procedure Disp_Token_Location is + begin + Disp_Location (Scanner.Get_Current_File, + Scanner.Get_Current_Line, + Scanner.Get_Token_Column); + end Disp_Token_Location; + + procedure Disp_Location (Loc : Location_Type) + is + Name : Name_Id; + Line : Natural; + Col : Natural; + begin + if Loc = Location_Nil then + -- Avoid a crash, but should not happen. + Put ("??:??:??:"); + else + Location_To_Position (Loc, Name, Line, Col); + Disp_Location (Name, Line, Col); + end if; + end Disp_Location; + + function Get_Location_Safe (N : Iir) return Location_Type is + begin + if N = Null_Iir then + return Location_Nil; + else + return Get_Location (N); + end if; + end Get_Location_Safe; + + procedure Disp_Iir_Location (An_Iir: Iir) is + begin + Disp_Location (Get_Location_Safe (An_Iir)); + end Disp_Iir_Location; + + procedure Disp_PSL_Location (N : PSL_Node) is + begin + Disp_Location (PSL.Nodes.Get_Location (N)); + end Disp_PSL_Location; + + procedure Warning_Msg (Msg: String) is + begin + Put ("warning: "); + Put_Line (Msg); + end Warning_Msg; + + procedure Warning_Msg_Parse (Msg: String) is + begin + if Flags.Flag_Only_Elab_Warnings then + return; + end if; + Disp_Token_Location; + if Flags.Warn_Error then + Nbr_Errors := Nbr_Errors + 1; + Put (" "); + else + Put ("warning: "); + end if; + Put_Line (Msg); + end Warning_Msg_Parse; + + procedure Warning_Msg_Sem (Msg: String; Loc : Location_Type) is + begin + if Flags.Flag_Only_Elab_Warnings then + return; + end if; + Disp_Location (Loc); + if Flags.Warn_Error then + Nbr_Errors := Nbr_Errors + 1; + Put (" "); + else + Put ("warning: "); + end if; + Put_Line (Msg); + end Warning_Msg_Sem; + + procedure Warning_Msg_Sem (Msg: String; Loc : Iir) is + begin + Warning_Msg_Sem (Msg, Get_Location_Safe (Loc)); + end Warning_Msg_Sem; + + procedure Warning_Msg_Elab (Msg: String; Loc : Location_Type) is + begin + Disp_Location (Loc); + if Flags.Warn_Error then + Nbr_Errors := Nbr_Errors + 1; + Put (" "); + else + Put ("warning: "); + end if; + Put_Line (Msg); + end Warning_Msg_Elab; + + procedure Warning_Msg_Elab (Msg: String; Loc : Iir) is + begin + Warning_Msg_Elab (Msg, Get_Location_Safe (Loc)); + end Warning_Msg_Elab; + + procedure Disp_Current_Token; + pragma Unreferenced (Disp_Current_Token); + + procedure Disp_Current_Token is + begin + case Scanner.Current_Token is + when Tok_Identifier => + Put ("identifier """ + & Name_Table.Image (Scanner.Current_Identifier) & """"); + when others => + Put (Token_Type'Image (Scanner.Current_Token)); + end case; + end Disp_Current_Token; + + -- Disp a message during scan. + procedure Error_Msg_Scan (Msg: String) is + begin + Nbr_Errors := Nbr_Errors + 1; + Disp_Current_Location; + Put (' '); + Put_Line (Msg); + end Error_Msg_Scan; + + procedure Error_Msg_Scan (Msg: String; Loc : Location_Type) is + begin + Nbr_Errors := Nbr_Errors + 1; + Disp_Location (Loc); + Put (' '); + Put_Line (Msg); + end Error_Msg_Scan; + + -- Disp a message during scan. + procedure Warning_Msg_Scan (Msg: String) is + begin + Disp_Current_Location; + Put ("warning: "); + Put_Line (Msg); + end Warning_Msg_Scan; + + -- Disp a message during scan. + procedure Error_Msg_Parse (Msg: String) is + begin + Nbr_Errors := Nbr_Errors + 1; + Disp_Token_Location; + Put (' '); + Put_Line (Msg); + end Error_Msg_Parse; + + procedure Error_Msg_Parse (Msg: String; Loc : Iir) is + begin + Nbr_Errors := Nbr_Errors + 1; + Disp_Iir_Location (Loc); + Put (' '); + Put_Line (Msg); + end Error_Msg_Parse; + + procedure Error_Msg_Parse (Msg: String; Loc : Location_Type) is + begin + Nbr_Errors := Nbr_Errors + 1; + Disp_Location (Loc); + Put (' '); + Put_Line (Msg); + end Error_Msg_Parse; + + -- Disp a message during semantic analysis. + -- LOC is used for location and current token. + procedure Error_Msg_Sem (Msg: String; Loc: in Iir) is + begin + Nbr_Errors := Nbr_Errors + 1; + if Loc /= Null_Iir then + Disp_Iir_Location (Loc); + Put (' '); + end if; + Put_Line (Msg); + end Error_Msg_Sem; + + procedure Error_Msg_Sem (Msg: String; Loc: PSL_Node) is + use PSL.Nodes; + begin + Nbr_Errors := Nbr_Errors + 1; + if Loc /= Null_Node then + Disp_PSL_Location (Loc); + Put (' '); + end if; + Put_Line (Msg); + end Error_Msg_Sem; + + procedure Error_Msg_Sem (Msg: String; Loc : Location_Type) is + begin + Nbr_Errors := Nbr_Errors + 1; + Disp_Location (Loc); + Put (' '); + Put_Line (Msg); + end Error_Msg_Sem; + + -- Disp a message during elaboration. + procedure Error_Msg_Elab (Msg: String) is + begin + Nbr_Errors := Nbr_Errors + 1; + Put ("error: "); + Put_Line (Msg); + end Error_Msg_Elab; + + procedure Error_Msg_Elab (Msg: String; Loc : Iir) is + begin + Nbr_Errors := Nbr_Errors + 1; + Disp_Iir_Location (Loc); + Put (' '); + Put_Line (Msg); + end Error_Msg_Elab; + + -- Disp a bug message. + procedure Error_Internal (Expr: in Iir; Msg: String := "") + is + pragma Unreferenced (Expr); + begin + Put ("internal error: "); + Put_Line (Msg); + raise Internal_Error; + end Error_Internal; + + function Disp_Label (Node : Iir; Str : String) return String + is + Id : Name_Id; + begin + Id := Get_Label (Node); + if Id = Null_Identifier then + return "(unlabeled) " & Str; + else + return Str & " labeled """ & Name_Table.Image (Id) & """"; + end if; + end Disp_Label; + + -- Disp a node. + -- Used for output of message. + function Disp_Node (Node: Iir) return String is + function Disp_Identifier (Node : Iir; Str : String) return String + is + Id : Name_Id; + begin + Id := Get_Identifier (Node); + return Str & " """ & Name_Table.Image (Id) & """"; + end Disp_Identifier; + + function Disp_Type (Node : Iir; Str : String) return String + is + Decl: Iir; + begin + Decl := Get_Type_Declarator (Node); + if Decl = Null_Iir then + return "the anonymous " & Str + & " defined at " & Disp_Location (Node); + else + return Disp_Identifier (Decl, Str); + end if; + end Disp_Type; + + begin + case Get_Kind (Node) is + when Iir_Kind_String_Literal => + return "string literal """ + & Image_String_Lit (Node) & """"; + when Iir_Kind_Bit_String_Literal => + return "bit string literal """ + & Image_String_Lit (Node) & """"; + when Iir_Kind_Character_Literal => + return "character literal " & Image_Identifier (Node); + when Iir_Kind_Integer_Literal => + return "integer literal"; + when Iir_Kind_Floating_Point_Literal => + return "floating point literal"; + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal => + return "physical literal"; + when Iir_Kind_Enumeration_Literal => + return "enumeration literal " & 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_Array_Element_Resolution => + return "array element resolution"; + when Iir_Kind_Record_Resolution => + return "record resolution"; + when Iir_Kind_Record_Element_Resolution => + return "record element resolution"; + when Iir_Kind_Null_Literal => + return "null literal"; + when Iir_Kind_Overflow_Literal => + return Disp_Node (Get_Literal_Origin (Node)); + when Iir_Kind_Aggregate => + return "aggregate"; + when Iir_Kind_Unit_Declaration => + return Disp_Identifier (Node, "physical unit"); + when Iir_Kind_Simple_Aggregate => + return "locally static array literal"; + + when Iir_Kind_Operator_Symbol => + return "operator name"; + when Iir_Kind_Aggregate_Info => + return "aggregate info"; + when Iir_Kind_Signature => + return "signature"; + when Iir_Kind_Waveform_Element => + return "waveform element"; + when Iir_Kind_Conditional_Waveform => + return "conditional waveform"; + when Iir_Kind_Association_Element_Open => + return "open association element"; + when Iir_Kind_Association_Element_By_Individual => + return "individual association element"; + when Iir_Kind_Association_Element_By_Expression + | Iir_Kind_Association_Element_Package => + return "association element"; + when Iir_Kind_Overload_List => + return "overloaded name or expression"; + + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Enumeration_Type_Definition => + return Image_Identifier (Get_Type_Declarator (Node)); + when Iir_Kind_Array_Type_Definition => + return Disp_Type (Node, "array type"); + when Iir_Kind_Array_Subtype_Definition => + return Disp_Type (Node, "array subtype"); + when Iir_Kind_Record_Type_Definition => + return Disp_Type (Node, "record type"); + when Iir_Kind_Record_Subtype_Definition => + return Disp_Type (Node, "record subtype"); + when Iir_Kind_Enumeration_Subtype_Definition => + return Disp_Type (Node, "enumeration subtype"); + when Iir_Kind_Integer_Subtype_Definition => + return Disp_Type (Node, "integer subtype"); + when Iir_Kind_Physical_Type_Definition => + return Disp_Type (Node, "physical type"); + when Iir_Kind_Physical_Subtype_Definition => + return Disp_Type (Node, "physical subtype"); + when Iir_Kind_File_Type_Definition => + return Disp_Type (Node, "file type"); + when Iir_Kind_Access_Type_Definition => + return Disp_Type (Node, "access type"); + when Iir_Kind_Access_Subtype_Definition => + return Disp_Type (Node, "access subtype"); + when Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition => + return Disp_Type (Node, "floating type"); + when Iir_Kind_Incomplete_Type_Definition => + return Disp_Type (Node, "incomplete type"); + when Iir_Kind_Protected_Type_Declaration => + return Disp_Type (Node, "protected type"); + when Iir_Kind_Protected_Type_Body => + return Disp_Type (Node, "protected type body"); + when Iir_Kind_Subtype_Definition => + return "subtype definition"; + + when Iir_Kind_Scalar_Nature_Definition => + return Image_Identifier (Get_Nature_Declarator (Node)); + + when Iir_Kind_Choice_By_Expression => + return "choice by expression"; + when Iir_Kind_Choice_By_Range => + return "choice by range"; + when Iir_Kind_Choice_By_Name => + return "choice by name"; + when Iir_Kind_Choice_By_Others => + return "others choice"; + when Iir_Kind_Choice_By_None => + return "positionnal choice"; + + when Iir_Kind_Function_Call => + return "function call"; + when Iir_Kind_Procedure_Call_Statement => + return "procedure call statement"; + when Iir_Kind_Procedure_Call => + return "procedure call"; + when Iir_Kind_Selected_Name => + Name_Table.Image (Get_Identifier (Node)); + return ''' + & Name_Table.Name_Buffer (1 .. Name_Table.Name_Length) + & '''; + when Iir_Kind_Simple_Name => + Name_Table.Image (Get_Identifier (Node)); + return ''' + & Name_Table.Name_Buffer (1 .. Name_Table.Name_Length) + & '''; + when Iir_Kind_Entity_Aspect_Entity => + return "aspect " & Disp_Node (Get_Entity (Node)) + & '(' & Image_Identifier (Get_Architecture (Node)) & ')'; + when Iir_Kind_Entity_Aspect_Configuration => + return "configuration entity aspect"; + when Iir_Kind_Entity_Aspect_Open => + return "open entity aspect"; + + when Iir_Kinds_Monadic_Operator + | Iir_Kinds_Dyadic_Operator => + return "operator """ + & Name_Table.Image (Get_Operator_Name (Node)) & """"; + when Iir_Kind_Parenthesis_Expression => + return "expression"; + when Iir_Kind_Qualified_Expression => + return "qualified expression"; + when Iir_Kind_Type_Conversion => + return "type conversion"; + when Iir_Kind_Allocator_By_Subtype + | Iir_Kind_Allocator_By_Expression => + return "allocator"; + when Iir_Kind_Indexed_Name => + return "indexed name"; + when Iir_Kind_Range_Expression => + return "range expression"; + when Iir_Kind_Implicit_Dereference => + return "implicit access dereference"; + when Iir_Kind_Dereference => + return "access dereference"; + when Iir_Kind_Selected_Element => + return "selected element"; + when Iir_Kind_Selected_By_All_Name => + return ".all name"; + when Iir_Kind_Psl_Expression => + return "PSL instantiation"; + + when Iir_Kind_Interface_Constant_Declaration => + if Get_Parent (Node) = Null_Iir then + -- For constant interface of predefined operator. + return "anonymous interface"; + end if; + case Get_Kind (Get_Parent (Node)) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Block_Statement + | Iir_Kind_Block_Header => + return Disp_Identifier (Node, "generic"); + when others => + return Disp_Identifier (Node, "constant interface"); + end case; + when Iir_Kind_Interface_Signal_Declaration => + case Get_Kind (Get_Parent (Node)) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Block_Statement + | Iir_Kind_Block_Header => + return Disp_Identifier (Node, "port"); + when others => + return Disp_Identifier (Node, "signal interface"); + end case; + when Iir_Kind_Interface_Variable_Declaration => + return Disp_Identifier (Node, "variable interface"); + when Iir_Kind_Interface_File_Declaration => + return Disp_Identifier (Node, "file interface"); + when Iir_Kind_Interface_Package_Declaration => + return Disp_Identifier (Node, "package interface"); + when Iir_Kind_Signal_Declaration => + return Disp_Identifier (Node, "signal"); + when Iir_Kind_Variable_Declaration => + return Disp_Identifier (Node, "variable"); + when Iir_Kind_Iterator_Declaration + | Iir_Kind_Constant_Declaration => + return Disp_Identifier (Node, "constant"); + when Iir_Kind_File_Declaration => + return Disp_Identifier (Node, "file"); + when Iir_Kind_Object_Alias_Declaration => + return Disp_Identifier (Node, "alias"); + when Iir_Kind_Non_Object_Alias_Declaration => + return Disp_Identifier (Node, "non-object alias"); + when Iir_Kind_Guard_Signal_Declaration => + return "GUARD signal"; + when Iir_Kind_Group_Template_Declaration => + return Disp_Identifier (Node, "group template"); + when Iir_Kind_Group_Declaration => + return Disp_Identifier (Node, "group"); + + when Iir_Kind_Library_Declaration + | Iir_Kind_Library_Clause => + return Disp_Identifier (Node, "library"); + when Iir_Kind_Design_File => + return "design file"; + + when Iir_Kind_Procedure_Declaration => + return Disp_Identifier (Node, "procedure"); + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + return "subprogram body"; + when Iir_Kind_Function_Declaration => + return Disp_Identifier (Node, "function"); + + when Iir_Kind_Package_Declaration => + return Disp_Identifier (Node, "package"); + when Iir_Kind_Package_Body => + return Disp_Identifier (Node, "package body"); + when Iir_Kind_Entity_Declaration => + return Disp_Identifier (Node, "entity"); + when Iir_Kind_Architecture_Body => + return Disp_Identifier (Node, "architecture") & + " of" & Disp_Identifier (Get_Entity_Name (Node), ""); + when Iir_Kind_Configuration_Declaration => + declare + Id : Name_Id; + Ent : Iir; + Arch : Iir; + begin + Id := Get_Identifier (Node); + if Id /= Null_Identifier then + return Disp_Identifier (Node, "configuration"); + else + Ent := Get_Entity (Node); + Arch := Get_Block_Specification + (Get_Block_Configuration (Node)); + return "default configuration of " + & Image_Identifier (Ent) + & '(' & Image_Identifier (Arch) & ')'; + end if; + end; + when Iir_Kind_Package_Instantiation_Declaration => + return Disp_Identifier (Node, "instantiation package"); + + when Iir_Kind_Package_Header => + return "package header"; + + when Iir_Kind_Component_Declaration => + return Disp_Identifier (Node, "component"); + + when Iir_Kind_Design_Unit => + return Disp_Node (Get_Library_Unit (Node)); + when Iir_Kind_Use_Clause => + return "use clause"; + when Iir_Kind_Disconnection_Specification => + return "disconnection specification"; + + when Iir_Kind_Slice_Name => + return "slice"; + when Iir_Kind_Parenthesis_Name => + return "function call, slice or indexed name"; + when Iir_Kind_Type_Declaration => + return Disp_Identifier (Node, "type"); + when Iir_Kind_Anonymous_Type_Declaration => + return Disp_Identifier (Node, "type"); + when Iir_Kind_Subtype_Declaration => + return Disp_Identifier (Node, "subtype"); + + when Iir_Kind_Nature_Declaration => + return Disp_Identifier (Node, "nature"); + when Iir_Kind_Subnature_Declaration => + return Disp_Identifier (Node, "subnature"); + + when Iir_Kind_Component_Instantiation_Statement => + return Disp_Identifier (Node, "component instance"); + when Iir_Kind_Configuration_Specification => + return "configuration specification"; + when Iir_Kind_Component_Configuration => + return "component configuration"; + when Iir_Kind_Implicit_Function_Declaration => + return Disp_Identifier (Node, "implicit function") + & Disp_Identifier (Get_Type_Reference (Node), " of type"); +-- return "implicit function " +-- & Get_Predefined_Function_Name +-- (Get_Implicit_Definition (Node)); + when Iir_Kind_Implicit_Procedure_Declaration => + return "implicit procedure " + & Get_Predefined_Function_Name (Get_Implicit_Definition (Node)); + + when Iir_Kind_Concurrent_Procedure_Call_Statement => + return "concurrent procedure call"; + when Iir_Kind_Generate_Statement => + return "generate statement"; + + when Iir_Kind_Simple_Simultaneous_Statement => + return "simple simultaneous statement"; + + when Iir_Kind_Psl_Declaration => + return Disp_Identifier (Node, "PSL declaration"); + + when Iir_Kind_Terminal_Declaration => + return Disp_Identifier (Node, "terminal declaration"); + when Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + return Disp_Identifier (Node, "quantity declaration"); + + when Iir_Kind_Attribute_Declaration => + return Disp_Identifier (Node, "attribute"); + when Iir_Kind_Attribute_Specification => + return "attribute specification"; + when Iir_Kind_Entity_Class => + return "entity class"; + when Iir_Kind_Attribute_Value => + return "attribute value"; + when Iir_Kind_Attribute_Name => + return "attribute"; + when Iir_Kind_Base_Attribute => + return "'base attribute"; + when Iir_Kind_Length_Array_Attribute => + return "'length attribute"; + when Iir_Kind_Range_Array_Attribute => + return "'range attribute"; + when Iir_Kind_Reverse_Range_Array_Attribute => + return "'reverse_range attribute"; + when Iir_Kind_Ascending_Type_Attribute + | Iir_Kind_Ascending_Array_Attribute => + return "'ascending attribute"; + when Iir_Kind_Left_Type_Attribute + | Iir_Kind_Left_Array_Attribute => + return "'left attribute"; + when Iir_Kind_Right_Type_Attribute + | Iir_Kind_Right_Array_Attribute => + return "'right attribute"; + when Iir_Kind_Low_Type_Attribute + | Iir_Kind_Low_Array_Attribute => + return "'low attribute"; + when Iir_Kind_Leftof_Attribute => + return "'leftof attribute"; + when Iir_Kind_Rightof_Attribute => + return "'rightof attribute"; + when Iir_Kind_Pred_Attribute => + return "'pred attribute"; + when Iir_Kind_Succ_Attribute => + return "'succ attribute"; + when Iir_Kind_Pos_Attribute => + return "'pos attribute"; + when Iir_Kind_Val_Attribute => + return "'val attribute"; + when Iir_Kind_Image_Attribute => + return "'image attribute"; + when Iir_Kind_Value_Attribute => + return "'value attribute"; + when Iir_Kind_High_Type_Attribute + | Iir_Kind_High_Array_Attribute => + return "'high attribute"; + when Iir_Kind_Transaction_Attribute => + return "'transaction attribute"; + when Iir_Kind_Stable_Attribute => + return "'stable attribute"; + when Iir_Kind_Quiet_Attribute => + return "'quiet attribute"; + when Iir_Kind_Delayed_Attribute => + return "'delayed attribute"; + when Iir_Kind_Driving_Attribute => + return "'driving attribute"; + when Iir_Kind_Driving_Value_Attribute => + return "'driving_value attribute"; + when Iir_Kind_Event_Attribute => + return "'event attribute"; + when Iir_Kind_Active_Attribute => + return "'active attribute"; + when Iir_Kind_Last_Event_Attribute => + return "'last_event attribute"; + when Iir_Kind_Last_Active_Attribute => + return "'last_active attribute"; + when Iir_Kind_Last_Value_Attribute => + return "'last_value attribute"; + when Iir_Kind_Behavior_Attribute => + return "'behavior attribute"; + when Iir_Kind_Structure_Attribute => + return "'structure attribute"; + + when Iir_Kind_Path_Name_Attribute => + return "'path_name attribute"; + when Iir_Kind_Instance_Name_Attribute => + return "'instance_name attribute"; + when Iir_Kind_Simple_Name_Attribute => + return "'simple_name attribute"; + + when Iir_Kind_For_Loop_Statement => + return Disp_Label (Node, "for loop statement"); + when Iir_Kind_While_Loop_Statement => + return Disp_Label (Node, "loop statement"); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + return Disp_Label (Node, "process"); + when Iir_Kind_Block_Statement => + return Disp_Label (Node, "block statement"); + when Iir_Kind_Block_Header => + return "block header"; + when Iir_Kind_Concurrent_Conditional_Signal_Assignment => + return Disp_Label + (Node, "concurrent conditional signal assignment"); + when Iir_Kind_Concurrent_Selected_Signal_Assignment => + return Disp_Label + (Node, "concurrent selected signal assignment"); + when Iir_Kind_Concurrent_Assertion_Statement => + return Disp_Label (Node, "concurrent assertion"); + when Iir_Kind_Psl_Assert_Statement => + return Disp_Label (Node, "PSL assertion"); + when Iir_Kind_Psl_Cover_Statement => + return Disp_Label (Node, "PSL cover"); + when Iir_Kind_Psl_Default_Clock => + return "PSL default clock"; + + when Iir_Kind_If_Statement => + return Disp_Label (Node, "if statement"); + when Iir_Kind_Elsif => + return Disp_Label (Node, "else/elsif statement"); + when Iir_Kind_Next_Statement => + return Disp_Label (Node, "next statement"); + when Iir_Kind_Exit_Statement => + return Disp_Label (Node, "exit statement"); + when Iir_Kind_Case_Statement => + return Disp_Label (Node, "case statement"); + when Iir_Kind_Return_Statement => + return Disp_Label (Node, "return statement"); + when Iir_Kind_Signal_Assignment_Statement => + return Disp_Label (Node, "signal assignment statement"); + when Iir_Kind_Variable_Assignment_Statement => + return Disp_Label (Node, "variable assignment statement"); + when Iir_Kind_Null_Statement => + return Disp_Label (Node, "null statement"); + when Iir_Kind_Wait_Statement => + return Disp_Label (Node, "wait statement"); + when Iir_Kind_Assertion_Statement => + return Disp_Label (Node, "assertion statement"); + when Iir_Kind_Report_Statement => + return Disp_Label (Node, "report statement"); + + when Iir_Kind_Block_Configuration => + return "block configuration"; + when Iir_Kind_Binding_Indication => + return "binding indication"; + + when Iir_Kind_Error => + return "error"; + when Iir_Kind_Unused => + return "*unused*"; + end case; + end Disp_Node; + + -- Disp a node location. + -- Used for output of message. + + function Get_Location_Str + (Name : Name_Id; Line, Col : Natural; Filename : Boolean) + return String + is + Line_Str : constant String := Natural'Image (Line); + Col_Str : constant String := Natural'Image (Col); + begin + if Filename then + return Name_Table.Image (Name) + & ':' & Line_Str (Line_Str'First + 1 .. Line_Str'Last) + & ':' & Col_Str (Col_Str'First + 1 .. Col_Str'Last); + else + return Line_Str (Line_Str'First + 1 .. Line_Str'Last) + & ':' & Col_Str (Col_Str'First + 1 .. Col_Str'Last); + end if; + end Get_Location_Str; + + function Get_Location_Str (Loc : Location_Type; Filename : Boolean := True) + return string + is + Line, Col : Natural; + Name : Name_Id; + begin + if Loc = Location_Nil then + -- Avoid a crash. + return "??:??:??"; + else + Location_To_Position (Loc, Name, Line, Col); + return Get_Location_Str (Name, Line, Col, Filename); + end if; + end Get_Location_Str; + + function Disp_Location (Node: Iir) return String is + begin + return Get_Location_Str (Get_Location (Node)); + end Disp_Location; + + function Disp_Name (Kind : Iir_Kind) return String is + begin + case Kind is + when Iir_Kind_Constant_Declaration => + return "constant declaration"; + when Iir_Kind_Signal_Declaration => + return "signal declaration"; + when Iir_Kind_Variable_Declaration => + return "variable declaration"; + when Iir_Kind_File_Declaration => + return "file declaration"; + when others => + return "???" & Iir_Kind'Image (Kind); + end case; + end Disp_Name; + + function Image (N : Iir_Int64) return String + is + Res : constant String := Iir_Int64'Image (N); + begin + if Res (1) = ' ' then + return Res (2 .. Res'Last); + else + return Res; + end if; + end Image; + + function Disp_Discrete (Dtype : Iir; Pos : Iir_Int64) return String is + begin + case Get_Kind (Dtype) is + when Iir_Kind_Integer_Type_Definition => + return Image (Pos); + when Iir_Kind_Enumeration_Type_Definition => + return Name_Table.Image + (Get_Identifier (Get_Nth_Element + (Get_Enumeration_Literal_List (Dtype), + Natural (Pos)))); + when others => + Error_Kind ("disp_discrete", Dtype); + end case; + end Disp_Discrete; + + function Disp_Subprg (Subprg : Iir) return String + is + use Ada.Strings.Unbounded; + Res : Unbounded_String; + + procedure Append_Type (Def : Iir) + is + use Name_Table; + Decl : Iir := Get_Type_Declarator (Def); + begin + if Decl = Null_Iir then + Decl := Get_Type_Declarator (Get_Base_Type (Def)); + end if; + Image (Get_Identifier (Decl)); + Append (Res, Name_Buffer (1 .. Name_Length)); + end Append_Type; + + begin + case Get_Kind (Subprg) is + when Iir_Kind_Enumeration_Literal => + Append (Res, "enumeration literal "); + when Iir_Kind_Implicit_Function_Declaration => + Append (Res, "implicit function "); + when Iir_Kind_Implicit_Procedure_Declaration => + Append (Res, "implicit procedure "); + when Iir_Kind_Function_Declaration => + Append (Res, "function "); + when Iir_Kind_Procedure_Declaration => + Append (Res, "procedure "); + when others => + Error_Kind ("disp_subprg", Subprg); + end case; + + declare + use Name_Table; + + Id : constant Name_Id := Get_Identifier (Subprg); + begin + Image (Id); + case Id is + when Std_Names.Name_Id_Operators + | Std_Names.Name_Word_Operators + | Std_Names.Name_Xnor + | Std_Names.Name_Shift_Operators => + Append (Res, """"); + Append (Res, Name_Buffer (1 .. Name_Length)); + Append (Res, """"); + when others => + Append (Res, Name_Buffer (1 .. Name_Length)); + end case; + end; + + Append (Res, " ["); + + case Get_Kind (Subprg) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + declare + El : Iir; + begin + El := Get_Interface_Declaration_Chain (Subprg); + while El /= Null_Iir loop + Append_Type (Get_Type (El)); + El := Get_Chain (El); + exit when El = Null_Iir; + Append (Res, ", "); + end loop; + end; + when others => + null; + end case; + + case Get_Kind (Subprg) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Enumeration_Literal => + Append (Res, " return "); + Append_Type (Get_Return_Type (Subprg)); + when others => + null; + end case; + + Append (Res, "]"); + + return To_String (Res); + end Disp_Subprg; + + -- DEF must be any type definition. + -- Return the type name of DEF, handle anonymous subtypes. + function Disp_Type_Name (Def : Iir) return String + is + Decl : Iir; + begin + Decl := Get_Type_Declarator (Def); + if Decl /= Null_Iir then + return Image_Identifier (Decl); + end if; + Decl := Get_Type_Declarator (Get_Base_Type (Def)); + if Decl /= Null_Iir then + return "a subtype of " & Image_Identifier (Decl); + else + return "an unknown type"; + end if; + end Disp_Type_Name; + + function Disp_Type_Of (Node : Iir) return String + is + A_Type : Iir; + begin + A_Type := Get_Type (Node); + if A_Type = Null_Iir then + return "unknown"; + elsif Get_Kind (A_Type) = Iir_Kind_Overload_List then + declare + use Ada.Strings.Unbounded; + Res : Unbounded_String; + List : Iir_List; + El : Iir; + Nbr : Natural; + begin + List := Get_Overload_List (A_Type); + Nbr := Get_Nbr_Elements (List); + if Nbr = 0 then + return "unknown"; + elsif Nbr = 1 then + return Disp_Type_Name (Get_First_Element (List)); + else + Append (Res, "one of "); + for I in 0 .. Nbr - 1 loop + El := Get_Nth_Element (List, I); + Append (Res, Disp_Type_Name (El)); + if I < Nbr - 2 then + Append (Res, ", "); + elsif I = Nbr - 2 then + Append (Res, " or "); + end if; + end loop; + return To_String (Res); + end if; + end; + else + return Disp_Type_Name (A_Type); + end if; + end Disp_Type_Of; + + procedure Error_Pure (Caller : Iir; Callee : Iir; Loc : Iir) + is + L : Location_Type; + begin + if Loc = Null_Iir then + L := Get_Location (Caller); + else + L := Get_Location (Loc); + end if; + Error_Msg_Sem + ("pure " & Disp_Node (Caller) & " cannot call (impure) " + & Disp_Node (Callee), L); + Error_Msg_Sem + ("(" & Disp_Node (Callee) & " is defined here)", Callee); + end Error_Pure; + + procedure Error_Not_Match (Expr: Iir; A_Type: Iir; Loc : Iir) + is + begin + Error_Msg_Sem ("can't match " & Disp_Node (Expr) & " with type " + & Disp_Node (A_Type), Loc); + if Loc /= Expr then + Error_Msg_Sem ("(location of " & Disp_Node (Expr) & ")", Expr); + end if; + end Error_Not_Match; + + function Get_Mode_Name (Mode : Iir_Mode) return String is + begin + case Mode is + when Iir_Unknown_Mode => + raise Internal_Error; + when Iir_Linkage_Mode => + return "linkage"; + when Iir_Buffer_Mode => + return "buffer"; + when Iir_Out_Mode => + return "out"; + when Iir_Inout_Mode => + return "inout"; + when Iir_In_Mode => + return "in"; + end case; + end Get_Mode_Name; + +end Errorout; diff --git a/src/vhdl/errorout.ads b/src/vhdl/errorout.ads new file mode 100644 index 000000000..ce694fe37 --- /dev/null +++ b/src/vhdl/errorout.ads @@ -0,0 +1,128 @@ +-- Error message handling. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Iirs; use Iirs; + +package Errorout is + Option_Error: exception; + Parse_Error: exception; + Compilation_Error: exception; + + -- This kind can't be handled. + --procedure Error_Kind (Msg: String; Kind: Iir_Kind); + procedure Error_Kind (Msg: String; An_Iir: in Iir); + procedure Error_Kind (Msg: String; Def : Iir_Predefined_Functions); + procedure Error_Kind (Msg : String; N : PSL_Node); + pragma No_Return (Error_Kind); + + -- The number of errors (ie, number of calls to error_msg*). + Nbr_Errors: Natural := 0; + + -- Disp an error, prepended with program name. + procedure Error_Msg (Msg: String); + + -- Disp an error, prepended with program name, and raise option_error. + -- This is used for errors before initialisation, such as bad option or + -- bad filename. + procedure Error_Msg_Option (Msg: String); + pragma No_Return (Error_Msg_Option); + + -- Same as Error_Msg_Option but do not raise Option_Error. + procedure Error_Msg_Option_NR (Msg: String); + + -- Disp an error location (using AN_IIR location) using the standard + -- format `file:line:col: '. + procedure Disp_Iir_Location (An_Iir: Iir); + + -- Disp a warning. + procedure Warning_Msg (Msg: String); + procedure Warning_Msg_Parse (Msg: String); + procedure Warning_Msg_Sem (Msg: String; Loc : Iir); + procedure Warning_Msg_Sem (Msg: String; Loc : Location_Type); + + -- Disp a message during scan. + -- The current location is automatically displayed before the message. + procedure Error_Msg_Scan (Msg: String); + procedure Error_Msg_Scan (Msg: String; Loc : Location_Type); + procedure Warning_Msg_Scan (Msg: String); + + -- Disp a message during parse + -- The location of the current token is automatically displayed before + -- the message. + procedure Error_Msg_Parse (Msg: String); + procedure Error_Msg_Parse (Msg: String; Loc : Iir); + procedure Error_Msg_Parse (Msg: String; Loc : Location_Type); + + -- Disp a message during semantic analysis. + -- an_iir is used for location and current token. + procedure Error_Msg_Sem (Msg: String; Loc: Iir); + procedure Error_Msg_Sem (Msg: String; Loc: PSL_Node); + procedure Error_Msg_Sem (Msg: String; Loc: Location_Type); + + -- Disp a message during elaboration (or configuration). + procedure Error_Msg_Elab (Msg: String); + procedure Error_Msg_Elab (Msg: String; Loc: Iir); + + -- Disp a warning durig elaboration (or configuration). + procedure Warning_Msg_Elab (Msg: String; Loc : Iir); + + -- Disp a bug message. + procedure Error_Internal (Expr: Iir; Msg: String := ""); + pragma No_Return (Error_Internal); + + -- Disp a node. + -- Used for output of message. + function Disp_Node (Node: Iir) return String; + + -- Disp a node location. + -- Used for output of message. + function Disp_Location (Node: Iir) return String; + function Get_Location_Str (Loc : Location_Type; Filename : Boolean := True) + return String; + + -- Disp non-terminal name from KIND. + function Disp_Name (Kind : Iir_Kind) return String; + + -- SUBPRG must be a subprogram declaration or an enumeration literal + -- declaration. + -- Returns: + -- "enumeration literal XX [ return TYPE ]" + -- "function XXX [ TYPE1, TYPE2 return TYPE ]" + -- "procedure XXX [ TYPE1, TYPE2 ]" + -- "implicit function XXX [ TYPE1, TYPE2 return TYPE ]" + -- "implicit procedure XXX [ TYPE1, TYPE2 ]" + function Disp_Subprg (Subprg : Iir) return String; + + -- Print element POS of discrete type DTYPE. + function Disp_Discrete (Dtype : Iir; Pos : Iir_Int64) return String; + + -- Disp the name of the type of NODE if known. + -- Disp "unknown" if it is not known. + -- Disp all possible types if it is an overload list. + function Disp_Type_Of (Node : Iir) return String; + + -- Disp an error message when a pure function CALLER calls impure CALLEE. + procedure Error_Pure (Caller : Iir; Callee : Iir; Loc : Iir); + + -- Report an error message as type of EXPR does not match A_TYPE. + -- Location is LOC. + procedure Error_Not_Match (Expr: Iir; A_Type: Iir; Loc : Iir); + + -- Disp interface mode MODE. + function Get_Mode_Name (Mode : Iir_Mode) return String; +end Errorout; diff --git a/src/vhdl/evaluation.adb b/src/vhdl/evaluation.adb new file mode 100644 index 000000000..8279e140c --- /dev/null +++ b/src/vhdl/evaluation.adb @@ -0,0 +1,3047 @@ +-- Evaluation of static expressions. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Unchecked_Deallocation; +with Errorout; use Errorout; +with Name_Table; use Name_Table; +with Str_Table; +with Iirs_Utils; use Iirs_Utils; +with Std_Package; use Std_Package; +with Flags; use Flags; +with Std_Names; +with Ada.Characters.Handling; + +package body Evaluation is + function Get_Physical_Value (Expr : Iir) return Iir_Int64 + is + pragma Unsuppress (Overflow_Check); + Kind : constant Iir_Kind := Get_Kind (Expr); + Unit : Iir; + begin + case Kind is + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal => + -- Extract Unit. + Unit := Get_Physical_Unit_Value + (Get_Named_Entity (Get_Unit_Name (Expr))); + case Kind is + when Iir_Kind_Physical_Int_Literal => + return Get_Value (Expr) * Get_Value (Unit); + when Iir_Kind_Physical_Fp_Literal => + return Iir_Int64 + (Get_Fp_Value (Expr) * Iir_Fp64 (Get_Value (Unit))); + when others => + raise Program_Error; + end case; + when Iir_Kind_Unit_Declaration => + return Get_Value (Get_Physical_Unit_Value (Expr)); + when others => + Error_Kind ("get_physical_value", Expr); + end case; + exception + when Constraint_Error => + Error_Msg_Sem ("arithmetic overflow in physical expression", Expr); + return Get_Value (Expr); + end Get_Physical_Value; + + function Build_Integer (Val : Iir_Int64; Origin : Iir) + return Iir_Integer_Literal + is + Res : Iir_Integer_Literal; + begin + Res := Create_Iir (Iir_Kind_Integer_Literal); + Location_Copy (Res, Origin); + Set_Value (Res, Val); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Integer; + + function Build_Floating (Val : Iir_Fp64; Origin : Iir) + return Iir_Floating_Point_Literal + is + Res : Iir_Floating_Point_Literal; + begin + Res := Create_Iir (Iir_Kind_Floating_Point_Literal); + Location_Copy (Res, Origin); + Set_Fp_Value (Res, Val); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Floating; + + function Build_Enumeration_Constant (Val : Iir_Index32; Origin : Iir) + return Iir_Enumeration_Literal + is + Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); + Enum_List : constant Iir_List := + Get_Enumeration_Literal_List (Enum_Type); + Lit : constant Iir_Enumeration_Literal := + Get_Nth_Element (Enum_List, Integer (Val)); + Res : Iir_Enumeration_Literal; + begin + Res := Copy_Enumeration_Literal (Lit); + Location_Copy (Res, Origin); + Set_Literal_Origin (Res, Origin); + return Res; + end Build_Enumeration_Constant; + + function Build_Physical (Val : Iir_Int64; Origin : Iir) + return Iir_Physical_Int_Literal + is + Res : Iir_Physical_Int_Literal; + Unit_Name : Iir; + begin + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Location_Copy (Res, Origin); + Unit_Name := Get_Primary_Unit_Name (Get_Base_Type (Get_Type (Origin))); + Set_Unit_Name (Res, Unit_Name); + Set_Value (Res, Val); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Physical; + + function Build_Discrete (Val : Iir_Int64; Origin : Iir) return Iir is + begin + case Get_Kind (Get_Type (Origin)) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + return Build_Enumeration_Constant (Iir_Index32 (Val), Origin); + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + return Build_Integer (Val, Origin); + when others => + Error_Kind ("build_discrete", Get_Type (Origin)); + end case; + end Build_Discrete; + + function Build_String (Val : String_Id; Len : Nat32; Origin : Iir) + return Iir_String_Literal + is + Res : Iir_String_Literal; + begin + Res := Create_Iir (Iir_Kind_String_Literal); + Location_Copy (Res, Origin); + Set_String_Id (Res, Val); + Set_String_Length (Res, Len); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_String; + + function Build_Simple_Aggregate + (El_List : Iir_List; Origin : Iir; Stype : Iir) + return Iir_Simple_Aggregate + is + Res : Iir_Simple_Aggregate; + begin + Res := Create_Iir (Iir_Kind_Simple_Aggregate); + Location_Copy (Res, Origin); + Set_Simple_Aggregate_List (Res, El_List); + Set_Type (Res, Stype); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + Set_Literal_Subtype (Res, Stype); + return Res; + end Build_Simple_Aggregate; + + function Build_Overflow (Origin : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Overflow_Literal); + Location_Copy (Res, Origin); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Overflow; + + function Build_Constant (Val : Iir; Origin : Iir) return Iir + is + Res : Iir; + begin + -- Note: this must work for any literals, because it may be used to + -- replace a locally static constant by its initial value. + case Get_Kind (Val) is + when Iir_Kind_Integer_Literal => + Res := Create_Iir (Iir_Kind_Integer_Literal); + Set_Value (Res, Get_Value (Val)); + + when Iir_Kind_Floating_Point_Literal => + Res := Create_Iir (Iir_Kind_Floating_Point_Literal); + Set_Fp_Value (Res, Get_Fp_Value (Val)); + + when Iir_Kind_Enumeration_Literal => + return Build_Enumeration_Constant + (Iir_Index32 (Get_Enum_Pos (Val)), Origin); + + when Iir_Kind_Physical_Int_Literal => + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Set_Unit_Name (Res, Get_Primary_Unit_Name + (Get_Base_Type (Get_Type (Origin)))); + Set_Value (Res, Get_Physical_Value (Val)); + + when Iir_Kind_Unit_Declaration => + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Set_Value (Res, Get_Physical_Value (Val)); + Set_Unit_Name (Res, Get_Primary_Unit_Name (Get_Type (Val))); + + when Iir_Kind_String_Literal => + Res := Create_Iir (Iir_Kind_String_Literal); + Set_String_Id (Res, Get_String_Id (Val)); + Set_String_Length (Res, Get_String_Length (Val)); + + when Iir_Kind_Bit_String_Literal => + Res := Create_Iir (Iir_Kind_Bit_String_Literal); + Set_String_Id (Res, Get_String_Id (Val)); + Set_String_Length (Res, Get_String_Length (Val)); + Set_Bit_String_Base (Res, Get_Bit_String_Base (Val)); + Set_Bit_String_0 (Res, Get_Bit_String_0 (Val)); + Set_Bit_String_1 (Res, Get_Bit_String_1 (Val)); + + when Iir_Kind_Simple_Aggregate => + Res := Create_Iir (Iir_Kind_Simple_Aggregate); + Set_Simple_Aggregate_List (Res, Get_Simple_Aggregate_List (Val)); + Set_Literal_Subtype (Res, Get_Type (Origin)); + + when Iir_Kind_Overflow_Literal => + Res := Create_Iir (Iir_Kind_Overflow_Literal); + + when others => + Error_Kind ("build_constant", Val); + end case; + Location_Copy (Res, Origin); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Constant; + + function Build_Boolean (Cond : Boolean) return Iir is + begin + if Cond then + return Boolean_True; + else + return Boolean_False; + end if; + end Build_Boolean; + + function Build_Enumeration (Val : Iir_Index32; Origin : Iir) + return Iir_Enumeration_Literal + is + Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); + Enum_List : constant Iir_List := + Get_Enumeration_Literal_List (Enum_Type); + begin + return Get_Nth_Element (Enum_List, Integer (Val)); + end Build_Enumeration; + + function Build_Enumeration (Val : Boolean; Origin : Iir) + return Iir_Enumeration_Literal + is + Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); + Enum_List : constant Iir_List := + Get_Enumeration_Literal_List (Enum_Type); + begin + return Get_Nth_Element (Enum_List, Boolean'Pos (Val)); + end Build_Enumeration; + + function Build_Constant_Range (Range_Expr : Iir; Origin : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Res, Origin); + Set_Type (Res, Get_Type (Range_Expr)); + Set_Left_Limit (Res, Get_Left_Limit (Range_Expr)); + Set_Right_Limit (Res, Get_Right_Limit (Range_Expr)); + Set_Direction (Res, Get_Direction (Range_Expr)); + Set_Range_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Constant_Range; + + function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir + is + Orig_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); + begin + case Get_Kind (Orig_Type) is + when Iir_Kind_Integer_Type_Definition => + if Is_Pos then + return Build_Integer (Iir_Int64'Last, Origin); + else + return Build_Integer (Iir_Int64'First, Origin); + end if; + when others => + Error_Kind ("build_extreme_value", Orig_Type); + end case; + end Build_Extreme_Value; + + -- A_RANGE is a range expression, whose type, location, expr_staticness, + -- left_limit and direction are set. + -- Type of A_RANGE must have a range_constraint. + -- Set the right limit of A_RANGE from LEN. + procedure Set_Right_Limit_By_Length (A_Range : Iir; Len : Iir_Int64) + is + Left, Right : Iir; + Pos : Iir_Int64; + A_Type : Iir; + begin + if Get_Expr_Staticness (A_Range) /= Locally then + raise Internal_Error; + end if; + A_Type := Get_Type (A_Range); + + Left := Get_Left_Limit (A_Range); + + Pos := Eval_Pos (Left); + case Get_Direction (A_Range) is + when Iir_To => + Pos := Pos + Len -1; + when Iir_Downto => + Pos := Pos - Len + 1; + end case; + if Len > 0 + and then not Eval_Int_In_Range (Pos, Get_Range_Constraint (A_Type)) + then + Error_Msg_Sem ("range length is beyond subtype length", A_Range); + Right := Left; + else + -- FIXME: what about nul range? + Right := Build_Discrete (Pos, A_Range); + Set_Literal_Origin (Right, Null_Iir); + end if; + Set_Right_Limit (A_Range, Right); + end Set_Right_Limit_By_Length; + + -- Create a range of type A_TYPE whose length is LEN. + -- Note: only two nodes are created: + -- * the range_expression (node returned) + -- * the right bound + -- The left bound *IS NOT* created, but points to the left bound of A_TYPE. + function Create_Range_By_Length + (A_Type : Iir; Len : Iir_Int64; Loc : Location_Type) + return Iir + is + Index_Constraint : Iir; + Constraint : Iir; + begin + -- The left limit must be locally static in order to compute the right + -- limit. + pragma Assert (Get_Type_Staticness (A_Type) = Locally); + + Index_Constraint := Get_Range_Constraint (A_Type); + Constraint := Create_Iir (Iir_Kind_Range_Expression); + Set_Location (Constraint, Loc); + Set_Expr_Staticness (Constraint, Locally); + Set_Type (Constraint, A_Type); + Set_Left_Limit (Constraint, Get_Left_Limit (Index_Constraint)); + Set_Direction (Constraint, Get_Direction (Index_Constraint)); + Set_Right_Limit_By_Length (Constraint, Len); + return Constraint; + end Create_Range_By_Length; + + function Create_Range_Subtype_From_Type (A_Type : Iir; Loc : Location_Type) + return Iir + is + Res : Iir; + begin + pragma Assert (Get_Type_Staticness (A_Type) = Locally); + + case Get_Kind (A_Type) is + when Iir_Kind_Enumeration_Type_Definition => + Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Res := Create_Iir (Get_Kind (A_Type)); + when others => + Error_Kind ("create_range_subtype_by_length", A_Type); + end case; + Set_Location (Res, Loc); + Set_Base_Type (Res, Get_Base_Type (A_Type)); + Set_Type_Staticness (Res, Locally); + + return Res; + end Create_Range_Subtype_From_Type; + + -- Create a subtype of A_TYPE whose length is LEN. + -- This is used to create subtypes for strings or aggregates. + function Create_Range_Subtype_By_Length + (A_Type : Iir; Len : Iir_Int64; Loc : Location_Type) + return Iir + is + Res : Iir; + begin + Res := Create_Range_Subtype_From_Type (A_Type, Loc); + + Set_Range_Constraint (Res, Create_Range_By_Length (A_Type, Len, Loc)); + return Res; + end Create_Range_Subtype_By_Length; + + function Create_Unidim_Array_From_Index + (Base_Type : Iir; Index_Type : Iir; Loc : Iir) + return Iir_Array_Subtype_Definition + is + Res : Iir_Array_Subtype_Definition; + begin + Res := Create_Array_Subtype (Base_Type, Get_Location (Loc)); + 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; + + function Create_Unidim_Array_By_Length + (Base_Type : Iir; Len : Iir_Int64; Loc : Iir) + return Iir_Array_Subtype_Definition + is + Index_Type : constant Iir := Get_Index_Type (Base_Type, 0); + N_Index_Type : Iir; + begin + N_Index_Type := Create_Range_Subtype_By_Length + (Index_Type, Len, Get_Location (Loc)); + return Create_Unidim_Array_From_Index (Base_Type, N_Index_Type, Loc); + end Create_Unidim_Array_By_Length; + + procedure Free_Eval_Static_Expr (Res : Iir; Orig : Iir) is + begin + if Res /= Orig and then Get_Literal_Origin (Res) = Orig then + Free_Iir (Res); + end if; + end Free_Eval_Static_Expr; + + -- Free the result RES of Eval_String_Literal called with ORIG, if created. + procedure Free_Eval_String_Literal (Res : Iir; Orig : Iir) + is + L : Iir_List; + begin + if Res /= Orig then + L := Get_Simple_Aggregate_List (Res); + Destroy_Iir_List (L); + Free_Iir (Res); + end if; + end Free_Eval_String_Literal; + + function Eval_String_Literal (Str : Iir) return Iir + is + Ptr : String_Fat_Acc; + Len : Nat32; + begin + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + declare + Element_Type : Iir; + Literal_List : Iir_List; + Lit : Iir; + + List : Iir_List; + begin + Element_Type := Get_Base_Type + (Get_Element_Subtype (Get_Base_Type (Get_Type (Str)))); + Literal_List := Get_Enumeration_Literal_List (Element_Type); + List := Create_Iir_List; + + Ptr := Get_String_Fat_Acc (Str); + Len := Get_String_Length (Str); + + for I in 1 .. Len loop + Lit := Find_Name_In_List + (Literal_List, + Name_Table.Get_Identifier (Ptr (I))); + Append_Element (List, Lit); + end loop; + return Build_Simple_Aggregate (List, Str, Get_Type (Str)); + end; + + when Iir_Kind_Bit_String_Literal => + declare + Str_Type : constant Iir := Get_Type (Str); + List : Iir_List; + Lit_0 : constant Iir := Get_Bit_String_0 (Str); + Lit_1 : constant Iir := Get_Bit_String_1 (Str); + begin + List := Create_Iir_List; + + Ptr := Get_String_Fat_Acc (Str); + Len := Get_String_Length (Str); + + for I in 1 .. Len loop + case Ptr (I) is + when '0' => + Append_Element (List, Lit_0); + when '1' => + Append_Element (List, Lit_1); + when others => + raise Internal_Error; + end case; + end loop; + return Build_Simple_Aggregate (List, Str, Str_Type); + end; + + when Iir_Kind_Simple_Aggregate => + return Str; + + when others => + Error_Kind ("eval_string_literal", Str); + end case; + end Eval_String_Literal; + + function Eval_Monadic_Operator (Orig : Iir; Operand : Iir) return Iir + is + pragma Unsuppress (Overflow_Check); + + Func : Iir_Predefined_Functions; + begin + if Get_Kind (Operand) = Iir_Kind_Overflow_Literal then + -- Propagate overflow. + return Build_Overflow (Orig); + end if; + + Func := Get_Implicit_Definition (Get_Implementation (Orig)); + case Func is + when Iir_Predefined_Integer_Negation => + return Build_Integer (-Get_Value (Operand), Orig); + when Iir_Predefined_Integer_Identity => + return Build_Integer (Get_Value (Operand), Orig); + when Iir_Predefined_Integer_Absolute => + return Build_Integer (abs Get_Value (Operand), Orig); + + when Iir_Predefined_Floating_Negation => + return Build_Floating (-Get_Fp_Value (Operand), Orig); + when Iir_Predefined_Floating_Identity => + return Build_Floating (Get_Fp_Value (Operand), Orig); + when Iir_Predefined_Floating_Absolute => + return Build_Floating (abs Get_Fp_Value (Operand), Orig); + + when Iir_Predefined_Physical_Negation => + return Build_Physical (-Get_Physical_Value (Operand), Orig); + when Iir_Predefined_Physical_Identity => + return Build_Physical (Get_Physical_Value (Operand), Orig); + when Iir_Predefined_Physical_Absolute => + return Build_Physical (abs Get_Physical_Value (Operand), Orig); + + when Iir_Predefined_Boolean_Not + | Iir_Predefined_Bit_Not => + return Build_Enumeration (Get_Enum_Pos (Operand) = 0, Orig); + + when Iir_Predefined_TF_Array_Not => + declare + O_List : Iir_List; + R_List : Iir_List; + El : Iir; + Lit : Iir; + begin + O_List := Get_Simple_Aggregate_List + (Eval_String_Literal (Operand)); + R_List := Create_Iir_List; + + for I in Natural loop + El := Get_Nth_Element (O_List, I); + exit when El = Null_Iir; + case Get_Enum_Pos (El) is + when 0 => + Lit := Bit_1; + when 1 => + Lit := Bit_0; + when others => + raise Internal_Error; + end case; + Append_Element (R_List, Lit); + end loop; + return Build_Simple_Aggregate + (R_List, Orig, Get_Type (Operand)); + end; + when others => + Error_Internal (Orig, "eval_monadic_operator: " & + Iir_Predefined_Functions'Image (Func)); + end case; + exception + when Constraint_Error => + -- Can happen for absolute. + Warning_Msg_Sem ("arithmetic overflow in static expression", Orig); + return Build_Overflow (Orig); + end Eval_Monadic_Operator; + + function Eval_Dyadic_Bit_Array_Operator + (Expr : Iir; + Left, Right : Iir; + Func : Iir_Predefined_Dyadic_TF_Array_Functions) + return Iir + is + use Str_Table; + L_Str : constant String_Fat_Acc := Get_String_Fat_Acc (Left); + R_Str : constant String_Fat_Acc := Get_String_Fat_Acc (Right); + Len : Nat32; + Id : String_Id; + Res : Iir; + begin + Len := Get_String_Length (Left); + if Len /= Get_String_Length (Right) then + Warning_Msg_Sem ("length of left and right operands mismatch", Expr); + return Build_Overflow (Expr); + else + Id := Start; + case Func is + when Iir_Predefined_TF_Array_And => + for I in 1 .. Len loop + case L_Str (I) is + when '0' => + Append ('0'); + when '1' => + Append (R_Str (I)); + when others => + raise Internal_Error; + end case; + end loop; + when Iir_Predefined_TF_Array_Nand => + for I in 1 .. Len loop + case L_Str (I) is + when '0' => + Append ('1'); + when '1' => + case R_Str (I) is + when '0' => + Append ('1'); + when '1' => + Append ('0'); + when others => + raise Internal_Error; + end case; + when others => + raise Internal_Error; + end case; + end loop; + when Iir_Predefined_TF_Array_Or => + for I in 1 .. Len loop + case L_Str (I) is + when '1' => + Append ('1'); + when '0' => + Append (R_Str (I)); + when others => + raise Internal_Error; + end case; + end loop; + when Iir_Predefined_TF_Array_Nor => + for I in 1 .. Len loop + case L_Str (I) is + when '1' => + Append ('0'); + when '0' => + case R_Str (I) is + when '0' => + Append ('1'); + when '1' => + Append ('0'); + when others => + raise Internal_Error; + end case; + when others => + raise Internal_Error; + end case; + end loop; + when Iir_Predefined_TF_Array_Xor => + for I in 1 .. Len loop + case L_Str (I) is + when '1' => + case R_Str (I) is + when '0' => + Append ('1'); + when '1' => + Append ('0'); + when others => + raise Internal_Error; + end case; + when '0' => + case R_Str (I) is + when '0' => + Append ('0'); + when '1' => + Append ('1'); + when others => + raise Internal_Error; + end case; + when others => + raise Internal_Error; + end case; + end loop; + when others => + Error_Internal (Expr, "eval_dyadic_bit_array_functions: " & + Iir_Predefined_Functions'Image (Func)); + end case; + Finish; + Res := Build_String (Id, Len, Expr); + + -- The unconstrained type is replaced by the constrained one. + Set_Type (Res, Get_Type (Left)); + return Res; + end if; + end Eval_Dyadic_Bit_Array_Operator; + + -- Return TRUE if VAL /= 0. + function Check_Integer_Division_By_Zero (Expr : Iir; Val : Iir) + return Boolean + is + begin + if Get_Value (Val) = 0 then + Warning_Msg_Sem ("division by 0", Expr); + return False; + else + return True; + end if; + end Check_Integer_Division_By_Zero; + + function Eval_Shift_Operator + (Left, Right : Iir; Origin : Iir; Func : Iir_Predefined_Shift_Functions) + return Iir + is + Count : Iir_Int64; + Cnt : Natural; + Len : Natural; + Arr_List : Iir_List; + Res_List : Iir_List; + Dir_Left : Boolean; + E : Iir; + begin + Count := Get_Value (Right); + Arr_List := Get_Simple_Aggregate_List (Left); + Len := Get_Nbr_Elements (Arr_List); + -- LRM93 7.2.3 + -- That is, if R is 0 or if L is a null array, the return value is L. + if Count = 0 or Len = 0 then + return Build_Simple_Aggregate (Arr_List, Origin, Get_Type (Left)); + end if; + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Rol => + Dir_Left := True; + when Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Ror => + Dir_Left := False; + end case; + if Count < 0 then + Cnt := Natural (-Count); + Dir_Left := not Dir_Left; + else + Cnt := Natural (Count); + end if; + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl => + declare + Enum_List : Iir_List; + begin + Enum_List := Get_Enumeration_Literal_List + (Get_Base_Type (Get_Element_Subtype (Get_Type (Left)))); + E := Get_Nth_Element (Enum_List, 0); + end; + when Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Dir_Left then + E := Get_Nth_Element (Arr_List, Len - 1); + else + E := Get_Nth_Element (Arr_List, 0); + end if; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + Cnt := Cnt mod Len; + if not Dir_Left then + Cnt := (Len - Cnt) mod Len; + end if; + end case; + + Res_List := Create_Iir_List; + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Dir_Left then + if Cnt < Len then + for I in Cnt .. Len - 1 loop + Append_Element + (Res_List, Get_Nth_Element (Arr_List, I)); + end loop; + else + Cnt := Len; + end if; + for I in 0 .. Cnt - 1 loop + Append_Element (Res_List, E); + end loop; + else + if Cnt > Len then + Cnt := Len; + end if; + for I in 0 .. Cnt - 1 loop + Append_Element (Res_List, E); + end loop; + for I in Cnt .. Len - 1 loop + Append_Element + (Res_List, Get_Nth_Element (Arr_List, I - Cnt)); + end loop; + end if; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + for I in 1 .. Len loop + Append_Element + (Res_List, Get_Nth_Element (Arr_List, Cnt)); + Cnt := Cnt + 1; + if Cnt = Len then + Cnt := 0; + end if; + end loop; + end case; + return Build_Simple_Aggregate (Res_List, Origin, Get_Type (Left)); + end Eval_Shift_Operator; + + -- Note: operands must be locally static. + function Eval_Concatenation + (Left, Right : Iir; Orig : Iir; Func : Iir_Predefined_Concat_Functions) + return Iir + is + Res_List : Iir_List; + L : Natural; + Res_Type : Iir; + Origin_Type : Iir; + Left_Aggr, Right_Aggr : Iir; + Left_List, Right_List : Iir_List; + Left_Len : Natural; + begin + Res_List := Create_Iir_List; + -- Do the concatenation. + -- Left: + case Func is + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + Append_Element (Res_List, Left); + Left_Len := 1; + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Array_Array_Concat => + Left_Aggr := Eval_String_Literal (Left); + Left_List := Get_Simple_Aggregate_List (Left_Aggr); + Left_Len := Get_Nbr_Elements (Left_List); + for I in 0 .. Left_Len - 1 loop + Append_Element (Res_List, Get_Nth_Element (Left_List, I)); + end loop; + Free_Eval_String_Literal (Left_Aggr, Left); + end case; + -- Right: + case Func is + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Append_Element (Res_List, Right); + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Array_Concat => + Right_Aggr := Eval_String_Literal (Right); + Right_List := Get_Simple_Aggregate_List (Right_Aggr); + L := Get_Nbr_Elements (Right_List); + for I in 0 .. L - 1 loop + Append_Element (Res_List, Get_Nth_Element (Right_List, I)); + end loop; + Free_Eval_String_Literal (Right_Aggr, Right); + end case; + L := Get_Nbr_Elements (Res_List); + + -- Compute subtype... + Origin_Type := Get_Type (Orig); + Res_Type := Null_Iir; + if Func = Iir_Predefined_Array_Array_Concat + and then Left_Len = 0 + then + if Flags.Vhdl_Std = Vhdl_87 then + -- LRM87 7.2.4 + -- [...], unless the left operand is a null array, in which case + -- the result of the concatenation is the right operand. + Res_Type := Get_Type (Right); + else + -- LRM93 7.2.4 + -- If both operands are null arrays, then the result of the + -- concatenation is the right operand. + if Get_Nbr_Elements (Right_List) = 0 then + Res_Type := Get_Type (Right); + end if; + end if; + end if; + if Res_Type = Null_Iir then + if Flags.Vhdl_Std = Vhdl_87 + and then (Func = Iir_Predefined_Array_Array_Concat + or Func = Iir_Predefined_Array_Element_Concat) + then + -- LRM87 7.2.4 + -- The left bound of the result is the left operand, [...] + -- + -- LRM87 7.2.4 + -- The direction of the result is the direction of the left + -- operand, [...] + declare + Left_Index : constant Iir := + Get_Index_Type (Get_Type (Left), 0); + Left_Range : constant Iir := + Get_Range_Constraint (Left_Index); + Ret_Type : constant Iir := + Get_Return_Type (Get_Implementation (Orig)); + A_Range : Iir; + Index_Type : Iir; + begin + A_Range := Create_Iir (Iir_Kind_Range_Expression); + Set_Type (A_Range, Get_Index_Type (Ret_Type, 0)); + Set_Expr_Staticness (A_Range, Locally); + Set_Left_Limit (A_Range, Get_Left_Limit (Left_Range)); + Set_Direction (A_Range, Get_Direction (Left_Range)); + Location_Copy (A_Range, Orig); + Set_Right_Limit_By_Length (A_Range, Iir_Int64 (L)); + Index_Type := Create_Range_Subtype_From_Type + (Left_Index, Get_Location (Orig)); + Set_Range_Constraint (Index_Type, A_Range); + Res_Type := Create_Unidim_Array_From_Index + (Origin_Type, Index_Type, Orig); + end; + else + -- LRM93 7.2.4 + -- Otherwise, the direction and bounds of the result are + -- determined as follows: let S be the index subtype of the base + -- type of the result. The direction of the result of the + -- concatenation is the direction of S, and the left bound of the + -- result is S'LEFT. + Res_Type := Create_Unidim_Array_By_Length + (Origin_Type, Iir_Int64 (L), Orig); + end if; + end if; + -- FIXME: this is not necessarily a string, it may be an aggregate if + -- element type is not a character type. + return Build_Simple_Aggregate (Res_List, Orig, Res_Type); + end Eval_Concatenation; + + function Eval_Array_Equality (Left, Right : Iir) return Boolean + is + Left_Val, Right_Val : Iir; + L_List : Iir_List; + R_List : Iir_List; + N : Natural; + Res : Boolean; + begin + Left_Val := Eval_String_Literal (Left); + Right_Val := Eval_String_Literal (Right); + + L_List := Get_Simple_Aggregate_List (Left_Val); + R_List := Get_Simple_Aggregate_List (Right_Val); + N := Get_Nbr_Elements (L_List); + if N /= Get_Nbr_Elements (R_List) then + -- Cannot be equal if not the same length. + Res := False; + else + Res := True; + for I in 0 .. N - 1 loop + -- FIXME: this is wrong: (eg: evaluated lit) + if Get_Nth_Element (L_List, I) /= Get_Nth_Element (R_List, I) then + Res := False; + exit; + end if; + end loop; + end if; + + Free_Eval_Static_Expr (Left_Val, Left); + Free_Eval_Static_Expr (Right_Val, Right); + + return Res; + end Eval_Array_Equality; + + -- ORIG is either a dyadic operator or a function call. + function Eval_Dyadic_Operator (Orig : Iir; Imp : Iir; Left, Right : Iir) + return Iir + is + pragma Unsuppress (Overflow_Check); + Func : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + begin + if Get_Kind (Left) = Iir_Kind_Overflow_Literal + or else Get_Kind (Right) = Iir_Kind_Overflow_Literal + then + return Build_Overflow (Orig); + end if; + + case Func is + when Iir_Predefined_Integer_Plus => + return Build_Integer (Get_Value (Left) + Get_Value (Right), Orig); + when Iir_Predefined_Integer_Minus => + return Build_Integer (Get_Value (Left) - Get_Value (Right), Orig); + when Iir_Predefined_Integer_Mul => + return Build_Integer (Get_Value (Left) * Get_Value (Right), Orig); + when Iir_Predefined_Integer_Div => + if Check_Integer_Division_By_Zero (Orig, Right) then + return Build_Integer + (Get_Value (Left) / Get_Value (Right), Orig); + else + return Build_Overflow (Orig); + end if; + when Iir_Predefined_Integer_Mod => + if Check_Integer_Division_By_Zero (Orig, Right) then + return Build_Integer + (Get_Value (Left) mod Get_Value (Right), Orig); + else + return Build_Overflow (Orig); + end if; + when Iir_Predefined_Integer_Rem => + if Check_Integer_Division_By_Zero (Orig, Right) then + return Build_Integer + (Get_Value (Left) rem Get_Value (Right), Orig); + else + return Build_Overflow (Orig); + end if; + when Iir_Predefined_Integer_Exp => + return Build_Integer + (Get_Value (Left) ** Integer (Get_Value (Right)), Orig); + + when Iir_Predefined_Integer_Equality => + return Build_Boolean (Get_Value (Left) = Get_Value (Right)); + when Iir_Predefined_Integer_Inequality => + return Build_Boolean (Get_Value (Left) /= Get_Value (Right)); + when Iir_Predefined_Integer_Greater_Equal => + return Build_Boolean (Get_Value (Left) >= Get_Value (Right)); + when Iir_Predefined_Integer_Greater => + return Build_Boolean (Get_Value (Left) > Get_Value (Right)); + when Iir_Predefined_Integer_Less_Equal => + return Build_Boolean (Get_Value (Left) <= Get_Value (Right)); + when Iir_Predefined_Integer_Less => + return Build_Boolean (Get_Value (Left) < Get_Value (Right)); + + when Iir_Predefined_Integer_Minimum => + if Get_Value (Left) < Get_Value (Right) then + return Left; + else + return Right; + end if; + when Iir_Predefined_Integer_Maximum => + if Get_Value (Left) > Get_Value (Right) then + return Left; + else + return Right; + end if; + + when Iir_Predefined_Floating_Equality => + return Build_Boolean (Get_Fp_Value (Left) = Get_Fp_Value (Right)); + when Iir_Predefined_Floating_Inequality => + return Build_Boolean (Get_Fp_Value (Left) /= Get_Fp_Value (Right)); + when Iir_Predefined_Floating_Greater => + return Build_Boolean (Get_Fp_Value (Left) > Get_Fp_Value (Right)); + when Iir_Predefined_Floating_Greater_Equal => + return Build_Boolean (Get_Fp_Value (Left) >= Get_Fp_Value (Right)); + when Iir_Predefined_Floating_Less => + return Build_Boolean (Get_Fp_Value (Left) < Get_Fp_Value (Right)); + when Iir_Predefined_Floating_Less_Equal => + return Build_Boolean (Get_Fp_Value (Left) <= Get_Fp_Value (Right)); + + when Iir_Predefined_Floating_Minus => + return Build_Floating + (Get_Fp_Value (Left) - Get_Fp_Value (Right), Orig); + when Iir_Predefined_Floating_Plus => + return Build_Floating + (Get_Fp_Value (Left) + Get_Fp_Value (Right), Orig); + when Iir_Predefined_Floating_Mul => + return Build_Floating + (Get_Fp_Value (Left) * Get_Fp_Value (Right), Orig); + when Iir_Predefined_Floating_Div => + if Get_Fp_Value (Right) = 0.0 then + Warning_Msg_Sem ("right operand of division is 0", Orig); + return Build_Overflow (Orig); + else + return Build_Floating + (Get_Fp_Value (Left) / Get_Fp_Value (Right), Orig); + end if; + when Iir_Predefined_Floating_Exp => + declare + Exp : Iir_Int64; + Res : Iir_Fp64; + Val : Iir_Fp64; + begin + Res := 1.0; + Val := Get_Fp_Value (Left); + Exp := abs Get_Value (Right); + while Exp /= 0 loop + if Exp mod 2 = 1 then + Res := Res * Val; + end if; + Exp := Exp / 2; + Val := Val * Val; + end loop; + if Get_Value (Right) < 0 then + Res := 1.0 / Res; + end if; + return Build_Floating (Res, Orig); + end; + + when Iir_Predefined_Floating_Minimum => + if Get_Fp_Value (Left) < Get_Fp_Value (Right) then + return Left; + else + return Right; + end if; + when Iir_Predefined_Floating_Maximum => + if Get_Fp_Value (Left) > Get_Fp_Value (Right) then + return Left; + else + return Right; + end if; + + when Iir_Predefined_Physical_Equality => + return Build_Boolean + (Get_Physical_Value (Left) = Get_Physical_Value (Right)); + when Iir_Predefined_Physical_Inequality => + return Build_Boolean + (Get_Physical_Value (Left) /= Get_Physical_Value (Right)); + when Iir_Predefined_Physical_Greater_Equal => + return Build_Boolean + (Get_Physical_Value (Left) >= Get_Physical_Value (Right)); + when Iir_Predefined_Physical_Greater => + return Build_Boolean + (Get_Physical_Value (Left) > Get_Physical_Value (Right)); + when Iir_Predefined_Physical_Less_Equal => + return Build_Boolean + (Get_Physical_Value (Left) <= Get_Physical_Value (Right)); + when Iir_Predefined_Physical_Less => + return Build_Boolean + (Get_Physical_Value (Left) < Get_Physical_Value (Right)); + + when Iir_Predefined_Physical_Physical_Div => + return Build_Integer + (Get_Physical_Value (Left) / Get_Physical_Value (Right), Orig); + when Iir_Predefined_Physical_Integer_Div => + return Build_Physical + (Get_Physical_Value (Left) / Get_Value (Right), Orig); + when Iir_Predefined_Physical_Minus => + return Build_Physical + (Get_Physical_Value (Left) - Get_Physical_Value (Right), Orig); + when Iir_Predefined_Physical_Plus => + return Build_Physical + (Get_Physical_Value (Left) + Get_Physical_Value (Right), Orig); + when Iir_Predefined_Integer_Physical_Mul => + return Build_Physical + (Get_Value (Left) * Get_Physical_Value (Right), Orig); + when Iir_Predefined_Physical_Integer_Mul => + return Build_Physical + (Get_Physical_Value (Left) * Get_Value (Right), Orig); + when Iir_Predefined_Real_Physical_Mul => + -- FIXME: overflow?? + return Build_Physical + (Iir_Int64 (Get_Fp_Value (Left) + * Iir_Fp64 (Get_Physical_Value (Right))), Orig); + when Iir_Predefined_Physical_Real_Mul => + -- FIXME: overflow?? + return Build_Physical + (Iir_Int64 (Iir_Fp64 (Get_Physical_Value (Left)) + * Get_Fp_Value (Right)), Orig); + when Iir_Predefined_Physical_Real_Div => + -- FIXME: overflow?? + return Build_Physical + (Iir_Int64 (Iir_Fp64 (Get_Physical_Value (Left)) + / Get_Fp_Value (Right)), Orig); + + when Iir_Predefined_Physical_Minimum => + return Build_Physical (Iir_Int64'Min (Get_Physical_Value (Left), + Get_Physical_Value (Right)), + Orig); + when Iir_Predefined_Physical_Maximum => + return Build_Physical (Iir_Int64'Max (Get_Physical_Value (Left), + Get_Physical_Value (Right)), + Orig); + + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Element_Element_Concat => + return Eval_Concatenation (Left, Right, Orig, Func); + + when Iir_Predefined_Enum_Equality + | Iir_Predefined_Bit_Match_Equality => + return Build_Enumeration + (Get_Enum_Pos (Left) = Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Inequality + | Iir_Predefined_Bit_Match_Inequality => + return Build_Enumeration + (Get_Enum_Pos (Left) /= Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Greater_Equal + | Iir_Predefined_Bit_Match_Greater_Equal => + return Build_Enumeration + (Get_Enum_Pos (Left) >= Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Greater + | Iir_Predefined_Bit_Match_Greater => + return Build_Enumeration + (Get_Enum_Pos (Left) > Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Less_Equal + | Iir_Predefined_Bit_Match_Less_Equal => + return Build_Enumeration + (Get_Enum_Pos (Left) <= Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Less + | Iir_Predefined_Bit_Match_Less => + return Build_Enumeration + (Get_Enum_Pos (Left) < Get_Enum_Pos (Right), Orig); + + when Iir_Predefined_Enum_Minimum => + if Get_Enum_Pos (Left) < Get_Enum_Pos (Right) then + return Left; + else + return Right; + end if; + when Iir_Predefined_Enum_Maximum => + if Get_Enum_Pos (Left) > Get_Enum_Pos (Right) then + return Left; + else + return Right; + end if; + + when Iir_Predefined_Boolean_And + | Iir_Predefined_Bit_And => + return Build_Enumeration + (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1, Orig); + when Iir_Predefined_Boolean_Nand + | Iir_Predefined_Bit_Nand => + return Build_Enumeration + (not (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1), + Orig); + when Iir_Predefined_Boolean_Or + | Iir_Predefined_Bit_Or => + return Build_Enumeration + (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1, Orig); + when Iir_Predefined_Boolean_Nor + | Iir_Predefined_Bit_Nor => + return Build_Enumeration + (not (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1), + Orig); + when Iir_Predefined_Boolean_Xor + | Iir_Predefined_Bit_Xor => + return Build_Enumeration + (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1, Orig); + when Iir_Predefined_Boolean_Xnor + | Iir_Predefined_Bit_Xnor => + return Build_Enumeration + (not (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1), + Orig); + + when Iir_Predefined_Dyadic_TF_Array_Functions => + -- FIXME: only for bit ? + return Eval_Dyadic_Bit_Array_Operator (Orig, Left, Right, Func); + + when Iir_Predefined_Universal_R_I_Mul => + return Build_Floating + (Get_Fp_Value (Left) * Iir_Fp64 (Get_Value (Right)), Orig); + when Iir_Predefined_Universal_I_R_Mul => + return Build_Floating + (Iir_Fp64 (Get_Value (Left)) * Get_Fp_Value (Right), Orig); + when Iir_Predefined_Universal_R_I_Div => + return Build_Floating + (Get_Fp_Value (Left) / Iir_Fp64 (Get_Value (Right)), Orig); + + when Iir_Predefined_Array_Equality => + return Build_Boolean (Eval_Array_Equality (Left, Right)); + + when Iir_Predefined_Array_Inequality => + return Build_Boolean (not Eval_Array_Equality (Left, Right)); + + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + declare + Left_Aggr : Iir; + Res : Iir; + begin + Left_Aggr := Eval_String_Literal (Left); + Res := Eval_Shift_Operator (Left_Aggr, Right, Orig, Func); + Free_Eval_String_Literal (Left_Aggr, Left); + return Res; + end; + + when Iir_Predefined_Array_Less + | Iir_Predefined_Array_Less_Equal + | Iir_Predefined_Array_Greater + | Iir_Predefined_Array_Greater_Equal => + -- FIXME: todo. + Error_Internal (Orig, "eval_dyadic_operator: " & + Iir_Predefined_Functions'Image (Func)); + + when Iir_Predefined_Boolean_Not + | Iir_Predefined_Boolean_Rising_Edge + | Iir_Predefined_Boolean_Falling_Edge + | Iir_Predefined_Bit_Not + | Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Integer_Absolute + | Iir_Predefined_Integer_Identity + | Iir_Predefined_Integer_Negation + | Iir_Predefined_Floating_Absolute + | Iir_Predefined_Floating_Negation + | Iir_Predefined_Floating_Identity + | Iir_Predefined_Physical_Absolute + | Iir_Predefined_Physical_Identity + | Iir_Predefined_Physical_Negation + | Iir_Predefined_Error + | Iir_Predefined_Record_Equality + | Iir_Predefined_Record_Inequality + | Iir_Predefined_Access_Equality + | Iir_Predefined_Access_Inequality + | Iir_Predefined_TF_Array_Not + | Iir_Predefined_Now_Function + | Iir_Predefined_Deallocate + | 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 + | Iir_Predefined_Endfile + | Iir_Predefined_Attribute_Image + | Iir_Predefined_Attribute_Value + | Iir_Predefined_Attribute_Pos + | Iir_Predefined_Attribute_Val + | Iir_Predefined_Attribute_Succ + | Iir_Predefined_Attribute_Pred + | Iir_Predefined_Attribute_Rightof + | Iir_Predefined_Attribute_Leftof + | Iir_Predefined_Attribute_Left + | Iir_Predefined_Attribute_Right + | Iir_Predefined_Attribute_Event + | Iir_Predefined_Attribute_Active + | Iir_Predefined_Attribute_Last_Value + | Iir_Predefined_Attribute_Last_Event + | Iir_Predefined_Attribute_Last_Active + | Iir_Predefined_Attribute_Driving + | Iir_Predefined_Attribute_Driving_Value + | Iir_Predefined_Array_Char_To_String + | Iir_Predefined_Bit_Vector_To_Ostring + | Iir_Predefined_Bit_Vector_To_Hstring => + -- Not binary or never locally static. + Error_Internal (Orig, "eval_dyadic_operator: " & + Iir_Predefined_Functions'Image (Func)); + + when Iir_Predefined_Bit_Condition => + raise Internal_Error; + + when Iir_Predefined_Array_Minimum + | Iir_Predefined_Array_Maximum + | Iir_Predefined_Vector_Minimum + | Iir_Predefined_Vector_Maximum => + raise Internal_Error; + + when Iir_Predefined_Std_Ulogic_Match_Equality + | Iir_Predefined_Std_Ulogic_Match_Inequality + | Iir_Predefined_Std_Ulogic_Match_Less + | Iir_Predefined_Std_Ulogic_Match_Less_Equal + | Iir_Predefined_Std_Ulogic_Match_Greater + | Iir_Predefined_Std_Ulogic_Match_Greater_Equal => + -- TODO + raise Internal_Error; + + when Iir_Predefined_Enum_To_String + | Iir_Predefined_Integer_To_String + | Iir_Predefined_Floating_To_String + | Iir_Predefined_Real_To_String_Digits + | Iir_Predefined_Real_To_String_Format + | Iir_Predefined_Physical_To_String + | Iir_Predefined_Time_To_String_Unit => + -- TODO + raise Internal_Error; + + when Iir_Predefined_TF_Array_Element_And + | Iir_Predefined_TF_Element_Array_And + | Iir_Predefined_TF_Array_Element_Or + | Iir_Predefined_TF_Element_Array_Or + | Iir_Predefined_TF_Array_Element_Nand + | Iir_Predefined_TF_Element_Array_Nand + | Iir_Predefined_TF_Array_Element_Nor + | Iir_Predefined_TF_Element_Array_Nor + | Iir_Predefined_TF_Array_Element_Xor + | Iir_Predefined_TF_Element_Array_Xor + | Iir_Predefined_TF_Array_Element_Xnor + | Iir_Predefined_TF_Element_Array_Xnor => + -- TODO + raise Internal_Error; + + when Iir_Predefined_TF_Reduction_And + | Iir_Predefined_TF_Reduction_Or + | Iir_Predefined_TF_Reduction_Nand + | Iir_Predefined_TF_Reduction_Nor + | Iir_Predefined_TF_Reduction_Xor + | Iir_Predefined_TF_Reduction_Xnor + | Iir_Predefined_TF_Reduction_Not => + -- TODO + raise Internal_Error; + + when Iir_Predefined_Bit_Array_Match_Equality + | Iir_Predefined_Bit_Array_Match_Inequality + | Iir_Predefined_Std_Ulogic_Array_Match_Equality + | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + -- TODO + raise Internal_Error; + end case; + exception + when Constraint_Error => + Warning_Msg_Sem ("arithmetic overflow in static expression", Orig); + return Build_Overflow (Orig); + end Eval_Dyadic_Operator; + + -- Evaluate any array attribute, return the type for the prefix. + function Eval_Array_Attribute (Attr : Iir) return Iir + is + Prefix : Iir; + Prefix_Type : Iir; + begin + Prefix := Get_Prefix (Attr); + case Get_Kind (Prefix) is + when Iir_Kinds_Object_Declaration -- FIXME: remove + | Iir_Kind_Selected_Element + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Implicit_Dereference => + Prefix_Type := Get_Type (Prefix); + when Iir_Kind_Attribute_Value => + -- The type of the attribute declaration may be unconstrained. + Prefix_Type := Get_Type + (Get_Expression (Get_Attribute_Specification (Prefix))); + when Iir_Kinds_Subtype_Definition => + Prefix_Type := Prefix; + when Iir_Kinds_Denoting_Name => + Prefix_Type := Get_Type (Prefix); + when others => + Error_Kind ("eval_array_attribute", Prefix); + end case; + if Get_Kind (Prefix_Type) /= Iir_Kind_Array_Subtype_Definition then + Error_Kind ("eval_array_attribute(2)", Prefix_Type); + end if; + return Get_Nth_Element (Get_Index_Subtype_List (Prefix_Type), + Natural (Get_Value (Get_Parameter (Attr)) - 1)); + end Eval_Array_Attribute; + + function Eval_Integer_Image (Val : Iir_Int64; Orig : Iir) return Iir + is + use Str_Table; + Img : String (1 .. 24); -- 23 is enough, 24 is rounded. + L : Natural; + V : Iir_Int64; + Id : String_Id; + begin + V := Val; + L := Img'Last; + loop + Img (L) := Character'Val (Character'Pos ('0') + abs (V rem 10)); + V := V / 10; + L := L - 1; + exit when V = 0; + end loop; + if Val < 0 then + Img (L) := '-'; + L := L - 1; + end if; + Id := Start; + for I in L + 1 .. Img'Last loop + Append (Img (I)); + end loop; + Finish; + return Build_String (Id, Int32 (Img'Last - L), Orig); + end Eval_Integer_Image; + + function Eval_Floating_Image (Val : Iir_Fp64; Orig : Iir) return Iir + is + use Str_Table; + Id : String_Id; + + -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1) + -- + exp_digits (4) -> 24. + Str : String (1 .. 25); + P : Natural; + V : Iir_Fp64; + Vd : Iir_Fp64; + Exp : Integer; + D : Integer; + B : Boolean; + + Res : Iir; + begin + -- Handle sign. + if Val < 0.0 then + Str (1) := '-'; + P := 1; + V := -Val; + else + P := 0; + V := Val; + end if; + + -- Compute the mantissa. + -- FIXME: should do a dichotomy. + if V = 0.0 then + Exp := 0; + elsif V < 1.0 then + Exp := -1; + while V * (10.0 ** (-Exp)) < 1.0 loop + Exp := Exp - 1; + end loop; + else + Exp := 0; + while V / (10.0 ** Exp) >= 10.0 loop + Exp := Exp + 1; + end loop; + end if; + + -- Normalize VAL: in [0; 10[ + if Exp >= 0 then + V := V / (10.0 ** Exp); + else + V := V * 10.0 ** (-Exp); + end if; + + for I in 0 .. 15 loop + Vd := Iir_Fp64'Truncation (V); + P := P + 1; + Str (P) := Character'Val (48 + Integer (Vd)); + V := (V - Vd) * 10.0; + + if I = 0 then + P := P + 1; + Str (P) := '.'; + end if; + exit when I > 0 and V < 10.0 ** (I + 1 - 15); + end loop; + + if Exp /= 0 then + -- LRM93 14.3 + -- if the exponent is present, the `e' is written as a lower case + -- character. + P := P + 1; + Str (P) := 'e'; + + if Exp < 0 then + P := P + 1; + Str (P) := '-'; + Exp := -Exp; + end if; + B := False; + for I in 0 .. 4 loop + D := (Exp / 10000) mod 10; + if D /= 0 or B or I = 4 then + P := P + 1; + Str (P) := Character'Val (48 + D); + B := True; + end if; + Exp := (Exp - D * 10000) * 10; + end loop; + end if; + + Id := Start; + for I in 1 .. P loop + Append (Str (I)); + end loop; + Finish; + Res := Build_String (Id, Int32 (P), Orig); + -- FIXME: this is not correct since the type is *not* constrained. + Set_Type (Res, Create_Unidim_Array_By_Length + (Get_Type (Orig), Iir_Int64 (P), Orig)); + return Res; + end Eval_Floating_Image; + + function Eval_Enumeration_Image (Enum, Expr : Iir) return Iir + is + Name : constant String := Image_Identifier (Enum); + Image_Id : constant String_Id := Str_Table.Start; + begin + for i in Name'range loop + Str_Table.Append(Name(i)); + end loop; + Str_Table.Finish; + return Build_String (Image_Id, Nat32(Name'Length), Expr); + end Eval_Enumeration_Image; + + function Build_Enumeration_Value (Val : String; Enum, Expr : Iir) return Iir + is + Value : String (Val'range); + List : constant Iir_List := Get_Enumeration_Literal_List (Enum); + begin + for I in Val'range loop + Value (I) := Ada.Characters.Handling.To_Lower (Val (I)); + end loop; + for I in 0 .. Get_Nbr_Elements (List) - 1 loop + if Value = Image_Identifier (Get_Nth_Element (List, I)) then + return Build_Enumeration (Iir_Index32 (I), Expr); + end if; + end loop; + Warning_Msg_Sem ("value """ & Value & """ not in enumeration", Expr); + return Build_Overflow (Expr); + end Build_Enumeration_Value; + + function Eval_Physical_Image (Phys, Expr: Iir) return Iir + is + -- Reduces to the base unit (e.g. femtoseconds). + Value : constant String := Iir_Int64'Image (Get_Physical_Value (Phys)); + Unit : constant Iir := + Get_Primary_Unit (Get_Base_Type (Get_Type (Phys))); + UnitName : constant String := Image_Identifier (Unit); + Image_Id : constant String_Id := Str_Table.Start; + Length : Nat32 := Value'Length + UnitName'Length + 1; + begin + for I in Value'range loop + -- Suppress the Ada +ve integer'image leading space + if I > Value'first or else Value (I) /= ' ' then + Str_Table.Append (Value (I)); + else + Length := Length - 1; + end if; + end loop; + Str_Table.Append (' '); + for I in UnitName'range loop + Str_Table.Append (UnitName (I)); + end loop; + Str_Table.Finish; + + return Build_String (Image_Id, Length, Expr); + end Eval_Physical_Image; + + function Build_Physical_Value (Val: String; Phys_Type, Expr: Iir) return Iir + is + function White (C : in Character) return Boolean is + NBSP : constant Character := Character'Val (160); + HT : constant Character := Character'Val (9); + begin + return C = ' ' or C = NBSP or C = HT; + end White; + + UnitName : String (Val'range); + Mult : Iir_Int64; + Sep : Natural; + Found_Unit : Boolean := false; + Found_Real : Boolean := false; + Unit : Iir := Get_Primary_Unit (Phys_Type); + begin + -- Separate string into numeric value and make lowercase unit. + for I in reverse Val'range loop + UnitName (I) := Ada.Characters.Handling.To_Lower (Val (I)); + if White (Val (I)) and Found_Unit then + Sep := I; + exit; + else + Found_Unit := true; + end if; + end loop; + + -- Unit name is UnitName(Sep+1..Unit'Last) + for I in Val'First .. Sep loop + if Val (I) = '.' then + Found_Real := true; + end if; + end loop; + + -- Chain down the units looking for matching one + Unit := Get_Primary_Unit (Phys_Type); + while Unit /= Null_Iir loop + exit when (UnitName (Sep + 1 .. UnitName'Last) + = Image_Identifier (Unit)); + Unit := Get_Chain (Unit); + end loop; + if Unit = Null_Iir then + Warning_Msg_Sem ("Unit """ & UnitName (Sep + 1 .. UnitName'Last) + & """ not in physical type", Expr); + return Build_Overflow (Expr); + end if; + + Mult := Get_Value (Get_Physical_Unit_Value (Unit)); + if Found_Real then + return Build_Physical + (Iir_Int64 (Iir_Fp64'Value (Val (Val'First .. Sep)) + * Iir_Fp64 (Mult)), + Expr); + else + return Build_Physical + (Iir_Int64'Value (Val (Val'First .. Sep)) * Mult, Expr); + end if; + end Build_Physical_Value; + + function Eval_Incdec (Expr : Iir; N : Iir_Int64; Origin : Iir) return Iir + is + P : Iir_Int64; + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal => + return Build_Integer (Get_Value (Expr) + N, Origin); + when Iir_Kind_Enumeration_Literal => + P := Iir_Int64 (Get_Enum_Pos (Expr)) + N; + if P < 0 then + Warning_Msg_Sem ("static constant violates bounds", Expr); + return Build_Overflow (Origin); + else + return Build_Enumeration (Iir_Index32 (P), Origin); + end if; + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Unit_Declaration => + return Build_Physical (Get_Physical_Value (Expr) + N, Origin); + when others => + Error_Kind ("eval_incdec", Expr); + end case; + end Eval_Incdec; + + function Convert_Range (Rng : Iir; Res_Type : Iir; Loc : Iir) return Iir + is + Res_Btype : Iir; + + function Create_Bound (Val : Iir) return Iir + is + R : Iir; + begin + R := Create_Iir (Iir_Kind_Integer_Literal); + Location_Copy (R, Loc); + Set_Value (R, Get_Value (Val)); + Set_Type (R, Res_Btype); + Set_Expr_Staticness (R, Locally); + return R; + end Create_Bound; + + Res : Iir; + begin + Res_Btype := Get_Base_Type (Res_Type); + Res := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Res, Loc); + Set_Type (Res, Res_Btype); + Set_Left_Limit (Res, Create_Bound (Get_Left_Limit (Rng))); + Set_Right_Limit (Res, Create_Bound (Get_Right_Limit (Rng))); + Set_Direction (Res, Get_Direction (Rng)); + Set_Expr_Staticness (Res, Locally); + return Res; + end Convert_Range; + + function Eval_Array_Type_Conversion (Conv : Iir; Val : Iir) return Iir + is + Conv_Type : constant Iir := Get_Type (Conv); + Val_Type : constant Iir := Get_Type (Val); + Conv_Index_Type : constant Iir := Get_Index_Type (Conv_Type, 0); + Val_Index_Type : constant Iir := Get_Index_Type (Val_Type, 0); + Index_Type : Iir; + Res_Type : Iir; + Res : Iir; + Rng : Iir; + begin + -- The expression is either a simple aggregate or a (bit) string. + Res := Build_Constant (Val, Conv); + case Get_Kind (Conv_Type) is + when Iir_Kind_Array_Subtype_Definition => + Set_Type (Res, Conv_Type); + if Eval_Discrete_Type_Length (Conv_Index_Type) + /= Eval_Discrete_Type_Length (Val_Index_Type) + then + Warning_Msg_Sem + ("non matching length in type conversion", Conv); + return Build_Overflow (Conv); + end if; + return Res; + 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; + else + -- Convert the index range. + -- It is an integer type. + Rng := Convert_Range (Get_Range_Constraint (Val_Index_Type), + Conv_Index_Type, Conv); + Index_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition); + Location_Copy (Index_Type, Conv); + Set_Range_Constraint (Index_Type, Rng); + Set_Base_Type (Index_Type, Get_Base_Type (Conv_Index_Type)); + Set_Type_Staticness (Index_Type, Locally); + end if; + Res_Type := Create_Unidim_Array_From_Index + (Get_Base_Type (Conv_Type), Index_Type, Conv); + Set_Type (Res, Res_Type); + Set_Type_Conversion_Subtype (Conv, Res_Type); + return Res; + when others => + Error_Kind ("eval_array_type_conversion", Conv_Type); + end case; + end Eval_Array_Type_Conversion; + + function Eval_Type_Conversion (Expr : Iir) return Iir + is + Val : Iir; + Val_Type : Iir; + Conv_Type : Iir; + begin + Val := Eval_Static_Expr (Get_Expression (Expr)); + Val_Type := Get_Base_Type (Get_Type (Val)); + Conv_Type := Get_Base_Type (Get_Type (Expr)); + if Conv_Type = Val_Type then + return Build_Constant (Val, Expr); + end if; + case Get_Kind (Conv_Type) is + when Iir_Kind_Integer_Type_Definition => + case Get_Kind (Val_Type) is + when Iir_Kind_Integer_Type_Definition => + return Build_Integer (Get_Value (Val), Expr); + when Iir_Kind_Floating_Type_Definition => + return Build_Integer (Iir_Int64 (Get_Fp_Value (Val)), Expr); + when others => + Error_Kind ("eval_type_conversion(1)", Val_Type); + end case; + when Iir_Kind_Floating_Type_Definition => + case Get_Kind (Val_Type) is + when Iir_Kind_Integer_Type_Definition => + return Build_Floating (Iir_Fp64 (Get_Value (Val)), Expr); + when Iir_Kind_Floating_Type_Definition => + return Build_Floating (Get_Fp_Value (Val), Expr); + when others => + Error_Kind ("eval_type_conversion(2)", Val_Type); + end case; + when Iir_Kind_Array_Type_Definition => + return Eval_Array_Type_Conversion (Expr, Val); + when others => + Error_Kind ("eval_type_conversion(3)", Conv_Type); + end case; + end Eval_Type_Conversion; + + function Eval_Physical_Literal (Expr : Iir) return Iir + is + Val : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kind_Physical_Fp_Literal => + Val := Expr; + when Iir_Kind_Physical_Int_Literal => + if Get_Named_Entity (Get_Unit_Name (Expr)) + = Get_Primary_Unit (Get_Base_Type (Get_Type (Expr))) + then + return Expr; + else + Val := Expr; + end if; + when Iir_Kind_Unit_Declaration => + Val := Expr; + when Iir_Kinds_Denoting_Name => + Val := Get_Named_Entity (Expr); + pragma Assert (Get_Kind (Val) = Iir_Kind_Unit_Declaration); + when others => + Error_Kind ("eval_physical_literal", Expr); + end case; + return Build_Physical (Get_Physical_Value (Val), Expr); + end Eval_Physical_Literal; + + function Eval_Static_Expr (Expr: Iir) return Iir + is + Res : Iir; + Val : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kinds_Denoting_Name => + return Eval_Static_Expr (Get_Named_Entity (Expr)); + + when Iir_Kind_Integer_Literal + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Floating_Point_Literal + | Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal + | Iir_Kind_Overflow_Literal + | Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal => + return Expr; + when Iir_Kind_Constant_Declaration => + Val := Eval_Static_Expr (Get_Default_Value (Expr)); + -- 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: + -- add an implicit subtype conversion node ? + -- FIXME: this currently creates a node at each evalation. + if Get_Kind (Get_Type (Val)) = Iir_Kind_Array_Type_Definition then + Res := Build_Constant (Val, Expr); + Set_Type (Res, Get_Type (Val)); + return Res; + else + return Val; + end if; + when Iir_Kind_Object_Alias_Declaration => + return Eval_Static_Expr (Get_Name (Expr)); + when Iir_Kind_Unit_Declaration => + return Get_Physical_Unit_Value (Expr); + when Iir_Kind_Simple_Aggregate => + return Expr; + + when Iir_Kind_Parenthesis_Expression => + return Eval_Static_Expr (Get_Expression (Expr)); + when Iir_Kind_Qualified_Expression => + return Eval_Static_Expr (Get_Expression (Expr)); + when Iir_Kind_Type_Conversion => + return Eval_Type_Conversion (Expr); + + when Iir_Kinds_Monadic_Operator => + declare + Operand : Iir; + begin + Operand := Eval_Static_Expr (Get_Operand (Expr)); + return Eval_Monadic_Operator (Expr, Operand); + end; + when Iir_Kinds_Dyadic_Operator => + declare + Left : constant Iir := Get_Left (Expr); + Right : constant Iir := Get_Right (Expr); + Left_Val, Right_Val : Iir; + Res : Iir; + begin + Left_Val := Eval_Static_Expr (Left); + Right_Val := Eval_Static_Expr (Right); + + Res := Eval_Dyadic_Operator + (Expr, Get_Implementation (Expr), Left_Val, Right_Val); + + Free_Eval_Static_Expr (Left_Val, Left); + Free_Eval_Static_Expr (Right_Val, Right); + + return Res; + end; + + when Iir_Kind_Attribute_Name => + -- An attribute name designates an attribute value. + declare + Attr_Val : constant Iir := Get_Named_Entity (Expr); + Attr_Expr : constant Iir := + Get_Expression (Get_Attribute_Specification (Attr_Val)); + Val : Iir; + begin + Val := Eval_Static_Expr (Attr_Expr); + -- FIXME: see constant_declaration. + -- Currently, this avoids weird nodes, such as a string literal + -- whose type is an unconstrained array type. + Res := Build_Constant (Val, Expr); + Set_Type (Res, Get_Type (Val)); + return Res; + end; + + when Iir_Kind_Pos_Attribute => + declare + Param : constant Iir := Get_Parameter (Expr); + Val : Iir; + Res : Iir; + begin + Val := Eval_Static_Expr (Param); + -- FIXME: check bounds, handle overflow. + Res := Build_Integer (Eval_Pos (Val), Expr); + Free_Eval_Static_Expr (Val, Param); + return Res; + end; + when Iir_Kind_Val_Attribute => + declare + Expr_Type : constant Iir := Get_Type (Expr); + Val_Expr : Iir; + Val : Iir_Int64; + begin + Val_Expr := Eval_Static_Expr (Get_Parameter (Expr)); + Val := Eval_Pos (Val_Expr); + -- Note: the type of 'val is a base type. + -- FIXME: handle VHDL93 restrictions. + if Get_Kind (Expr_Type) = Iir_Kind_Enumeration_Type_Definition + and then + not Eval_Int_In_Range (Val, Get_Range_Constraint (Expr_Type)) + then + Warning_Msg_Sem + ("static argument out of the type range", Expr); + return Build_Overflow (Expr); + end if; + if Get_Kind (Get_Base_Type (Get_Type (Expr))) + = Iir_Kind_Physical_Type_Definition + then + return Build_Physical (Val, Expr); + else + return Build_Discrete (Val, Expr); + end if; + end; + when Iir_Kind_Image_Attribute => + declare + Param : Iir; + Param_Type : Iir; + begin + Param := Get_Parameter (Expr); + Param := Eval_Static_Expr (Param); + Set_Parameter (Expr, Param); + Param_Type := Get_Base_Type (Get_Type (Param)); + case Get_Kind (Param_Type) is + when Iir_Kind_Integer_Type_Definition => + return Eval_Integer_Image (Get_Value (Param), Expr); + when Iir_Kind_Floating_Type_Definition => + return Eval_Floating_Image (Get_Fp_Value (Param), Expr); + when Iir_Kind_Enumeration_Type_Definition => + return Eval_Enumeration_Image (Param, Expr); + when Iir_Kind_Physical_Type_Definition => + return Eval_Physical_Image (Param, Expr); + when others => + Error_Kind ("eval_static_expr('image)", Param); + end case; + end; + when Iir_Kind_Value_Attribute => + declare + Param : Iir; + Param_Type : Iir; + begin + Param := Get_Parameter (Expr); + Param := Eval_Static_Expr (Param); + Set_Parameter (Expr, Param); + if Get_Kind (Param) /= Iir_Kind_String_Literal then + -- FIXME: Isn't it an implementation restriction. + Warning_Msg_Sem ("'value argument not a string", Expr); + return Build_Overflow (Expr); + else + -- what type are we converting the string to? + Param_Type := Get_Base_Type (Get_Type (Expr)); + declare + Value : constant String := Image_String_Lit (Param); + begin + case Get_Kind (Param_Type) is + when Iir_Kind_Integer_Type_Definition => + return Build_Discrete (Iir_Int64'Value (Value), Expr); + when Iir_Kind_Enumeration_Type_Definition => + return Build_Enumeration_Value (Value, Param_Type, + Expr); + when Iir_Kind_Floating_Type_Definition => + return Build_Floating (Iir_Fp64'value (Value), Expr); + when Iir_Kind_Physical_Type_Definition => + return Build_Physical_Value (Value, Param_Type, Expr); + when others => + Error_Kind ("eval_static_expr('value)", Param); + end case; + end; + end if; + end; + + when Iir_Kind_Left_Type_Attribute => + return Eval_Static_Expr + (Get_Left_Limit (Eval_Static_Range (Get_Prefix (Expr)))); + when Iir_Kind_Right_Type_Attribute => + return Eval_Static_Expr + (Get_Right_Limit (Eval_Static_Range (Get_Prefix (Expr)))); + when Iir_Kind_High_Type_Attribute => + return Eval_Static_Expr + (Get_High_Limit (Eval_Static_Range (Get_Prefix (Expr)))); + when Iir_Kind_Low_Type_Attribute => + return Eval_Static_Expr + (Get_Low_Limit (Eval_Static_Range (Get_Prefix (Expr)))); + when Iir_Kind_Ascending_Type_Attribute => + return Build_Boolean + (Get_Direction (Eval_Static_Range (Get_Prefix (Expr))) = Iir_To); + + when Iir_Kind_Length_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Build_Discrete (Eval_Discrete_Type_Length (Index), Expr); + end; + when Iir_Kind_Left_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Eval_Static_Expr + (Get_Left_Limit (Get_Range_Constraint (Index))); + end; + when Iir_Kind_Right_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Eval_Static_Expr + (Get_Right_Limit (Get_Range_Constraint (Index))); + end; + when Iir_Kind_Low_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Eval_Static_Expr + (Get_Low_Limit (Get_Range_Constraint (Index))); + end; + when Iir_Kind_High_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Eval_Static_Expr + (Get_High_Limit (Get_Range_Constraint (Index))); + end; + when Iir_Kind_Ascending_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Build_Boolean + (Get_Direction (Get_Range_Constraint (Index)) = Iir_To); + end; + + when Iir_Kind_Pred_Attribute => + Res := Eval_Incdec + (Eval_Static_Expr (Get_Parameter (Expr)), -1, Expr); + Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr))); + return Res; + when Iir_Kind_Succ_Attribute => + Res := Eval_Incdec + (Eval_Static_Expr (Get_Parameter (Expr)), +1, Expr); + Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr))); + return Res; + when Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute => + declare + Rng : Iir; + N : Iir_Int64; + Prefix_Type : Iir; + Res : Iir; + begin + Prefix_Type := Get_Type (Get_Prefix (Expr)); + Rng := Eval_Static_Range (Prefix_Type); + case Get_Direction (Rng) is + when Iir_To => + N := 1; + when Iir_Downto => + N := -1; + end case; + case Get_Kind (Expr) is + when Iir_Kind_Leftof_Attribute => + N := -N; + when Iir_Kind_Rightof_Attribute => + null; + when others => + raise Internal_Error; + end case; + Res := Eval_Incdec + (Eval_Static_Expr (Get_Parameter (Expr)), N, Expr); + Eval_Check_Bound (Res, Prefix_Type); + return Res; + end; + + when Iir_Kind_Simple_Name_Attribute => + declare + use Str_Table; + Id : String_Id; + begin + Id := Start; + Image (Get_Simple_Name_Identifier (Expr)); + for I in 1 .. Name_Length loop + Append (Name_Buffer (I)); + end loop; + Finish; + return Build_String (Id, Nat32 (Name_Length), Expr); + end; + + when Iir_Kind_Null_Literal => + return Expr; + + when Iir_Kind_Function_Call => + declare + Imp : constant Iir := Get_Implementation (Expr); + Left, Right : Iir; + begin + -- Note: there can't be association by name. + Left := Get_Parameter_Association_Chain (Expr); + Right := Get_Chain (Left); + + Left := Eval_Static_Expr (Get_Actual (Left)); + if Right = Null_Iir then + return Eval_Monadic_Operator (Expr, Left); + else + Right := Eval_Static_Expr (Get_Actual (Right)); + return Eval_Dyadic_Operator (Expr, Imp, Left, Right); + end if; + end; + + when Iir_Kind_Error => + return Expr; + when others => + Error_Kind ("eval_static_expr", Expr); + end case; + end Eval_Static_Expr; + + -- If FORCE is true, always return a literal. + function Eval_Expr_Keep_Orig (Expr : Iir; Force : Boolean) return Iir + is + Res : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kinds_Denoting_Name => + declare + Orig : constant Iir := Get_Named_Entity (Expr); + begin + Res := Eval_Static_Expr (Orig); + if Res /= Orig or else Force then + return Build_Constant (Res, Expr); + else + return Expr; + end if; + end; + when others => + Res := Eval_Static_Expr (Expr); + if Res /= Expr + and then Get_Literal_Origin (Res) /= Expr + then + -- Need to build a constant if the result is a different + -- literal not tied to EXPR. + return Build_Constant (Res, Expr); + else + return Res; + end if; + end case; + end Eval_Expr_Keep_Orig; + + function Eval_Expr (Expr: Iir) return Iir is + begin + if Get_Expr_Staticness (Expr) /= Locally then + Error_Msg_Sem ("expression must be locally static", Expr); + return Expr; + else + return Eval_Expr_Keep_Orig (Expr, False); + end if; + end Eval_Expr; + + function Eval_Expr_If_Static (Expr : Iir) return Iir is + begin + if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then + return Eval_Expr_Keep_Orig (Expr, False); + else + return Expr; + end if; + end Eval_Expr_If_Static; + + function Eval_Expr_Check (Expr : Iir; Sub_Type : Iir) return Iir + is + Res : Iir; + begin + Res := Eval_Expr_Keep_Orig (Expr, False); + Eval_Check_Bound (Res, Sub_Type); + return Res; + end Eval_Expr_Check; + + function Eval_Expr_Check_If_Static (Expr : Iir; Atype : Iir) return Iir + is + Res : Iir; + begin + if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then + -- Expression is static and can be evaluated. + Res := Eval_Expr_Keep_Orig (Expr, False); + + if Res /= Null_Iir + and then Get_Type_Staticness (Atype) = Locally + and then Get_Kind (Atype) in Iir_Kinds_Range_Type_Definition + then + -- Check bounds (as this can be done). + -- FIXME: create overflow_expr ? + Eval_Check_Bound (Res, Atype); + end if; + + return Res; + 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 + when Iir_Kind_Range_Expression => + case Get_Direction (Bound) is + when Iir_To => + if Val < Eval_Pos (Get_Left_Limit (Bound)) + or else Val > Eval_Pos (Get_Right_Limit (Bound)) + then + return False; + end if; + when Iir_Downto => + if Val > Eval_Pos (Get_Left_Limit (Bound)) + or else Val < Eval_Pos (Get_Right_Limit (Bound)) + then + return False; + end if; + end case; + when others => + Error_Kind ("eval_int_in_range", Bound); + end case; + return True; + end Eval_Int_In_Range; + + function Eval_Phys_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean + is + Left, Right : Iir_Int64; + begin + case Get_Kind (Bound) is + when Iir_Kind_Range_Expression => + case Get_Kind (Get_Type (Get_Left_Limit (Bound))) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + Left := Get_Value (Get_Left_Limit (Bound)); + Right := Get_Value (Get_Right_Limit (Bound)); + when Iir_Kind_Physical_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + Left := Get_Physical_Value (Get_Left_Limit (Bound)); + Right := Get_Physical_Value (Get_Right_Limit (Bound)); + when others => + Error_Kind ("eval_phys_in_range(1)", Get_Type (Bound)); + end case; + case Get_Direction (Bound) is + when Iir_To => + if Val < Left or else Val > Right then + return False; + end if; + when Iir_Downto => + if Val > Left or else Val < Right then + return False; + end if; + end case; + when others => + Error_Kind ("eval_phys_in_range", Bound); + end case; + return True; + end Eval_Phys_In_Range; + + function Eval_Fp_In_Range (Val : Iir_Fp64; Bound : Iir) return Boolean is + begin + case Get_Kind (Bound) is + when Iir_Kind_Range_Expression => + case Get_Direction (Bound) is + when Iir_To => + if Val < Get_Fp_Value (Get_Left_Limit (Bound)) + or else Val > Get_Fp_Value (Get_Right_Limit (Bound)) + then + return False; + end if; + when Iir_Downto => + if Val > Get_Fp_Value (Get_Left_Limit (Bound)) + or else Val < Get_Fp_Value (Get_Right_Limit (Bound)) + then + return False; + end if; + end case; + when others => + Error_Kind ("eval_fp_in_range", Bound); + end case; + return True; + end Eval_Fp_In_Range; + + -- Return TRUE if literal EXPR is in SUB_TYPE bounds. + function Eval_Is_In_Bound (Expr : Iir; Sub_Type : Iir) return Boolean + is + Type_Range : Iir; + Val : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kind_Error => + -- Ignore errors. + return True; + when Iir_Kind_Overflow_Literal => + -- Never within bounds + return False; + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Selected_Name => + Val := Get_Named_Entity (Expr); + when others => + Val := Expr; + end case; + + case Get_Kind (Sub_Type) is + when Iir_Kind_Integer_Subtype_Definition => + Type_Range := Get_Range_Constraint (Sub_Type); + return Eval_Int_In_Range (Get_Value (Val), Type_Range); + when Iir_Kind_Floating_Subtype_Definition => + Type_Range := Get_Range_Constraint (Sub_Type); + return Eval_Fp_In_Range (Get_Fp_Value (Val), Type_Range); + when Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + -- A check is required for an enumeration type definition for + -- 'val attribute. + Type_Range := Get_Range_Constraint (Sub_Type); + return Eval_Int_In_Range + (Iir_Int64 (Get_Enum_Pos (Val)), Type_Range); + when Iir_Kind_Physical_Subtype_Definition => + Type_Range := Get_Range_Constraint (Sub_Type); + return Eval_Phys_In_Range (Get_Physical_Value (Val), Type_Range); + + when Iir_Kind_Base_Attribute => + return Eval_Is_In_Bound (Val, Get_Type (Sub_Type)); + + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Record_Type_Definition => + -- FIXME: do it. + return True; + + when others => + Error_Kind ("eval_is_in_bound", Sub_Type); + end case; + end Eval_Is_In_Bound; + + procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir) is + begin + if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then + -- Nothing to check, and a message was already generated. + return; + end if; + + if not Eval_Is_In_Bound (Expr, Sub_Type) then + Error_Msg_Sem ("static constant violates bounds", Expr); + end if; + end Eval_Check_Bound; + + function Eval_Is_Range_In_Bound + (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) + return Boolean + is + Type_Range : Iir; + Range_Constraint : constant Iir := Eval_Static_Range (A_Range); + begin + Type_Range := Get_Range_Constraint (Sub_Type); + if not Any_Dir + and then Get_Direction (Type_Range) /= Get_Direction (Range_Constraint) + then + return True; + end if; + + case Get_Kind (Sub_Type) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + declare + L, R : Iir_Int64; + begin + -- Check for null range. + L := Eval_Pos (Get_Left_Limit (Range_Constraint)); + R := Eval_Pos (Get_Right_Limit (Range_Constraint)); + case Get_Direction (Range_Constraint) is + when Iir_To => + if L > R then + return True; + end if; + when Iir_Downto => + if L < R then + return True; + end if; + end case; + return Eval_Int_In_Range (L, Type_Range) + and then Eval_Int_In_Range (R, Type_Range); + end; + when Iir_Kind_Floating_Subtype_Definition => + declare + L, R : Iir_Fp64; + begin + -- Check for null range. + L := Get_Fp_Value (Get_Left_Limit (Range_Constraint)); + R := Get_Fp_Value (Get_Right_Limit (Range_Constraint)); + case Get_Direction (Range_Constraint) is + when Iir_To => + if L > R then + return True; + end if; + when Iir_Downto => + if L < R then + return True; + end if; + end case; + return Eval_Fp_In_Range (L, Type_Range) + and then Eval_Fp_In_Range (R, Type_Range); + end; + when others => + Error_Kind ("eval_is_range_in_bound", Sub_Type); + end case; + + -- Should check L <= R or L >= R according to direction. + --return Eval_Is_In_Bound (Get_Left_Limit (A_Range), Sub_Type) + -- and then Eval_Is_In_Bound (Get_Right_Limit (A_Range), Sub_Type); + end Eval_Is_Range_In_Bound; + + procedure Eval_Check_Range + (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) + is + begin + if not Eval_Is_Range_In_Bound (A_Range, Sub_Type, Any_Dir) then + Error_Msg_Sem ("static range violates bounds", A_Range); + end if; + end Eval_Check_Range; + + function Eval_Discrete_Range_Length (Constraint : Iir) return Iir_Int64 + is + Res : Iir_Int64; + Left, Right : Iir_Int64; + begin + Left := Eval_Pos (Get_Left_Limit (Constraint)); + Right := Eval_Pos (Get_Right_Limit (Constraint)); + case Get_Direction (Constraint) is + when Iir_To => + if Right < Left then + -- Null range. + return 0; + else + Res := Right - Left + 1; + end if; + when Iir_Downto => + if Left < Right then + -- Null range + return 0; + else + Res := Left - Right + 1; + end if; + end case; + return Res; + end Eval_Discrete_Range_Length; + + function Eval_Discrete_Type_Length (Sub_Type : Iir) return Iir_Int64 + is + begin + case Get_Kind (Sub_Type) is + when Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + return Eval_Discrete_Range_Length + (Get_Range_Constraint (Sub_Type)); + when others => + Error_Kind ("eval_discrete_type_length", Sub_Type); + end case; + end Eval_Discrete_Type_Length; + + function Eval_Pos (Expr : Iir) return Iir_Int64 is + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal => + return Get_Value (Expr); + when Iir_Kind_Enumeration_Literal => + return Iir_Int64 (Get_Enum_Pos (Expr)); + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Unit_Declaration => + return Get_Physical_Value (Expr); + when Iir_Kinds_Denoting_Name => + return Eval_Pos (Get_Named_Entity (Expr)); + when others => + Error_Kind ("eval_pos", Expr); + end case; + end Eval_Pos; + + function Eval_Static_Range (Rng : Iir) return Iir + is + Expr : Iir; + Kind : Iir_Kind; + begin + Expr := Rng; + loop + Kind := Get_Kind (Expr); + case Kind is + when Iir_Kind_Range_Expression => + if Get_Expr_Staticness (Expr) /= Locally then + return Null_Iir; + end if; + + -- Normalize the range expression. + Set_Left_Limit + (Expr, Eval_Expr_Keep_Orig (Get_Left_Limit (Expr), True)); + Set_Right_Limit + (Expr, Eval_Expr_Keep_Orig (Get_Right_Limit (Expr), True)); + return Expr; + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Expr := Get_Range_Constraint (Expr); + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + declare + Prefix : Iir; + Res : Iir; + begin + Prefix := Get_Prefix (Expr); + if Get_Kind (Prefix) /= Iir_Kind_Array_Subtype_Definition + then + Prefix := Get_Type (Prefix); + end if; + if Get_Kind (Prefix) /= Iir_Kind_Array_Subtype_Definition + then + -- Unconstrained object. + return Null_Iir; + end if; + Expr := Get_Nth_Element + (Get_Index_Subtype_List (Prefix), + Natural (Eval_Pos (Get_Parameter (Expr))) - 1); + if Kind = Iir_Kind_Reverse_Range_Array_Attribute then + Expr := Eval_Static_Range (Expr); + + Res := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Res, Expr); + Set_Type (Res, Get_Type (Expr)); + case Get_Direction (Expr) is + when Iir_To => + Set_Direction (Res, Iir_Downto); + when Iir_Downto => + Set_Direction (Res, Iir_To); + end case; + Set_Left_Limit (Res, Get_Right_Limit (Expr)); + Set_Right_Limit (Res, Get_Left_Limit (Expr)); + Set_Range_Origin (Res, Rng); + Set_Expr_Staticness (Res, Get_Expr_Staticness (Expr)); + return Res; + end if; + end; + + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Base_Attribute => + Expr := Get_Type (Expr); + when Iir_Kind_Type_Declaration => + Expr := Get_Type_Definition (Expr); + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Expr := Get_Named_Entity (Expr); + when others => + Error_Kind ("eval_static_range", Expr); + end case; + end loop; + end Eval_Static_Range; + + function Eval_Range (Arange : Iir) return Iir is + Res : Iir; + begin + Res := Eval_Static_Range (Arange); + if Res /= Arange + and then Get_Range_Origin (Res) /= Arange + then + return Build_Constant_Range (Res, Arange); + else + return Res; + end if; + end Eval_Range; + + function Eval_Range_If_Static (Arange : Iir) return Iir is + begin + if Get_Expr_Staticness (Arange) /= Locally then + return Arange; + else + return Eval_Range (Arange); + end if; + end Eval_Range_If_Static; + + -- Return the range constraint of a discrete range. + function Eval_Discrete_Range_Expression (Constraint : Iir) return Iir + is + Res : Iir; + begin + Res := Eval_Static_Range (Constraint); + if Res = Null_Iir then + Error_Kind ("eval_discrete_range_expression", Constraint); + else + return Res; + end if; + end Eval_Discrete_Range_Expression; + + function Eval_Discrete_Range_Left (Constraint : Iir) return Iir + is + Range_Expr : Iir; + begin + Range_Expr := Eval_Discrete_Range_Expression (Constraint); + return Get_Left_Limit (Range_Expr); + end Eval_Discrete_Range_Left; + + procedure Eval_Operator_Symbol_Name (Id : Name_Id) + is + begin + Image (Id); + Name_Buffer (2 .. Name_Length + 1) := Name_Buffer (1 .. Name_Length); + Name_Buffer (1) := '"'; --" + Name_Length := Name_Length + 2; + Name_Buffer (Name_Length) := '"'; --" + end Eval_Operator_Symbol_Name; + + procedure Eval_Simple_Name (Id : Name_Id) + is + begin + -- LRM 14.1 + -- E'SIMPLE_NAME + -- Result: [...] but with apostrophes (in the case of a character + -- literal) + if Is_Character (Id) then + Name_Buffer (1) := '''; + Name_Buffer (2) := Get_Character (Id); + Name_Buffer (3) := '''; + Name_Length := 3; + return; + end if; + case Id is + when Std_Names.Name_Word_Operators + | Std_Names.Name_First_Operator .. Std_Names.Name_Last_Operator => + Eval_Operator_Symbol_Name (Id); + return; + when Std_Names.Name_Xnor + | Std_Names.Name_Shift_Operators => + if Flags.Vhdl_Std > Vhdl_87 then + Eval_Operator_Symbol_Name (Id); + return; + end if; + when others => + null; + end case; + Image (Id); +-- if Name_Buffer (1) = '\' then +-- declare +-- I : Natural; +-- begin +-- I := 2; +-- while I <= Name_Length loop +-- if Name_Buffer (I) = '\' then +-- Name_Length := Name_Length + 1; +-- Name_Buffer (I + 1 .. Name_Length) := +-- Name_Buffer (I .. Name_Length - 1); +-- I := I + 1; +-- end if; +-- I := I + 1; +-- end loop; +-- Name_Length := Name_Length + 1; +-- Name_Buffer (Name_Length) := '\'; +-- end; +-- end if; + end Eval_Simple_Name; + + function Compare_String_Literals (L, R : Iir) return Compare_Type + is + type Str_Info is record + El : Iir; + Ptr : String_Fat_Acc; + Len : Nat32; + Lit_0 : Iir; + Lit_1 : Iir; + List : Iir_List; + end record; + + Literal_List : Iir_List; + + -- Fill Res from EL. This is used to speed up Lt and Eq operations. + procedure Get_Info (Expr : Iir; Res : out Str_Info) is + 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 := Nat32 (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 : Nat32) 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, Natural (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 (Literal_List, + Name_Table.Get_Identifier (C)); + if S = Null_Iir then + return -1; + end if; + 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; + + L_Info, R_Info : Str_Info; + L_Pos, R_Pos : Iir_Int32; + begin + Get_Info (L, L_Info); + Get_Info (R, R_Info); + + if L_Info.Len /= R_Info.Len then + raise Internal_Error; + end if; + + Literal_List := Get_Enumeration_Literal_List + (Get_Base_Type (Get_Element_Subtype (Get_Type (L)))); + + for I in 0 .. L_Info.Len - 1 loop + L_Pos := Get_Pos (L_Info, I); + R_Pos := Get_Pos (R_Info, I); + if L_Pos /= R_Pos then + if L_Pos < R_Pos then + return Compare_Lt; + else + return Compare_Gt; + end if; + end if; + end loop; + return Compare_Eq; + end Compare_String_Literals; + + function Get_Path_Instance_Name_Suffix (Attr : Iir) + return Path_Instance_Name_Type + is + -- Current path for name attributes. + Path_Str : String_Acc := null; + Path_Maxlen : Natural := 0; + Path_Len : Natural; + Path_Instance : Iir; + + procedure Deallocate is new Ada.Unchecked_Deallocation + (Name => String_Acc, Object => String); + + procedure Path_Reset is + begin + Path_Len := 0; + Path_Instance := Null_Iir; + if Path_Maxlen = 0 then + Path_Maxlen := 256; + Path_Str := new String (1 .. Path_Maxlen); + end if; + end Path_Reset; + + procedure Path_Add (Str : String) + is + N_Len : Natural; + N_Path : String_Acc; + begin + N_Len := Path_Maxlen; + loop + exit when Path_Len + Str'Length <= N_Len; + N_Len := N_Len * 2; + end loop; + if N_Len /= Path_Maxlen then + N_Path := new String (1 .. N_Len); + N_Path (1 .. Path_Len) := Path_Str (1 .. Path_Len); + Deallocate (Path_Str); + Path_Str := N_Path; + Path_Maxlen := N_Len; + end if; + Path_Str (Path_Len + 1 .. Path_Len + Str'Length) := Str; + Path_Len := Path_Len + Str'Length; + end Path_Add; + + procedure Path_Add_Type_Name (Atype : Iir) + is + Adecl : Iir; + begin + Adecl := Get_Type_Declarator (Atype); + Image (Get_Identifier (Adecl)); + Path_Add (Name_Buffer (1 .. Name_Length)); + end Path_Add_Type_Name; + + procedure Path_Add_Signature (Subprg : Iir) + is + Chain : Iir; + begin + Path_Add ("["); + Chain := Get_Interface_Declaration_Chain (Subprg); + while Chain /= Null_Iir loop + Path_Add_Type_Name (Get_Type (Chain)); + Chain := Get_Chain (Chain); + if Chain /= Null_Iir then + Path_Add (","); + end if; + end loop; + + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration => + Path_Add (" return "); + Path_Add_Type_Name (Get_Return_Type (Subprg)); + when others => + null; + end case; + Path_Add ("]"); + end Path_Add_Signature; + + procedure Path_Add_Name (N : Iir) is + begin + Eval_Simple_Name (Get_Identifier (N)); + if Name_Buffer (1) /= 'P' then + -- Skip anonymous processes. + Path_Add (Name_Buffer (1 .. Name_Length)); + end if; + end Path_Add_Name; + + procedure Path_Add_Element (El : Iir; Is_Instance : Boolean) is + begin + -- LRM 14.1 + -- E'INSTANCE_NAME + -- There is one full path instance element for each component + -- instantiation, block statement, generate statemenent, process + -- statement, or subprogram body in the design hierarchy between + -- the top design entity and the named entity denoted by the + -- prefix. + -- + -- E'PATH_NAME + -- There is one path instance element for each component + -- instantiation, block statement, generate statement, process + -- statement, or subprogram body in the design hierarchy between + -- the root design entity and the named entity denoted by the + -- prefix. + case Get_Kind (El) is + when Iir_Kind_Library_Declaration => + Path_Add (":"); + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + Path_Add_Element + (Get_Library (Get_Design_File (Get_Design_Unit (El))), + Is_Instance); + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Entity_Declaration => + Path_Instance := El; + when Iir_Kind_Architecture_Body => + Path_Instance := El; + when Iir_Kind_Design_Unit => + Path_Add_Element (Get_Library_Unit (El), Is_Instance); + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Block_Statement => + Path_Add_Element (Get_Parent (El), Is_Instance); + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + Path_Add_Element (Get_Parent (El), Is_Instance); + Path_Add_Name (El); + if Flags.Vhdl_Std >= Vhdl_02 then + -- Add signature. + Path_Add_Signature (El); + end if; + Path_Add (":"); + when Iir_Kind_Procedure_Body => + Path_Add_Element (Get_Subprogram_Specification (El), + Is_Instance); + when Iir_Kind_Generate_Statement => + declare + Scheme : Iir; + begin + Scheme := Get_Generation_Scheme (El); + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Path_Instance := El; + else + Path_Add_Element (Get_Parent (El), Is_Instance); + Path_Add_Name (El); + Path_Add (":"); + end if; + end; + when Iir_Kinds_Sequential_Statement => + Path_Add_Element (Get_Parent (El), Is_Instance); + when others => + Error_Kind ("path_add_element", El); + end case; + end Path_Add_Element; + + Prefix : constant Iir := Get_Named_Entity (Get_Prefix (Attr)); + Is_Instance : constant Boolean := + Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; + begin + Path_Reset; + + -- LRM 14.1 + -- E'PATH_NAME + -- The local item name in E'PATH_NAME equals E'SIMPLE_NAME, unless + -- E denotes a library, package, subprogram or label. In this + -- latter case, the package based path or instance based path, + -- as appropriate, will not contain a local item name. + -- + -- E'INSTANCE_NAME + -- The local item name in E'INSTANCE_NAME equals E'SIMPLE_NAME, + -- unless E denotes a library, package, subprogram, or label. In + -- this latter case, the package based path or full instance based + -- path, as appropriate, will not contain a local item name. + case Get_Kind (Prefix) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + Path_Add_Element (Get_Parent (Prefix), Is_Instance); + Path_Add_Name (Prefix); + when Iir_Kind_Library_Declaration + | Iir_Kinds_Library_Unit_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement => + Path_Add_Element (Prefix, Is_Instance); + when others => + Error_Kind ("get_path_instance_name_suffix", Prefix); + end case; + + declare + Result : constant Path_Instance_Name_Type := + (Len => Path_Len, + Path_Instance => Path_Instance, + Suffix => Path_Str (1 .. Path_Len)); + begin + Deallocate (Path_Str); + return Result; + end; + end Get_Path_Instance_Name_Suffix; + +end Evaluation; diff --git a/src/vhdl/evaluation.ads b/src/vhdl/evaluation.ads new file mode 100644 index 000000000..66ec2a1cc --- /dev/null +++ b/src/vhdl/evaluation.ads @@ -0,0 +1,161 @@ +-- Evaluation of static expressions. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Iirs; use Iirs; + +package Evaluation is + + -- Evaluation is about compile-time computation of expressions, such as + -- 2 + 1 --> 3. This is (of course) possible only with locally (and some + -- globally) static expressions. Evaluation is required during semantic + -- analysis at many places (in fact those where locally static expression + -- are required by the language). For example, the type of O'Range (N) + -- depends on N, so we need to evaluate N. + -- + -- The result of evaluation is a literal (integer, enumeration, real, + -- physical), a string or a simple aggregate. For scalar types, the + -- result is therefore normalized (there is only one kind of result), but + -- for array types, the result isn't: in general it will be a string, but + -- it may be a simple aggregate. Strings are preferred (because they are + -- more compact), but aren't possible in some cases. For example, the + -- evaluation of "Text" & NUL cannot be a string. + -- + -- Some functions (like Eval_Static_Expr) simply returns a result (which + -- may be a node of the expression), others returns a result and set the + -- origin (Literal_Origin or Range_Origin) to remember the original + -- expression that was evaluation. The original expression is kept so that + -- it is possible to print the original tree. + + -- Get the value of a physical integer literal or unit. + function Get_Physical_Value (Expr : Iir) return Iir_Int64; + + -- Evaluate the locally static expression EXPR (without checking that EXPR + -- is locally static). Return a literal or an aggregate, without setting + -- the origin, and do not modify EXPR. This can be used only to get the + -- value of an expression, without replacing it. + function Eval_Static_Expr (Expr: Iir) return Iir; + + -- Evaluate (ie compute) expression EXPR. + -- EXPR is required to be a locally static expression, otherwise an error + -- message is generated. + -- The result is a literal with the origin set. + function Eval_Expr (Expr: Iir) return Iir; + + -- Same as Eval_Expr, but if EXPR is not locally static, the result is + -- EXPR. Also, if EXPR is null_iir, then null_iir is returned. + -- The purpose of this function is to evaluate an expression only if it + -- is locally static. + function Eval_Expr_If_Static (Expr : Iir) return Iir; + + -- Evaluate a physical literal and return a normalized literal (using + -- the primary unit as unit). + function Eval_Physical_Literal (Expr : Iir) return Iir; + + -- Return TRUE if literal EXPR is in SUB_TYPE bounds. + function Eval_Is_In_Bound (Expr : Iir; Sub_Type : Iir) return Boolean; + + -- Emit an error if EXPR violates SUB_TYPE bounds. + procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir); + + -- Same as Eval_Expr, but a range check with SUB_TYPE is performed after + -- 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; + + -- For a locally static range RNG (a range expression, a range attribute + -- or a name that denotes a type or a subtype) returns its corresponding + -- locally static range_expression. The bounds of the results are also + -- literals. + -- Return a range_expression or NULL_IIR for a non locally static range. + function Eval_Static_Range (Rng : Iir) return Iir; + + -- Return a locally static range expression with the origin set for ARANGE. + function Eval_Range (Arange : Iir) return Iir; + + -- If ARANGE is a locally static range, return locally static range + -- expression (with the origin set), else return ARANGE. + function Eval_Range_If_Static (Arange : Iir) return Iir; + + -- Emit an error if A_RANGE is not included in SUB_TYPE. A_RANGE can be + -- a range expression, a range attribute or a name that denotes a discrete + -- type or subtype. A_RANGE must be a locally static range. + procedure Eval_Check_Range (A_Range : Iir; Sub_Type : Iir; + Any_Dir : Boolean); + + -- Return TRUE if range expression A_RANGE is not included in SUB_TYPE. + function Eval_Is_Range_In_Bound + (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) + return Boolean; + + -- Return TRUE iff VAL belongs to BOUND. + function Eval_Int_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean; + + -- Return the length of the discrete range CONSTRAINT. + function Eval_Discrete_Range_Length (Constraint : Iir) return Iir_Int64; + + -- Return the length of SUB_TYPE. + function Eval_Discrete_Type_Length (Sub_Type : Iir) return Iir_Int64; + + -- Get the left bound of a range constraint. + -- Note: the range constraint may be an attribute or a subtype. + function Eval_Discrete_Range_Left (Constraint : Iir) return Iir; + + -- Return the position of EXPR, ie the result of sub_type'pos (EXPR), where + -- sub_type is the type of expr. + -- EXPR must be of a discrete subtype. + function Eval_Pos (Expr : Iir) return Iir_Int64; + + -- Replace ORIGIN (an overflow literal) with extreme positive value (if + -- IS_POS is true) or extreme negative value. + function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir; + + -- Create an array subtype from LEN and BASE_TYPE, according to rules + -- of LRM93 7.3.2.2. (which are the same as LRM93 7.2.4). + function Create_Unidim_Array_By_Length + (Base_Type : Iir; Len : Iir_Int64; Loc : Iir) + return Iir_Array_Subtype_Definition; + + -- Create a subtype of A_TYPE whose length is LEN. + -- This is used to create subtypes for strings or aggregates. + function Create_Range_Subtype_By_Length + (A_Type : Iir; Len : Iir_Int64; Loc : Location_Type) + return Iir; + + -- Store into NAME_BUFFER, NAME_LENGTH the simple name, character literal + -- or operator sumbol of ID, using the same format as SIMPLE_NAME + -- attribute. + procedure Eval_Simple_Name (Id : Name_Id); + + -- Compare two string literals (of same length). + type Compare_Type is (Compare_Lt, Compare_Eq, Compare_Gt); + function Compare_String_Literals (L, R : Iir) return Compare_Type; + + -- Return the local part of 'Instance_Name or 'Path_Name. + type Path_Instance_Name_Type (Len : Natural) is record + -- The node before suffix (entity, architecture or generate iterator). + Path_Instance : Iir; + + -- The suffix + Suffix : String (1 .. Len); + end record; + + function Get_Path_Instance_Name_Suffix (Attr : Iir) + return Path_Instance_Name_Type; +end Evaluation; diff --git a/src/vhdl/ieee-std_logic_1164.adb b/src/vhdl/ieee-std_logic_1164.adb new file mode 100644 index 000000000..ee58fe7a5 --- /dev/null +++ b/src/vhdl/ieee-std_logic_1164.adb @@ -0,0 +1,170 @@ +-- Nodes recognizer for ieee.std_logic_1164. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Std_Names; use Std_Names; +with Errorout; use Errorout; +with Std_Package; + +package body Ieee.Std_Logic_1164 is + function Skip_Implicit (Decl : Iir) return Iir + is + Res : Iir; + begin + Res := Decl; + loop + exit when Res = Null_Iir; + exit when Get_Kind (Res) /= Iir_Kind_Implicit_Function_Declaration; + Res := Get_Chain (Res); + end loop; + return Res; + end Skip_Implicit; + + procedure Extract_Declarations (Pkg : Iir_Package_Declaration) + is + Error : exception; + + Decl : Iir; + Def : Iir; + begin + Std_Logic_1164_Pkg := Pkg; + + Decl := Get_Declaration_Chain (Pkg); + + -- Skip a potential copyright constant. + if Decl /= Null_Iir + and then Get_Kind (Decl) = Iir_Kind_Constant_Declaration + and then (Get_Base_Type (Get_Type (Decl)) + = Std_Package.String_Type_Definition) + then + Decl := Get_Chain (Decl); + end if; + + -- The first declaration should be type std_ulogic. + if Decl = Null_Iir + or else Get_Kind (Decl) /= Iir_Kind_Type_Declaration + or else Get_Identifier (Decl) /= Name_Std_Ulogic + then + raise Error; + end if; + + Def := Get_Type_Definition (Decl); + if Get_Kind (Def) /= Iir_Kind_Enumeration_Type_Definition then + raise Error; + end if; + Std_Ulogic_Type := Def; + + -- The second declaration should be std_ulogic_vector. + Decl := Get_Chain (Decl); + Decl := Skip_Implicit (Decl); + if Decl = Null_Iir + or else Get_Kind (Decl) /= Iir_Kind_Type_Declaration + or else Get_Identifier (Decl) /= Name_Std_Ulogic_Vector + then + raise Error; + end if; + Def := Get_Type_Definition (Decl); + if Get_Kind (Def) /= Iir_Kind_Array_Type_Definition then + raise Error; + end if; + Std_Ulogic_Vector_Type := Def; + + -- The third declaration should be resolved. + Decl := Get_Chain (Decl); + Decl := Skip_Implicit (Decl); + if Decl = Null_Iir + or else Get_Kind (Decl) /= Iir_Kind_Function_Declaration + then + -- FIXME: check name ? + raise Error; + end if; + Resolved := Decl; + + -- The fourth declaration should be std_logic. + Decl := Get_Chain (Decl); + Decl := Skip_Implicit (Decl); + if Decl = Null_Iir + or else Get_Kind (Decl) /= Iir_Kind_Subtype_Declaration + or else Get_Identifier (Decl) /= Name_Std_Logic + then + raise Error; + end if; + Def := Get_Type (Decl); + if Get_Kind (Def) /= Iir_Kind_Enumeration_Subtype_Definition then + raise Error; + end if; + Std_Logic_Type := Def; + + -- The fifth declaration should be std_logic_vector. + Decl := Get_Chain (Decl); + Decl := Skip_Implicit (Decl); + if Decl = Null_Iir + 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; + Std_Logic_Vector_Type := Def; + + -- Skip any declarations but functions. + loop + Decl := Get_Chain (Decl); + exit when Decl = Null_Iir; + + if Get_Kind (Decl) = Iir_Kind_Function_Declaration then + if Get_Identifier (Decl) = Name_Rising_Edge then + Rising_Edge := Decl; + elsif Get_Identifier (Decl) = Name_Falling_Edge then + Falling_Edge := Decl; + end if; + end if; + end loop; + + -- Since rising_edge and falling_edge do not read activity of its + -- parameter, clear the flag to allow more optimizations. + if Rising_Edge /= Null_Iir then + Set_Has_Active_Flag + (Get_Interface_Declaration_Chain (Rising_Edge), False); + else + raise Error; + end if; + if Falling_Edge /= Null_Iir then + Set_Has_Active_Flag + (Get_Interface_Declaration_Chain (Falling_Edge), False); + else + raise Error; + end if; + + exception + when Error => + Error_Msg_Sem ("package ieee.std_logic_1164 is ill-formed", Pkg); + + -- Clear all definitions. + Std_Logic_1164_Pkg := Null_Iir; + Std_Ulogic_Type := Null_Iir; + Std_Ulogic_Vector_Type := Null_Iir; + Std_Logic_Type := Null_Iir; + Std_Logic_Vector_Type := Null_Iir; + Rising_Edge := Null_Iir; + Falling_Edge := Null_Iir; + end Extract_Declarations; +end Ieee.Std_Logic_1164; diff --git a/src/vhdl/ieee-std_logic_1164.ads b/src/vhdl/ieee-std_logic_1164.ads new file mode 100644 index 000000000..b1f14f272 --- /dev/null +++ b/src/vhdl/ieee-std_logic_1164.ads @@ -0,0 +1,35 @@ +-- Nodes recognizer for ieee.std_logic_1164. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +package Ieee.Std_Logic_1164 is + -- Nodes corresponding to declarations in the package. + Std_Logic_1164_Pkg : Iir_Package_Declaration := Null_Iir; + Std_Ulogic_Type : Iir_Enumeration_Type_Definition := Null_Iir; + Std_Ulogic_Vector_Type : Iir_Array_Type_Definition := Null_Iir; + Std_Logic_Type : Iir_Enumeration_Subtype_Definition := Null_Iir; + Std_Logic_Vector_Type : Iir_Array_Type_Definition := Null_Iir; + Resolved : Iir_Function_Declaration := Null_Iir; + Rising_Edge : Iir_Function_Declaration := Null_Iir; + Falling_Edge : Iir_Function_Declaration := Null_Iir; + + -- Extract declarations from PKG. + -- PKG is the package declaration for ieee.std_logic_1164 package. + -- Fills the node aboves. + procedure Extract_Declarations (Pkg : Iir_Package_Declaration); +end Ieee.Std_Logic_1164; diff --git a/src/vhdl/ieee-vital_timing.adb b/src/vhdl/ieee-vital_timing.adb new file mode 100644 index 000000000..d6429e251 --- /dev/null +++ b/src/vhdl/ieee-vital_timing.adb @@ -0,0 +1,1377 @@ +-- Nodes recognizer for ieee.vital_timing. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Std_Names; +with Errorout; use Errorout; +with Std_Package; use Std_Package; +with Tokens; use Tokens; +with Name_Table; +with Ieee.Std_Logic_1164; use Ieee.Std_Logic_1164; +with Sem_Scopes; +with Evaluation; +with Sem; +with Iirs_Utils; +with Flags; + +package body Ieee.Vital_Timing is + -- This package is based on IEEE 1076.4 1995. + + -- Control generics identifier. + InstancePath_Id : Name_Id; + TimingChecksOn_Id : Name_Id; + XOn_Id : Name_Id; + MsgOn_Id : Name_Id; + + -- Extract declarations from package IEEE.VITAL_Timing. + procedure Extract_Declarations (Pkg : Iir_Package_Declaration) + is + use Name_Table; + + Ill_Formed : exception; + + Decl : Iir; + Id : Name_Id; + + VitalDelayType_Id : Name_Id; + VitalDelayType01_Id : Name_Id; + VitalDelayType01Z_Id : Name_Id; + VitalDelayType01ZX_Id : Name_Id; + + VitalDelayArrayType_Id : Name_Id; + VitalDelayArrayType01_Id : Name_Id; + VitalDelayArrayType01Z_Id : Name_Id; + VitalDelayArrayType01ZX_Id : Name_Id; + begin + -- Get Vital delay type identifiers. + Name_Buffer (1 .. 18) := "vitaldelaytype01zx"; + Name_Length := 14; + VitalDelayType_Id := Get_Identifier_No_Create; + if VitalDelayType_Id = Null_Identifier then + raise Ill_Formed; + end if; + Name_Length := 16; + VitalDelayType01_Id := Get_Identifier_No_Create; + if VitalDelayType01_Id = Null_Identifier then + raise Ill_Formed; + end if; + Name_Length := 17; + VitalDelayType01Z_Id := Get_Identifier_No_Create; + if VitalDelayType01Z_Id = Null_Identifier then + raise Ill_Formed; + end if; + Name_Length := 18; + VitalDelayType01ZX_Id := Get_Identifier_No_Create; + if VitalDelayType01ZX_Id = Null_Identifier then + raise Ill_Formed; + end if; + + Name_Buffer (1 .. 23) := "vitaldelayarraytype01zx"; + Name_Length := 19; + VitalDelayArrayType_Id := Get_Identifier_No_Create; + if VitalDelayArrayType_Id = Null_Identifier then + raise Ill_Formed; + end if; + Name_Length := 21; + VitalDelayArrayType01_Id := Get_Identifier_No_Create; + if VitalDelayArrayType01_Id = Null_Identifier then + raise Ill_Formed; + end if; + Name_Length := 22; + VitalDelayArrayType01Z_Id := Get_Identifier_No_Create; + if VitalDelayArrayType01Z_Id = Null_Identifier then + raise Ill_Formed; + end if; + Name_Length := 23; + VitalDelayArrayType01ZX_Id := Get_Identifier_No_Create; + if VitalDelayArrayType01ZX_Id = Null_Identifier then + raise Ill_Formed; + end if; + + -- Iterate on every declaration. + -- Do name-matching. + Decl := Get_Declaration_Chain (Pkg); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Attribute_Declaration => + Id := Get_Identifier (Decl); + if Id = Std_Names.Name_VITAL_Level0 then + Vital_Level0_Attribute := Decl; + elsif Id = Std_Names.Name_VITAL_Level1 then + Vital_Level1_Attribute := Decl; + end if; + when Iir_Kind_Subtype_Declaration => + Id := Get_Identifier (Decl); + if Id = VitalDelayType_Id then + VitalDelayType := Get_Type (Decl); + end if; + when Iir_Kind_Type_Declaration => + Id := Get_Identifier (Decl); + if Id = VitalDelayArrayType_Id then + VitalDelayArrayType := Get_Type_Definition (Decl); + elsif Id = VitalDelayArrayType01_Id then + VitalDelayArrayType01 := Get_Type_Definition (Decl); + elsif Id = VitalDelayArrayType01Z_Id then + VitalDelayArrayType01Z := Get_Type_Definition (Decl); + elsif Id = VitalDelayArrayType01ZX_Id then + VitalDelayArrayType01ZX := Get_Type_Definition (Decl); + end if; + when Iir_Kind_Anonymous_Type_Declaration => + Id := Get_Identifier (Decl); + if Id = VitalDelayType01_Id then + VitalDelayType01 := Get_Type_Definition (Decl); + elsif Id = VitalDelayType01Z_Id then + VitalDelayType01Z := Get_Type_Definition (Decl); + elsif Id = VitalDelayType01ZX_Id then + VitalDelayType01ZX := Get_Type_Definition (Decl); + end if; + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + + -- If a declaration was not found, then the package is not the expected + -- one. + if Vital_Level0_Attribute = Null_Iir + or Vital_Level1_Attribute = Null_Iir + or VitalDelayType = Null_Iir + or VitalDelayType01 = Null_Iir + or VitalDelayType01Z = Null_Iir + or VitalDelayType01ZX = Null_Iir + or VitalDelayArrayType = Null_Iir + or VitalDelayArrayType01 = Null_Iir + or VitalDelayArrayType01Z = Null_Iir + or VitalDelayArrayType01ZX = Null_Iir + then + raise Ill_Formed; + end if; + + -- Create identifier for control generics. + InstancePath_Id := Get_Identifier ("instancepath"); + TimingChecksOn_Id := Get_Identifier ("timingcheckson"); + XOn_Id := Get_Identifier ("xon"); + MsgOn_Id := Get_Identifier ("msgon"); + + exception + when Ill_Formed => + Error_Msg_Sem ("package ieee.vital_timing is ill-formed", Pkg); + + Vital_Level0_Attribute := Null_Iir; + Vital_Level1_Attribute := Null_Iir; + + VitalDelayType := Null_Iir; + VitalDelayType01 := Null_Iir; + VitalDelayType01Z := Null_Iir; + VitalDelayType01ZX := Null_Iir; + + VitalDelayArrayType := Null_Iir; + VitalDelayArrayType01 := Null_Iir; + VitalDelayArrayType01Z := Null_Iir; + VitalDelayArrayType01ZX := Null_Iir; + end Extract_Declarations; + + procedure Error_Vital (Msg : String; Loc : Iir) renames Error_Msg_Sem; + procedure Error_Vital (Msg : String; Loc : Location_Type) + renames Error_Msg_Sem; + procedure Warning_Vital (Msg : String; Loc : Iir) renames Warning_Msg_Sem; + + -- Check DECL is the VITAL level 0 attribute specification. + procedure Check_Level0_Attribute_Specification (Decl : Iir) + is + Expr : Iir; + begin + if Get_Kind (Decl) /= Iir_Kind_Attribute_Specification + or else (Get_Named_Entity (Get_Attribute_Designator (Decl)) + /= Vital_Level0_Attribute) + then + Error_Vital + ("first declaration must be the VITAL attribute specification", + Decl); + return; + end if; + + -- IEEE 1076.4 4.1 + -- The expression in the VITAL_Level0 attribute specification shall be + -- the Boolean literal TRUE. + Expr := Get_Expression (Decl); + if Get_Kind (Expr) not in Iir_Kinds_Denoting_Name + or else Get_Named_Entity (Expr) /= Boolean_True + then + Error_Vital + ("the expression in the VITAL_Level0 attribute specification shall " + & "be the Boolean literal TRUE", Decl); + end if; + + -- IEEE 1076.4 4.1 + -- The entity specification of the decorating attribute specification + -- shall be such that the enclosing entity or architecture inherits the + -- VITAL_Level0 attribute. + case Get_Entity_Class (Decl) is + when Tok_Entity + | Tok_Architecture => + null; + when others => + Error_Vital ("VITAL attribute specification does not decorate the " + & "enclosing entity or architecture", Decl); + end case; + end Check_Level0_Attribute_Specification; + + procedure Check_Entity_Port_Declaration + (Decl : Iir_Interface_Signal_Declaration) + is + use Name_Table; + + Atype : Iir; + Base_Type : Iir; + Type_Decl : Iir; + begin + -- IEEE 1076.4 4.3.1 + -- The identifiers in an entity port declaration shall not contain + -- underscore characters. + Image (Get_Identifier (Decl)); + if Name_Buffer (1) = '/' then + Error_Vital ("VITAL entity port shall not be an extended identifier", + Decl); + end if; + for I in 1 .. Name_Length loop + if Name_Buffer (I) = '_' then + Error_Vital + ("VITAL entity port shall not contain underscore", Decl); + exit; + end if; + end loop; + + -- IEEE 1076.4 4.3.1 + -- A port that is declared in an entity port declaration shall not be + -- of mode LINKAGE. + if Get_Mode (Decl) = Iir_Linkage_Mode then + Error_Vital ("VITAL entity port shall not be of mode LINKAGE", Decl); + end if; + + -- IEEE 1076.4 4.3.1 + -- The type mark in an entity port declaration shall denote a type or + -- a subtype that is declared in package Std_Logic_1164. The type + -- mark in the declaration of a scalar port shall denote the subtype + -- Std_Ulogic or a subtype of Std_Ulogic. The type mark in the + -- declaration of an array port shall denote the type Std_Logic_Vector. + Atype := Get_Type (Decl); + Base_Type := Get_Base_Type (Atype); + Type_Decl := Get_Type_Declarator (Atype); + if Base_Type = Std_Logic_Vector_Type then + if Get_Resolution_Indication (Atype) /= Null_Iir then + Error_Vital + ("VITAL array port type cannot override resolution function", + Decl); + end if; + -- FIXME: is an unconstrained array port allowed ? + -- FIXME: what about staticness of the index_constraint ? + elsif Base_Type = Std_Ulogic_Type then + if Type_Decl = Null_Iir + or else Get_Parent (Type_Decl) /= Std_Logic_1164_Pkg + then + Error_Vital + ("VITAL entity port type mark shall be one of Std_Logic_1164", + Decl); + end if; + else + Error_Vital ("VITAL port type must be Std_Logic_Vector or Std_Ulogic", + Decl); + end if; + + if Get_Signal_Kind (Decl) /= Iir_No_Signal_Kind then + Error_Vital ("VITAL entity port cannot be guarded", Decl); + end if; + end Check_Entity_Port_Declaration; + + -- Current position in the generic name, stored into + -- name_table.name_buffer. + Gen_Name_Pos : Natural; + + -- Length of the generic name. + Gen_Name_Length : Natural; + + -- The generic being analyzed. + Gen_Decl : Iir; + Gen_Chain : Iir; + + procedure Error_Vital_Name (Str : String) + is + Loc : Location_Type; + begin + Loc := Get_Location (Gen_Decl); + Error_Vital (Str, Loc + Location_Type (Gen_Name_Pos - 1)); + end Error_Vital_Name; + + -- Check the next sub-string in the generic name is a port. + -- Returns the port. + function Check_Port return Iir + is + use Sem_Scopes; + use Name_Table; + + C : Character; + Res : Iir; + Id : Name_Id; + Inter : Name_Interpretation_Type; + begin + Name_Length := 0; + while Gen_Name_Pos <= Gen_Name_Length loop + C := Name_Buffer (Gen_Name_Pos); + Gen_Name_Pos := Gen_Name_Pos + 1; + exit when C = '_'; + Name_Length := Name_Length + 1; + Name_Buffer (Name_Length) := C; + end loop; + + if Name_Length = 0 then + Error_Vital_Name ("port expected in VITAL generic name"); + return Null_Iir; + end if; + + Id := Get_Identifier_No_Create; + Res := Null_Iir; + if Id /= Null_Identifier then + Inter := Get_Interpretation (Id); + if Valid_Interpretation (Inter) then + Res := Get_Declaration (Inter); + end if; + end if; + if Res = Null_Iir then + Warning_Vital ("'" & Name_Buffer (1 .. Name_Length) + & "' is not a port name (in VITAL generic name)", + Gen_Decl); + end if; + return Res; + end Check_Port; + + -- Checks the port is an input port. + function Check_Input_Port return Iir + is + use Name_Table; + + Res : Iir; + begin + Res := Check_Port; + if Res /= Null_Iir then + -- IEEE 1076.4 4.3.2.1.3 + -- an input port is a VHDL port of mode IN or INOUT. + case Get_Mode (Res) is + when Iir_In_Mode + | Iir_Inout_Mode => + null; + when others => + Error_Vital ("'" & Name_Buffer (1 .. Name_Length) + & "' must be an input port", Gen_Decl); + end case; + end if; + return Res; + end Check_Input_Port; + + -- Checks the port is an output port. + function Check_Output_Port return Iir + is + use Name_Table; + + Res : Iir; + begin + Res := Check_Port; + if Res /= Null_Iir then + -- IEEE 1076.4 4.3.2.1.3 + -- An output port is a VHDL port of mode OUT, INOUT or BUFFER. + case Get_Mode (Res) is + when Iir_Out_Mode + | Iir_Inout_Mode + | Iir_Buffer_Mode => + null; + when others => + Error_Vital ("'" & Name_Buffer (1 .. Name_Length) + & "' must be an output port", Gen_Decl); + end case; + end if; + return Res; + end Check_Output_Port; + + -- Extract a suffix from the generic name. + type Suffixes_Kind is + ( + Suffix_Name, -- [a-z]* + Suffix_Num_Name, -- [0-9]* + Suffix_Edge, -- posedge, negedge, 01, 10, 0z, z1, 1z, z0 + Suffix_Noedge, -- noedge + Suffix_Eon -- End of name + ); + + function Get_Next_Suffix_Kind return Suffixes_Kind + is + use Name_Table; + + Len : Natural; + P : constant Natural := Gen_Name_Pos; + C : Character; + begin + Len := 0; + while Gen_Name_Pos <= Gen_Name_Length loop + C := Name_Buffer (Gen_Name_Pos); + Gen_Name_Pos := Gen_Name_Pos + 1; + exit when C = '_'; + Len := Len + 1; + end loop; + if Len = 0 then + return Suffix_Eon; + end if; + + case Name_Buffer (P) is + when '0' => + if Len = 2 and then (Name_Buffer (P + 1) = '1' + or Name_Buffer (P + 1) = 'z') + then + return Suffix_Edge; + else + return Suffix_Num_Name; + end if; + when '1' => + if Len = 2 and then (Name_Buffer (P + 1) = '0' + or Name_Buffer (P + 1) = 'z') + then + return Suffix_Edge; + else + return Suffix_Num_Name; + end if; + when '2' .. '9' => + return Suffix_Num_Name; + when 'z' => + if Len = 2 and then (Name_Buffer (P + 1) = '0' + or Name_Buffer (P + 1) = '1') + then + return Suffix_Edge; + else + return Suffix_Name; + end if; + when 'p' => + if Len = 7 and then Name_Buffer (P .. P + 6) = "posedge" then + return Suffix_Edge; + else + return Suffix_Name; + end if; + when 'n' => + if Len = 7 and then Name_Buffer (P .. P + 6) = "negedge" then + return Suffix_Edge; + elsif Len = 6 and then Name_Buffer (P .. P + 5) = "noedge" then + return Suffix_Edge; + else + return Suffix_Name; + end if; + when 'a' .. 'm' + | 'o' + | 'q' .. 'y' => + return Suffix_Name; + when others => + raise Internal_Error; + end case; + end Get_Next_Suffix_Kind; + + -- <SDFSimpleConditionAndOrEdge> ::= + -- <ConditionName> + -- | <Edge> + -- | <ConditionName>_<Edge> + procedure Check_Simple_Condition_And_Or_Edge + is + First : Boolean := True; + begin + loop + case Get_Next_Suffix_Kind is + when Suffix_Eon => + -- Simple condition is optional. + return; + when Suffix_Edge => + if Get_Next_Suffix_Kind /= Suffix_Eon then + Error_Vital_Name ("garbage after edge"); + end if; + return; + when Suffix_Num_Name => + if First then + Error_Vital_Name ("condition is a simple name"); + end if; + when Suffix_Noedge => + Error_Vital_Name ("'noedge' not allowed in simple condition"); + when Suffix_Name => + null; + end case; + First := False; + end loop; + end Check_Simple_Condition_And_Or_Edge; + + -- <SDFFullConditionAndOrEdge> ::= + -- <ConditionNameEdge>[_<SDFSimpleConditionAndOrEdge>] + -- + -- <ConditionNameEdge> ::= + -- [<ConditionName>_]<Edge> + -- | [<ConditionName>_]noedge + procedure Check_Full_Condition_And_Or_Edge + is + begin + case Get_Next_Suffix_Kind is + when Suffix_Eon => + -- FullCondition is always optional. + return; + when Suffix_Edge + | Suffix_Noedge => + Check_Simple_Condition_And_Or_Edge; + return; + when Suffix_Num_Name => + Error_Vital_Name ("condition is a simple name"); + when Suffix_Name => + null; + end case; + + loop + case Get_Next_Suffix_Kind is + when Suffix_Eon => + Error_Vital_Name ("missing edge or noedge"); + return; + when Suffix_Edge + | Suffix_Noedge => + Check_Simple_Condition_And_Or_Edge; + return; + when Suffix_Num_Name + | Suffix_Name => + null; + end case; + end loop; + end Check_Full_Condition_And_Or_Edge; + + procedure Check_End is + begin + if Get_Next_Suffix_Kind /= Suffix_Eon then + Error_Vital_Name ("garbage at end of name"); + end if; + end Check_End; + + -- Return the length of a port P. + -- If P is a scalar port, return PORT_LENGTH_SCALAR + -- If P is a vector, return the length of the vector (>= 0) + -- Otherwise, return PORT_LENGTH_ERROR. + Port_Length_Unknown : constant Iir_Int64 := -1; + Port_Length_Scalar : constant Iir_Int64 := -2; + Port_Length_Error : constant Iir_Int64 := -3; + function Get_Port_Length (P : Iir) return Iir_Int64 + is + Ptype : Iir; + Itype : Iir; + begin + Ptype := Get_Type (P); + if Get_Base_Type (Ptype) = Std_Ulogic_Type then + return Port_Length_Scalar; + elsif Get_Kind (Ptype) = Iir_Kind_Array_Subtype_Definition + and then Get_Base_Type (Ptype) = Std_Logic_Vector_Type + then + Itype := Get_First_Element (Get_Index_Subtype_List (Ptype)); + if Get_Type_Staticness (Itype) /= Locally then + return Port_Length_Unknown; + end if; + return Evaluation.Eval_Discrete_Type_Length (Itype); + else + return Port_Length_Error; + end if; + end Get_Port_Length; + + -- IEEE 1076.4 9.1 VITAL delay types and subtypes. + -- The transition dependent delay types are + -- VitalDelayType01, VitalDelayType01Z, VitalDelayType01ZX, + -- VitalDelayArrayType01, VitalDelayArrayType01Z, VitalDelayArrayType01ZX. + -- The first three are scalar forms, the last three are vector forms. + -- + -- The simple delay types and subtypes include + -- Time, VitalDelayType, and VitalDelayArrayType. + -- The first two are scalar forms, and the latter is the vector form. + type Timing_Generic_Type_Kind is + ( + Timing_Type_Simple_Scalar, + Timing_Type_Simple_Vector, + Timing_Type_Trans_Scalar, + Timing_Type_Trans_Vector, + Timing_Type_Bad + ); + + function Get_Timing_Generic_Type_Kind return Timing_Generic_Type_Kind + is + Gtype : Iir; + Btype : Iir; + begin + Gtype := Get_Type (Gen_Decl); + Btype := Get_Base_Type (Gtype); + case Get_Kind (Gtype) is + when Iir_Kind_Array_Subtype_Definition => + if Btype = VitalDelayArrayType then + return Timing_Type_Simple_Vector; + end if; + if Btype = VitalDelayType01 + or Btype = VitalDelayType01Z + or Btype = VitalDelayType01ZX + then + return Timing_Type_Trans_Scalar; + end if; + if Btype = VitalDelayArrayType01 + or Btype = VitalDelayArrayType01Z + or Btype = VitalDelayArrayType01ZX + then + return Timing_Type_Trans_Vector; + end if; + when Iir_Kind_Physical_Subtype_Definition => + if Gtype = Time_Subtype_Definition + or else Gtype = VitalDelayType + then + return Timing_Type_Simple_Scalar; + end if; + when others => + null; + end case; + Error_Vital ("type of timing generic is not a VITAL delay type", + Gen_Decl); + return Timing_Type_Bad; + end Get_Timing_Generic_Type_Kind; + + function Get_Timing_Generic_Type_Length return Iir_Int64 + is + Itype : Iir; + begin + Itype := Get_First_Element + (Get_Index_Subtype_List (Get_Type (Gen_Decl))); + if Get_Type_Staticness (Itype) /= Locally then + return Port_Length_Unknown; + else + return Evaluation.Eval_Discrete_Type_Length (Itype); + end if; + end Get_Timing_Generic_Type_Length; + + -- IEEE 1076.4 4.3.2.1.2 Timing generic subtypes + -- * If the timing generic is associated with a single port and that port + -- is a scalar, then the type of the timing generic shall be a scalar + -- form of delay type. + -- * If such a timing generic is associated with a single port and that + -- port is a vector, then the type of the timing generic shall be a + -- vector form of delay type, and the constraint on the generic shall + -- match that on the associated port. + procedure Check_Vital_Delay_Type (P : Iir; + Is_Simple : Boolean := False; + Is_Scalar : Boolean := False) + is + Kind : Timing_Generic_Type_Kind; + Len : Iir_Int64; + Len1 : Iir_Int64; + begin + Kind := Get_Timing_Generic_Type_Kind; + if P = Null_Iir or Kind = Timing_Type_Bad then + return; + end if; + Len := Get_Port_Length (P); + if Len = Port_Length_Scalar then + case Kind is + when Timing_Type_Simple_Scalar => + null; + when Timing_Type_Trans_Scalar => + if Is_Simple then + Error_Vital + ("VITAL simple scalar timing type expected", Gen_Decl); + return; + end if; + when others => + Error_Vital ("VITAL scalar timing type expected", Gen_Decl); + return; + end case; + elsif Len >= Port_Length_Unknown then + if Is_Scalar then + Error_Vital ("VITAL scalar timing type expected", Gen_Decl); + return; + end if; + + case Kind is + when Timing_Type_Simple_Vector => + null; + when Timing_Type_Trans_Vector => + if Is_Simple then + Error_Vital + ("VITAL simple vector timing type expected", Gen_Decl); + return; + end if; + when others => + Error_Vital ("VITAL vector timing type expected", Gen_Decl); + return; + end case; + Len1 := Get_Timing_Generic_Type_Length; + if Len1 /= Len then + Error_Vital ("length of port and VITAL vector timing subtype " + & "does not match", Gen_Decl); + end if; + end if; + end Check_Vital_Delay_Type; + + -- IEEE 1076.4 4.3.2.1.2 Timing generic subtypes + -- * If the timing generic is associated with two scalar ports, then the + -- type of the timing generic shall be a scalar form of delay type. + -- * If the timing generic is associated with two ports, one or more of + -- which is a vector, then the type of the timing generic shall be a + -- vector form of delay type, and the length of the index range of the + -- generic shall be equal to the product of the number of scalar + -- subelements in the first port and the number of scalar subelements + -- in the second port. + procedure Check_Vital_Delay_Type + (P1, P2 : Iir; + Is_Simple : Boolean := False; + Is_Scalar : Boolean := False) + is + Kind : Timing_Generic_Type_Kind; + Len1 : Iir_Int64; + Len2 : Iir_Int64; + Lenp : Iir_Int64; + begin + Kind := Get_Timing_Generic_Type_Kind; + if P1 = Null_Iir or P2 = Null_Iir or Kind = Timing_Type_Bad then + return; + end if; + Len1 := Get_Port_Length (P1); + Len2 := Get_Port_Length (P2); + if Len1 = Port_Length_Scalar and Len2 = Port_Length_Scalar then + case Kind is + when Timing_Type_Simple_Scalar => + null; + when Timing_Type_Trans_Scalar => + if Is_Simple then + Error_Vital + ("VITAL simple scalar timing type expected", Gen_Decl); + return; + end if; + when others => + Error_Vital ("VITAL scalar timing type expected", Gen_Decl); + return; + end case; + elsif Len1 >= Port_Length_Unknown or Len2 >= Port_Length_Unknown then + if Is_Scalar then + Error_Vital ("VITAL scalar timing type expected", Gen_Decl); + return; + end if; + case Kind is + when Timing_Type_Simple_Vector => + null; + when Timing_Type_Trans_Vector => + if Is_Simple then + Error_Vital + ("VITAL simple vector timing type expected", Gen_Decl); + return; + end if; + when others => + Error_Vital ("VITAL vector timing type expected", Gen_Decl); + return; + end case; + if Len1 = Port_Length_Scalar then + Len1 := 1; + elsif Len1 = Port_Length_Error then + return; + end if; + if Len2 = Port_Length_Scalar then + Len2 := 1; + elsif Len2 = Port_Length_Error then + return; + end if; + Lenp := Get_Timing_Generic_Type_Length; + if Lenp /= Len1 * Len2 then + Error_Vital ("length of port and VITAL vector timing subtype " + & "does not match", Gen_Decl); + end if; + end if; + end Check_Vital_Delay_Type; + + function Check_Timing_Generic_Prefix + (Decl : Iir_Interface_Constant_Declaration; Length : Natural) + return Boolean + is + use Name_Table; + begin + -- IEEE 1076.4 4.3.1 + -- It is an error for a model to use a timing generic prefix to begin + -- the simple name of an entity generic that is not a timing generic. + if Name_Length < Length or Name_Buffer (Length) /= '_' then + Error_Vital ("invalid use of a VITAL timing generic prefix", Decl); + return False; + end if; + Gen_Name_Pos := Length + 1; + Gen_Name_Length := Name_Length; + Gen_Decl := Decl; + return True; + end Check_Timing_Generic_Prefix; + + -- IEEE 1076.4 4.3.2.1.3.1 Propagation Delay + -- <VITALPropagationDelayName> ::= + -- TPD_<InputPort>_<OutputPort>[_<SDFSimpleConditionAndOrEdge>] + procedure Check_Propagation_Delay_Name + (Decl : Iir_Interface_Constant_Declaration) + is + Iport : Iir; + Oport : Iir; + begin + if not Check_Timing_Generic_Prefix (Decl, 4) then + return; + end if; + Iport := Check_Input_Port; + Oport := Check_Output_Port; + Check_Simple_Condition_And_Or_Edge; + Check_Vital_Delay_Type (Iport, Oport); + end Check_Propagation_Delay_Name; + + procedure Check_Test_Reference + is + Tport : Iir; + Rport : Iir; + begin + Tport := Check_Input_Port; + Rport := Check_Input_Port; + Check_Full_Condition_And_Or_Edge; + Check_Vital_Delay_Type (Tport, Rport, Is_Simple => True); + end Check_Test_Reference; + + -- tsetup + procedure Check_Input_Setup_Time_Name + (Decl : Iir_Interface_Constant_Declaration) + is + begin + if not Check_Timing_Generic_Prefix (Decl, 7) then + return; + end if; + Check_Test_Reference; + end Check_Input_Setup_Time_Name; + + -- thold + procedure Check_Input_Hold_Time_Name + (Decl : Iir_Interface_Constant_Declaration) + is + begin + if not Check_Timing_Generic_Prefix (Decl, 6) then + return; + end if; + Check_Test_Reference; + end Check_Input_Hold_Time_Name; + + -- trecovery + procedure Check_Input_Recovery_Time_Name + (Decl : Iir_Interface_Constant_Declaration) + is + begin + if not Check_Timing_Generic_Prefix (Decl, 10) then + return; + end if; + Check_Test_Reference; + end Check_Input_Recovery_Time_Name; + + -- tremoval + procedure Check_Input_Removal_Time_Name + (Decl : Iir_Interface_Constant_Declaration) + is + begin + if not Check_Timing_Generic_Prefix (Decl, 9) then + return; + end if; + Check_Test_Reference; + end Check_Input_Removal_Time_Name; + + -- tperiod + procedure Check_Input_Period_Name + (Decl : Iir_Interface_Constant_Declaration) + is + Iport : Iir; + begin + if not Check_Timing_Generic_Prefix (Decl, 8) then + return; + end if; + Iport := Check_Input_Port; + Check_Simple_Condition_And_Or_Edge; + Check_Vital_Delay_Type (Iport, Is_Simple => True); + end Check_Input_Period_Name; + + -- tpw + procedure Check_Pulse_Width_Name + (Decl : Iir_Interface_Constant_Declaration) + is + Iport : Iir; + begin + if not Check_Timing_Generic_Prefix (Decl, 4) then + return; + end if; + Iport := Check_Input_Port; + Check_Simple_Condition_And_Or_Edge; + Check_Vital_Delay_Type (Iport, Is_Simple => True); + end Check_Pulse_Width_Name; + + -- tskew + procedure Check_Input_Skew_Time_Name + (Decl : Iir_Interface_Constant_Declaration) + is + Fport : Iir; + Sport : Iir; + begin + if not Check_Timing_Generic_Prefix (Decl, 6) then + return; + end if; + Fport := Check_Port; + Sport := Check_Port; + Check_Full_Condition_And_Or_Edge; + Check_Vital_Delay_Type (Fport, Sport, Is_Simple => True); + end Check_Input_Skew_Time_Name; + + -- tncsetup + procedure Check_No_Change_Setup_Time_Name + (Decl : Iir_Interface_Constant_Declaration) + is + begin + if not Check_Timing_Generic_Prefix (Decl, 9) then + return; + end if; + Check_Test_Reference; + end Check_No_Change_Setup_Time_Name; + + -- tnchold + procedure Check_No_Change_Hold_Time_Name + (Decl : Iir_Interface_Constant_Declaration) + is + begin + if not Check_Timing_Generic_Prefix (Decl, 8) then + return; + end if; + Check_Test_Reference; + end Check_No_Change_Hold_Time_Name; + + -- tipd + procedure Check_Interconnect_Path_Delay_Name + (Decl : Iir_Interface_Constant_Declaration) + is + Iport : Iir; + begin + if not Check_Timing_Generic_Prefix (Decl, 5) then + return; + end if; + Iport := Check_Input_Port; + Check_End; + Check_Vital_Delay_Type (Iport); + end Check_Interconnect_Path_Delay_Name; + + -- tdevice + procedure Check_Device_Delay_Name + (Decl : Iir_Interface_Constant_Declaration) + is + Oport : Iir; + pragma Unreferenced (Oport); + Pos : Natural; + Kind : Timing_Generic_Type_Kind; + pragma Unreferenced (Kind); + begin + if not Check_Timing_Generic_Prefix (Decl, 8) then + return; + end if; + if Get_Next_Suffix_Kind /= Suffix_Name then + Error_Vital_Name ("instance_name expected in VITAL generic name"); + return; + end if; + Pos := Gen_Name_Pos; + if Get_Next_Suffix_Kind /= Suffix_Eon then + Gen_Name_Pos := Pos; + Oport := Check_Output_Port; + Check_End; + end if; + Kind := Get_Timing_Generic_Type_Kind; + end Check_Device_Delay_Name; + + -- tisd + procedure Check_Internal_Signal_Delay_Name + (Decl : Iir_Interface_Constant_Declaration) + is + Iport : Iir; + Cport : Iir; + begin + if not Check_Timing_Generic_Prefix (Decl, 5) then + return; + end if; + Iport := Check_Input_Port; + Cport := Check_Input_Port; + Check_End; + Check_Vital_Delay_Type (Iport, Cport, + Is_Simple => True, Is_Scalar => True); + end Check_Internal_Signal_Delay_Name; + + -- tbpd + procedure Check_Biased_Propagation_Delay_Name + (Decl : Iir_Interface_Constant_Declaration) + is + Iport : Iir; + Oport : Iir; + Cport : Iir; + pragma Unreferenced (Cport); + Clock_Start : Natural; + Clock_End : Natural; + begin + if not Check_Timing_Generic_Prefix (Decl, 5) then + return; + end if; + Iport := Check_Input_Port; + Oport := Check_Output_Port; + Clock_Start := Gen_Name_Pos - 1; -- At the '_'. + Cport := Check_Input_Port; + Clock_End := Gen_Name_Pos; + Check_Simple_Condition_And_Or_Edge; + Check_Vital_Delay_Type (Iport, Oport); + + -- IEEE 1076.4 4.3.2.1.3.14 Biased propagation delay + -- There shall exist, in the same entity generic clause, a corresponding + -- propagation delay generic denoting the same ports, condition name, + -- and edge. + declare + use Name_Table; + + -- '-1' is for the missing 'b' in 'tpd'. + Tpd_Name : String + (1 .. Gen_Name_Length - 1 - (Clock_End - Clock_Start)); + Tpd_Decl : Iir; + begin + Image (Get_Identifier (Decl)); + Tpd_Name (1) := 't'; + -- The part before '_<ClockPort>'. + Tpd_Name (2 .. Clock_Start - 2) := Name_Buffer (3 .. Clock_Start - 1); + Tpd_Name (Clock_Start - 1 .. Tpd_Name'Last) := + Name_Buffer (Clock_End .. Name_Length); + + Tpd_Decl := Gen_Chain; + loop + exit when Tpd_Decl = Null_Iir; + Image (Get_Identifier (Tpd_Decl)); + exit when Name_Length = Tpd_Name'Length + and then Name_Buffer (1 .. Name_Length) = Tpd_Name; + Tpd_Decl := Get_Chain (Tpd_Decl); + end loop; + + if Tpd_Decl = Null_Iir then + Error_Vital + ("no matching 'tpd' generic for VITAL 'tbpd' timing generic", + Decl); + else + -- IEEE 1076.4 4.3.2.1.3.14 Biased propagation delay + -- Furthermore, the type of the biased propagation generic shall + -- be the same as the type of the corresponding delay generic. + if not Sem.Are_Trees_Equal (Get_Type (Decl), Get_Type (Tpd_Decl)) + then + Error_Vital + ("type of VITAL 'tbpd' generic mismatch type of " + & "'tpd' generic", Decl); + Error_Vital + ("(corresponding 'tpd' timing generic)", Tpd_Decl); + end if; + end if; + end; + end Check_Biased_Propagation_Delay_Name; + + -- ticd + procedure Check_Internal_Clock_Delay_Generic_Name + (Decl : Iir_Interface_Constant_Declaration) + is + Cport : Iir; + P_Start : Natural; + P_End : Natural; + begin + if not Check_Timing_Generic_Prefix (Decl, 5) then + return; + end if; + P_Start := Gen_Name_Pos; + Cport := Check_Input_Port; + P_End := Gen_Name_Pos; + Check_End; + Check_Vital_Delay_Type (Cport, Is_Simple => True, Is_Scalar => True); + + -- IEEE 1076.4 4.3.2.1.3.15 Internal clock delay + -- It is an error for a clocks signal name to appear as one of the + -- following elements in the name of a timing generic: + -- * As either the input port in the name of a biased propagation + -- delay generic. + -- * As the input signal name in an internal delay timing generic. + -- * As the test port in a timing check or recovery removal timing + -- generic. + -- FIXME: recovery OR removal ? + + if P_End - 1 /= Gen_Name_Length then + -- Do not check in case of error. + return; + end if; + declare + use Name_Table; + Port : String (1 .. Name_Length); + El : Iir; + Offset : Natural; + + procedure Check_Not_Clock + is + S : Natural; + begin + S := Offset; + loop + Offset := Offset + 1; + exit when Offset > Name_Length + or else Name_Buffer (Offset) = '_'; + end loop; + if Offset - S = Port'Length + and then Name_Buffer (S .. Offset - 1) = Port + then + Error_Vital ("clock port name of 'ticd' VITAL generic must not" + & " appear here", El); + end if; + end Check_Not_Clock; + begin + Port := Name_Buffer (P_Start .. Gen_Name_Length); + + El := Gen_Chain; + while El /= Null_Iir loop + Image (Get_Identifier (El)); + if Name_Length > 5 + and then Name_Buffer (1) = 't' + then + if Name_Buffer (2 .. 5) = "bpd_" then + Offset := 6; + Check_Not_Clock; -- input + Check_Not_Clock; -- output + elsif Name_Buffer (2 .. 5) = "isd_" then + Offset := 6; + Check_Not_Clock; -- input + elsif Name_Length > 10 + and then Name_Buffer (2 .. 10) = "recovery_" + then + Offset := 11; + Check_Not_Clock; -- test port + elsif Name_Length > 9 + and then Name_Buffer (2 .. 9) = "removal_" + then + Offset := 10; + Check_Not_Clock; + end if; + end if; + El := Get_Chain (El); + end loop; + end; + end Check_Internal_Clock_Delay_Generic_Name; + + procedure Check_Entity_Generic_Declaration + (Decl : Iir_Interface_Constant_Declaration) + is + use Name_Table; + Id : Name_Id; + begin + Id := Get_Identifier (Decl); + Image (Id); + + -- Extract prefix. + if Name_Buffer (1) = 't' and Name_Length >= 3 then + -- Timing generic names. + if Name_Buffer (2) = 'p' then + if Name_Buffer (3) = 'd' then + Check_Propagation_Delay_Name (Decl); -- tpd + return; + elsif Name_Buffer (3) = 'w' then + Check_Pulse_Width_Name (Decl); -- tpw + return; + elsif Name_Length >= 7 + and then Name_Buffer (3 .. 7) = "eriod" + then + Check_Input_Period_Name (Decl); -- tperiod + return; + end if; + elsif Name_Buffer (2) = 'i' + and then Name_Length >= 4 + and then Name_Buffer (4) = 'd' + then + if Name_Buffer (3) = 'p' then + Check_Interconnect_Path_Delay_Name (Decl); -- tipd + return; + elsif Name_Buffer (3) = 's' then + Check_Internal_Signal_Delay_Name (Decl); -- tisd + return; + elsif Name_Buffer (3) = 'c' then + Check_Internal_Clock_Delay_Generic_Name (Decl); -- ticd + return; + end if; + elsif Name_Length >= 6 and then Name_Buffer (2 .. 6) = "setup" then + Check_Input_Setup_Time_Name (Decl); -- tsetup + return; + elsif Name_Length >= 5 and then Name_Buffer (2 .. 5) = "hold" then + Check_Input_Hold_Time_Name (Decl); -- thold + return; + elsif Name_Length >= 9 and then Name_Buffer (2 .. 9) = "recovery" then + Check_Input_Recovery_Time_Name (Decl); -- trecovery + return; + elsif Name_Length >= 8 and then Name_Buffer (2 .. 8) = "removal" then + Check_Input_Removal_Time_Name (Decl); -- tremoval + return; + elsif Name_Length >= 5 and then Name_Buffer (2 .. 5) = "skew" then + Check_Input_Skew_Time_Name (Decl); -- tskew + return; + elsif Name_Length >= 8 and then Name_Buffer (2 .. 8) = "ncsetup" then + Check_No_Change_Setup_Time_Name (Decl); -- tncsetup + return; + elsif Name_Length >= 7 and then Name_Buffer (2 .. 7) = "nchold" then + Check_No_Change_Hold_Time_Name (Decl); -- tnchold + return; + elsif Name_Length >= 7 and then Name_Buffer (2 .. 7) = "device" then + Check_Device_Delay_Name (Decl); -- tdevice + return; + elsif Name_Length >= 4 and then Name_Buffer (2 .. 4) = "bpd" then + Check_Biased_Propagation_Delay_Name (Decl); -- tbpd + return; + end if; + end if; + + if Id = InstancePath_Id then + if Get_Type (Decl) /= String_Type_Definition then + Error_Vital + ("InstancePath VITAL generic must be of type String", Decl); + end if; + return; + elsif Id = TimingChecksOn_Id + or Id = XOn_Id + or Id = MsgOn_Id + then + if Get_Type (Decl) /= Boolean_Type_Definition then + Error_Vital + (Image (Id) & " VITAL generic must be of type Boolean", Decl); + end if; + return; + end if; + + if Flags.Warn_Vital_Generic then + Warning_Vital (Disp_Node (Decl) & " is not a VITAL generic", Decl); + end if; + end Check_Entity_Generic_Declaration; + + -- Checks rules for a VITAL level 0 entity. + procedure Check_Vital_Level0_Entity (Ent : Iir_Entity_Declaration) + is + use Sem_Scopes; + Decl : Iir; + begin + -- IEEE 1076.4 4.3.1 + -- The only form of declaration allowed in the entity declarative part + -- is the specification of the VITAL_Level0 attribute. + Decl := Get_Declaration_Chain (Ent); + if Decl = Null_Iir then + -- Cannot happen, since there is at least the attribute spec. + raise Internal_Error; + end if; + Check_Level0_Attribute_Specification (Decl); + Decl := Get_Chain (Decl); + if Decl /= Null_Iir then + Error_Vital ("VITAL entity declarative part must only contain the " + & "attribute specification", Decl); + end if; + + -- IEEE 1076.4 4.3.1 + -- No statements are allowed in the entity statement part. + Decl := Get_Concurrent_Statement_Chain (Ent); + if Decl /= Null_Iir then + Error_Vital ("VITAL entity must not have concurrent statement", Decl); + end if; + + -- Check ports. + Name_Table.Assert_No_Infos; + Open_Declarative_Region; + Decl := Get_Port_Chain (Ent); + while Decl /= Null_Iir loop + Check_Entity_Port_Declaration (Decl); + Add_Name (Decl); + Decl := Get_Chain (Decl); + end loop; + + -- Check generics. + Gen_Chain := Get_Generic_Chain (Ent); + Decl := Gen_Chain; + while Decl /= Null_Iir loop + Check_Entity_Generic_Declaration (Decl); + Decl := Get_Chain (Decl); + end loop; + Close_Declarative_Region; + end Check_Vital_Level0_Entity; + + -- Return TRUE if UNIT was decorated with attribute VITAL_Level0. + function Is_Vital_Level0 (Unit : Iir_Entity_Declaration) return Boolean + is + Value : Iir_Attribute_Value; + Spec : Iir_Attribute_Specification; + begin + Value := Get_Attribute_Value_Chain (Unit); + while Value /= Null_Iir loop + Spec := Get_Attribute_Specification (Value); + if Get_Named_Entity (Get_Attribute_Designator (Spec)) + = Vital_Level0_Attribute + then + return True; + end if; + Value := Get_Chain (Value); + end loop; + + return False; + end Is_Vital_Level0; + + procedure Check_Vital_Level0_Architecture (Arch : Iir_Architecture_Body) + is + Decl : Iir; + begin + -- IEEE 1076.4 4.1 + -- The entity associated with a Level 0 architecture shall be a VITAL + -- Level 0 entity. + if not Is_Vital_Level0 (Iirs_Utils.Get_Entity (Arch)) then + Error_Vital ("entity associated with a VITAL level 0 architecture " + & "shall be a VITAL level 0 entity", Arch); + end if; + + -- VITAL_Level_0_architecture_declarative_part ::= + -- VITAL_Level0_attribute_specification { block_declarative_item } + Decl := Get_Declaration_Chain (Arch); + Check_Level0_Attribute_Specification (Decl); + end Check_Vital_Level0_Architecture; + + -- Check a VITAL level 0 decorated design unit. + procedure Check_Vital_Level0 (Unit : Iir_Design_Unit) + is + Lib_Unit : Iir; + begin + Lib_Unit := Get_Library_Unit (Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Entity_Declaration => + Check_Vital_Level0_Entity (Lib_Unit); + when Iir_Kind_Architecture_Body => + Check_Vital_Level0_Architecture (Lib_Unit); + when others => + Error_Vital + ("only entity or architecture can be VITAL_Level0", Lib_Unit); + end case; + end Check_Vital_Level0; + + procedure Check_Vital_Level1 (Unit : Iir_Design_Unit) + is + Arch : Iir; + begin + Arch := Get_Library_Unit (Unit); + if Get_Kind (Arch) /= Iir_Kind_Architecture_Body then + Error_Vital ("only architecture can be VITAL_Level1", Arch); + return; + end if; + -- FIXME: todo + end Check_Vital_Level1; + +end Ieee.Vital_Timing; diff --git a/src/vhdl/ieee-vital_timing.ads b/src/vhdl/ieee-vital_timing.ads new file mode 100644 index 000000000..7abda2eba --- /dev/null +++ b/src/vhdl/ieee-vital_timing.ads @@ -0,0 +1,41 @@ +-- Nodes recognizer for ieee.vital_timing. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +package Ieee.Vital_Timing is + -- Attribute declarations. + Vital_Level0_Attribute : Iir_Attribute_Declaration := Null_Iir; + Vital_Level1_Attribute : Iir_Attribute_Declaration := Null_Iir; + + -- Vital delay types. + VitalDelayType : Iir := Null_Iir; + VitalDelayType01 : Iir_Array_Type_Definition := Null_Iir; + VitalDelayType01Z : Iir_Array_Type_Definition := Null_Iir; + VitalDelayType01ZX : Iir_Array_Type_Definition := Null_Iir; + + VitalDelayArrayType : Iir_Array_Type_Definition := Null_Iir; + VitalDelayArrayType01 : Iir_Array_Type_Definition := Null_Iir; + VitalDelayArrayType01Z : Iir_Array_Type_Definition := Null_Iir; + VitalDelayArrayType01ZX : Iir_Array_Type_Definition := Null_Iir; + + -- Extract declarations from IEEE.VITAL_Timing package. + procedure Extract_Declarations (Pkg : Iir_Package_Declaration); + + procedure Check_Vital_Level0 (Unit : Iir_Design_Unit); + procedure Check_Vital_Level1 (Unit : Iir_Design_Unit); +end Ieee.Vital_Timing; diff --git a/src/vhdl/ieee.ads b/src/vhdl/ieee.ads new file mode 100644 index 000000000..48ab37630 --- /dev/null +++ b/src/vhdl/ieee.ads @@ -0,0 +1,5 @@ +-- Top of ieee hierarchy. +-- Too small to be copyrighted. +package Ieee is + pragma Pure (Ieee); +end Ieee; diff --git a/src/vhdl/iir_chain_handling.adb b/src/vhdl/iir_chain_handling.adb new file mode 100644 index 000000000..1e70a366a --- /dev/null +++ b/src/vhdl/iir_chain_handling.adb @@ -0,0 +1,68 @@ +-- Generic package to handle chains. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package body Iir_Chain_Handling is + procedure Build_Init (Last : out Iir) is + begin + Last := Null_Iir; + end Build_Init; + + procedure Build_Init (Last : out Iir; Parent : Iir) + is + El : Iir; + begin + El := Get_Chain_Start (Parent); + if El /= Null_Iir then + loop + Last := El; + El := Get_Chain (El); + exit when El = Null_Iir; + end loop; + else + Last := Null_Iir; + end if; + end Build_Init; + + procedure Append (Last : in out Iir; Parent : Iir; El : Iir) is + begin + if Last = Null_Iir then + Set_Chain_Start (Parent, El); + else + Set_Chain (Last, El); + end if; + Last := El; + end Append; + + procedure Append_Subchain (Last : in out Iir; Parent : Iir; Els : Iir) + is + El : Iir; + begin + if Last = Null_Iir then + Set_Chain_Start (Parent, Els); + else + Set_Chain (Last, Els); + end if; + El := Els; + loop + Set_Parent (El, Parent); + Last := El; + El := Get_Chain (El); + exit when El = Null_Iir; + end loop; + end Append_Subchain; +end Iir_Chain_Handling; + diff --git a/src/vhdl/iir_chain_handling.ads b/src/vhdl/iir_chain_handling.ads new file mode 100644 index 000000000..3865e9b65 --- /dev/null +++ b/src/vhdl/iir_chain_handling.ads @@ -0,0 +1,47 @@ +-- Generic package to handle chains. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +-- The generic package Chain_Handling can be used to build or modify +-- chains. +-- The formals are the subprograms to get and set the first element +-- from the parent. +generic + with function Get_Chain_Start (Parent : Iir) return Iir; + with procedure Set_Chain_Start (Parent : Iir; First : Iir); +package Iir_Chain_Handling is + + -- Building a chain: + -- Initialize (set LAST to NULL_IIR). + procedure Build_Init (Last : out Iir); + -- Set LAST with the last element of the chain. + -- This is an initialization for an already built chain. + procedure Build_Init (Last : out Iir; Parent : Iir); + + -- Append element EL to the chain, whose parent is PARENT and last + -- element LAST. + procedure Append (Last : in out Iir; Parent : Iir; El : Iir); + + -- Append a subchain whose first element is ELS to a chain, whose + -- parent is PARENT and last element LAST. + -- The Parent field of each elements of Els is set to PARENT. + -- Note: the Append procedure declared just above is an optimization + -- of this subprogram if ELS has no next element. However, the + -- above subprogram does not set the Parent field of EL. + procedure Append_Subchain (Last : in out Iir; Parent : Iir; Els : Iir); +end Iir_Chain_Handling; diff --git a/src/vhdl/iir_chains.adb b/src/vhdl/iir_chains.adb new file mode 100644 index 000000000..ef47b6485 --- /dev/null +++ b/src/vhdl/iir_chains.adb @@ -0,0 +1,64 @@ +-- Chain handling. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package body Iir_Chains is + function Get_Chain_Length (First : Iir) return Natural + is + Res : Natural := 0; + El : Iir := First; + begin + while El /= Null_Iir loop + Res := Res + 1; + El := Get_Chain (El); + end loop; + return Res; + end Get_Chain_Length; + + procedure Sub_Chain_Init (First, Last : out Iir) is + begin + First := Null_Iir; + Last := Null_Iir; + end Sub_Chain_Init; + + procedure Sub_Chain_Append (First, Last : in out Iir; El : Iir) is + begin + if First = Null_Iir then + First := El; + else + Set_Chain (Last, El); + end if; + Last := El; + end Sub_Chain_Append; + + function Is_Chain_Length_One (Chain : Iir) return Boolean is + begin + return Chain /= Null_Iir and then Get_Chain (Chain) = Null_Iir; + end Is_Chain_Length_One; + + procedure Insert (Last : Iir; El : Iir) is + begin + Set_Chain (El, Get_Chain (Last)); + Set_Chain (Last, El); + end Insert; + + procedure Insert_Incr (Last : in out Iir; El : Iir) is + begin + Set_Chain (El, Get_Chain (Last)); + Set_Chain (Last, El); + Last := El; + end Insert_Incr; +end Iir_Chains; diff --git a/src/vhdl/iir_chains.ads b/src/vhdl/iir_chains.ads new file mode 100644 index 000000000..dc2f3894c --- /dev/null +++ b/src/vhdl/iir_chains.ads @@ -0,0 +1,113 @@ +-- Chain handling. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; +with Iir_Chain_Handling; +pragma Elaborate_All (Iir_Chain_Handling); + +package Iir_Chains is + -- Chains are simply linked list of iirs. + -- Elements of the chain are ordered. + -- Each element of a chain have a Chain field, which points to the next + -- element. + -- All elements of a chain have the same parent. This parent contains + -- a field which points to the first element of the chain. + -- Note: the parent is often the value of the Parent field, but sometimes + -- not. + + -- Chains can be covered very simply: + -- El : Iir; + -- begin + -- El := Get_xxx_Chain (Parent); + -- while El /= Null_Iir loop + -- * Handle element EL of the chain. + -- El := Get_Chain (El); + -- end loop; + + -- However, building a chain is a little bit more difficult if elements + -- have to be appended. Indeed, there is no direct access to the last + -- element of a chain. + -- An efficient way to build a chain is to keep the last element of it. + -- See Iir_Chain_Handling package. + + package Declaration_Chain_Handling is new Iir_Chain_Handling + (Get_Chain_Start => Get_Declaration_Chain, + Set_Chain_Start => Set_Declaration_Chain); + + package Interface_Declaration_Chain_Handling is new Iir_Chain_Handling + (Get_Chain_Start => Get_Interface_Declaration_Chain, + Set_Chain_Start => Set_Interface_Declaration_Chain); + + package Context_Items_Chain_Handling is new Iir_Chain_Handling + (Get_Chain_Start => Get_Context_Items, + Set_Chain_Start => Set_Context_Items); + + package Unit_Chain_Handling is new Iir_Chain_Handling + (Get_Chain_Start => Get_Unit_Chain, + Set_Chain_Start => Set_Unit_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); + + package Entity_Class_Entry_Chain_Handling is new Iir_Chain_Handling + (Get_Chain_Start => Get_Entity_Class_Entry_Chain, + Set_Chain_Start => Set_Entity_Class_Entry_Chain); + + package Conditional_Waveform_Chain_Handling is new Iir_Chain_Handling + (Get_Chain_Start => Get_Conditional_Waveform_Chain, + Set_Chain_Start => Set_Conditional_Waveform_Chain); + + package Selected_Waveform_Chain_Handling is new Iir_Chain_Handling + (Get_Chain_Start => Get_Selected_Waveform_Chain, + Set_Chain_Start => Set_Selected_Waveform_Chain); + + package Association_Choices_Chain_Handling is new Iir_Chain_Handling + (Get_Chain_Start => Get_Association_Choices_Chain, + Set_Chain_Start => Set_Association_Choices_Chain); + + package Case_Statement_Alternative_Chain_Handling is new Iir_Chain_Handling + (Get_Chain_Start => Get_Case_Statement_Alternative_Chain, + Set_Chain_Start => Set_Case_Statement_Alternative_Chain); + + -- Return the number of elements in a chain starting with FIRST. + -- Not very efficient since O(N). + function Get_Chain_Length (First : Iir) return Natural; + + -- These two subprograms can be used to build a sub-chain. + -- FIRST and LAST designates respectively the first and last element of + -- the sub-chain. + + -- Set FIRST and LAST to Null_Iir. + procedure Sub_Chain_Init (First, Last : out Iir); + pragma Inline (Sub_Chain_Init); + + -- Append element EL to the sub-chain. + procedure Sub_Chain_Append (First, Last : in out Iir; El : Iir); + pragma Inline (Sub_Chain_Append); + + -- Return TRUE iff CHAIN is of length one, ie CHAIN is not NULL_IIR + -- and chain (CHAIN) is NULL_IIR. + function Is_Chain_Length_One (Chain : Iir) return Boolean; + pragma Inline (Is_Chain_Length_One); + + -- Insert EL after LAST. + procedure Insert (Last : Iir; El : Iir); + + -- Insert EL after LAST and set LAST to EL. + procedure Insert_Incr (Last : in out Iir; El : Iir); +end Iir_Chains; diff --git a/src/vhdl/iirs.adb b/src/vhdl/iirs.adb new file mode 100644 index 000000000..876d1464f --- /dev/null +++ b/src/vhdl/iirs.adb @@ -0,0 +1,4515 @@ +-- Tree node definitions. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Unchecked_Conversion; +with Ada.Text_IO; +with Nodes; use Nodes; +with Lists; use Lists; +with Nodes_Meta; use Nodes_Meta; + +package body Iirs is + function Is_Null (Node : Iir) return Boolean is + begin + return Node = Null_Iir; + end Is_Null; + + function Is_Null_List (Node : Iir_List) return Boolean is + begin + return Node = Null_Iir_List; + end Is_Null_List; + + --------------------------------------------------- + -- General subprograms that operate on every iir -- + --------------------------------------------------- + + function Get_Format (Kind : Iir_Kind) return Format_Type; + + function Create_Iir (Kind : Iir_Kind) return Iir + is + Res : Iir; + Format : Format_Type; + begin + Format := Get_Format (Kind); + Res := Create_Node (Format); + Set_Nkind (Res, Iir_Kind'Pos (Kind)); + return Res; + end Create_Iir; + + -- Statistics. + procedure Disp_Stats + is + use Ada.Text_IO; + type Num_Array is array (Iir_Kind) of Natural; + Num : Num_Array := (others => 0); + type Format_Array is array (Format_Type) of Natural; + Formats : Format_Array := (others => 0); + Kind : Iir_Kind; + I : Iir; + Last_I : Iir; + Format : Format_Type; + begin + I := Error_Node + 1; + Last_I := Get_Last_Node; + while I < Last_I loop + Kind := Get_Kind (I); + Num (Kind) := Num (Kind) + 1; + Format := Get_Format (Kind); + Formats (Format) := Formats (Format) + 1; + case Format is + when Format_Medium => + I := I + 2; + when Format_Short + | Format_Fp + | Format_Int => + I := I + 1; + end case; + end loop; + + Put_Line ("Stats per iir_kind:"); + for J in Iir_Kind loop + if Num (J) /= 0 then + Put_Line (' ' & Iir_Kind'Image (J) & ':' + & Natural'Image (Num (J))); + end if; + end loop; + Put_Line ("Stats per formats:"); + for J in Format_Type loop + Put_Line (' ' & Format_Type'Image (J) & ':' + & Natural'Image (Formats (J))); + end loop; + end Disp_Stats; + + function Iir_Predefined_Shortcut_P (Func : Iir_Predefined_Functions) + return Boolean is + begin + case Func is + when Iir_Predefined_Bit_And + | Iir_Predefined_Bit_Or + | Iir_Predefined_Bit_Nand + | Iir_Predefined_Bit_Nor + | Iir_Predefined_Boolean_And + | Iir_Predefined_Boolean_Or + | Iir_Predefined_Boolean_Nand + | Iir_Predefined_Boolean_Nor => + return True; + when others => + return False; + end case; + end Iir_Predefined_Shortcut_P; + + function Create_Iir_Error return Iir + is + Res : Iir; + begin + Res := Create_Node (Format_Short); + Set_Nkind (Res, Iir_Kind'Pos (Iir_Kind_Error)); + Set_Base_Type (Res, Res); + return Res; + end Create_Iir_Error; + + procedure Location_Copy (Target: Iir; Src: Iir) is + begin + Set_Location (Target, Get_Location (Src)); + end Location_Copy; + + -- Get kind + function Get_Kind (An_Iir: Iir) return Iir_Kind + is + -- Speed up: avoid to check that nkind is in the bounds of Iir_Kind. + pragma Suppress (Range_Check); + begin + return Iir_Kind'Val (Get_Nkind (An_Iir)); + end Get_Kind; + + function Time_Stamp_Id_To_Iir is new Ada.Unchecked_Conversion + (Source => Time_Stamp_Id, Target => Iir); + + function Iir_To_Time_Stamp_Id is new Ada.Unchecked_Conversion + (Source => Iir, Target => Time_Stamp_Id); + + function Iir_To_Iir_List is new Ada.Unchecked_Conversion + (Source => Iir, Target => Iir_List); + function Iir_List_To_Iir is new Ada.Unchecked_Conversion + (Source => Iir_List, Target => Iir); + + function Iir_To_Token_Type (N : Iir) return Token_Type is + begin + return Token_Type'Val (N); + end Iir_To_Token_Type; + + function Token_Type_To_Iir (T : Token_Type) return Iir is + begin + 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_Name_Id (N : Iir) return Name_Id is + begin + return Iir'Pos (N); + end Iir_To_Name_Id; + pragma Inline (Iir_To_Name_Id); + + function Name_Id_To_Iir (V : Name_Id) return Iir is + begin + return Name_Id'Pos (V); + end Name_Id_To_Iir; + + function Iir_To_Iir_Int32 is new Ada.Unchecked_Conversion + (Source => Iir, Target => Iir_Int32); + + function Iir_Int32_To_Iir is new Ada.Unchecked_Conversion + (Source => Iir_Int32, Target => Iir); + + function Iir_To_Source_Ptr (N : Iir) return Source_Ptr is + begin + return Source_Ptr (N); + end Iir_To_Source_Ptr; + + function Source_Ptr_To_Iir (P : Source_Ptr) return Iir is + begin + return Iir (P); + end Source_Ptr_To_Iir; + + function Iir_To_Location_Type (N : Iir) return Location_Type is + begin + return Location_Type (N); + end Iir_To_Location_Type; + + function Location_Type_To_Iir (L : Location_Type) return Iir is + begin + return Iir (L); + end Location_Type_To_Iir; + + function Iir_To_String_Id is new Ada.Unchecked_Conversion + (Source => Iir, Target => String_Id); + function String_Id_To_Iir is new Ada.Unchecked_Conversion + (Source => String_Id, Target => Iir); + + function Iir_To_Int32 is new Ada.Unchecked_Conversion + (Source => Iir, Target => Int32); + function Int32_To_Iir is new Ada.Unchecked_Conversion + (Source => Int32, Target => Iir); + + function Iir_To_PSL_Node is new Ada.Unchecked_Conversion + (Source => Iir, Target => PSL_Node); + + function PSL_Node_To_Iir is new Ada.Unchecked_Conversion + (Source => PSL_Node, Target => Iir); + + function Iir_To_PSL_NFA is new Ada.Unchecked_Conversion + (Source => Iir, Target => PSL_NFA); + + function PSL_NFA_To_Iir is new Ada.Unchecked_Conversion + (Source => PSL_NFA, Target => Iir); + + -- Subprograms + function Get_Format (Kind : Iir_Kind) return Format_Type is + begin + case Kind is + when Iir_Kind_Unused + | Iir_Kind_Error + | Iir_Kind_Library_Clause + | Iir_Kind_Use_Clause + | Iir_Kind_Null_Literal + | Iir_Kind_String_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Overflow_Literal + | Iir_Kind_Waveform_Element + | Iir_Kind_Conditional_Waveform + | Iir_Kind_Association_Element_By_Expression + | Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Open + | Iir_Kind_Association_Element_Package + | Iir_Kind_Choice_By_Others + | Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_None + | Iir_Kind_Choice_By_Name + | Iir_Kind_Entity_Aspect_Entity + | Iir_Kind_Entity_Aspect_Configuration + | Iir_Kind_Entity_Aspect_Open + | Iir_Kind_Block_Configuration + | Iir_Kind_Component_Configuration + | Iir_Kind_Entity_Class + | Iir_Kind_Attribute_Value + | Iir_Kind_Aggregate_Info + | Iir_Kind_Procedure_Call + | Iir_Kind_Record_Element_Constraint + | Iir_Kind_Array_Element_Resolution + | Iir_Kind_Record_Resolution + | Iir_Kind_Record_Element_Resolution + | Iir_Kind_Disconnection_Specification + | Iir_Kind_Configuration_Specification + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Incomplete_Type_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Protected_Type_Declaration + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Access_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Range_Expression + | Iir_Kind_Protected_Type_Body + | Iir_Kind_Overload_List + | Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | 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_Terminal_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Identity_Operator + | Iir_Kind_Negation_Operator + | Iir_Kind_Absolute_Operator + | Iir_Kind_Not_Operator + | Iir_Kind_Condition_Operator + | Iir_Kind_Reduction_And_Operator + | Iir_Kind_Reduction_Or_Operator + | Iir_Kind_Reduction_Nand_Operator + | Iir_Kind_Reduction_Nor_Operator + | Iir_Kind_Reduction_Xor_Operator + | Iir_Kind_Reduction_Xnor_Operator + | Iir_Kind_And_Operator + | Iir_Kind_Or_Operator + | Iir_Kind_Nand_Operator + | Iir_Kind_Nor_Operator + | Iir_Kind_Xor_Operator + | Iir_Kind_Xnor_Operator + | Iir_Kind_Equality_Operator + | Iir_Kind_Inequality_Operator + | Iir_Kind_Less_Than_Operator + | Iir_Kind_Less_Than_Or_Equal_Operator + | Iir_Kind_Greater_Than_Operator + | Iir_Kind_Greater_Than_Or_Equal_Operator + | Iir_Kind_Match_Equality_Operator + | Iir_Kind_Match_Inequality_Operator + | Iir_Kind_Match_Less_Than_Operator + | Iir_Kind_Match_Less_Than_Or_Equal_Operator + | Iir_Kind_Match_Greater_Than_Operator + | Iir_Kind_Match_Greater_Than_Or_Equal_Operator + | Iir_Kind_Sll_Operator + | Iir_Kind_Sla_Operator + | Iir_Kind_Srl_Operator + | Iir_Kind_Sra_Operator + | Iir_Kind_Rol_Operator + | Iir_Kind_Ror_Operator + | Iir_Kind_Addition_Operator + | Iir_Kind_Substraction_Operator + | Iir_Kind_Concatenation_Operator + | Iir_Kind_Multiplication_Operator + | Iir_Kind_Division_Operator + | Iir_Kind_Modulus_Operator + | Iir_Kind_Remainder_Operator + | Iir_Kind_Exponentiation_Operator + | Iir_Kind_Function_Call + | Iir_Kind_Aggregate + | Iir_Kind_Parenthesis_Expression + | Iir_Kind_Qualified_Expression + | Iir_Kind_Type_Conversion + | Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Psl_Expression + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Null_Statement + | Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_Case_Statement + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_Character_Literal + | Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Operator_Symbol + | Iir_Kind_Selected_By_All_Name + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Base_Attribute + | Iir_Kind_Left_Type_Attribute + | Iir_Kind_Right_Type_Attribute + | Iir_Kind_High_Type_Attribute + | Iir_Kind_Low_Type_Attribute + | Iir_Kind_Ascending_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute + | Iir_Kind_Pos_Attribute + | Iir_Kind_Val_Attribute + | Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute + | Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Event_Attribute + | Iir_Kind_Active_Attribute + | Iir_Kind_Last_Event_Attribute + | Iir_Kind_Last_Active_Attribute + | Iir_Kind_Last_Value_Attribute + | Iir_Kind_Driving_Attribute + | Iir_Kind_Driving_Value_Attribute + | Iir_Kind_Behavior_Attribute + | Iir_Kind_Structure_Attribute + | Iir_Kind_Simple_Name_Attribute + | Iir_Kind_Instance_Name_Attribute + | Iir_Kind_Path_Name_Attribute + | Iir_Kind_Left_Array_Attribute + | Iir_Kind_Right_Array_Attribute + | Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute + | Iir_Kind_Length_Array_Attribute + | Iir_Kind_Ascending_Array_Attribute + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Attribute_Name => + return Format_Short; + when Iir_Kind_Design_File + | Iir_Kind_Design_Unit + | Iir_Kind_Bit_String_Literal + | Iir_Kind_Block_Header + | Iir_Kind_Binding_Indication + | Iir_Kind_Signature + | Iir_Kind_Attribute_Specification + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Subtype_Definition + | Iir_Kind_Scalar_Nature_Definition + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Package_Header + | Iir_Kind_Unit_Declaration + | Iir_Kind_Library_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Psl_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_File_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement + | Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement + | Iir_Kind_Wait_Statement + | Iir_Kind_If_Statement + | Iir_Kind_Elsif => + return Format_Medium; + when Iir_Kind_Floating_Point_Literal + | Iir_Kind_Physical_Fp_Literal => + return Format_Fp; + when Iir_Kind_Integer_Literal + | Iir_Kind_Physical_Int_Literal => + return Format_Int; + end case; + end Get_Format; + + function Get_First_Design_Unit (Design : Iir) return Iir is + begin + pragma Assert (Design /= Null_Iir); + pragma Assert (Has_First_Design_Unit (Get_Kind (Design))); + return Get_Field5 (Design); + end Get_First_Design_Unit; + + procedure Set_First_Design_Unit (Design : Iir; Chain : Iir) is + begin + pragma Assert (Design /= Null_Iir); + pragma Assert (Has_First_Design_Unit (Get_Kind (Design))); + Set_Field5 (Design, Chain); + end Set_First_Design_Unit; + + function Get_Last_Design_Unit (Design : Iir) return Iir is + begin + pragma Assert (Design /= Null_Iir); + pragma Assert (Has_Last_Design_Unit (Get_Kind (Design))); + return Get_Field6 (Design); + end Get_Last_Design_Unit; + + procedure Set_Last_Design_Unit (Design : Iir; Chain : Iir) is + begin + pragma Assert (Design /= Null_Iir); + pragma Assert (Has_Last_Design_Unit (Get_Kind (Design))); + Set_Field6 (Design, Chain); + end Set_Last_Design_Unit; + + function Get_Library_Declaration (Design : Iir) return Iir is + begin + pragma Assert (Design /= Null_Iir); + pragma Assert (Has_Library_Declaration (Get_Kind (Design))); + return Get_Field1 (Design); + end Get_Library_Declaration; + + procedure Set_Library_Declaration (Design : Iir; Library : Iir) is + begin + pragma Assert (Design /= Null_Iir); + pragma Assert (Has_Library_Declaration (Get_Kind (Design))); + Set_Field1 (Design, Library); + end Set_Library_Declaration; + + function Get_File_Time_Stamp (Design : Iir) return Time_Stamp_Id is + begin + pragma Assert (Design /= Null_Iir); + pragma Assert (Has_File_Time_Stamp (Get_Kind (Design))); + return Iir_To_Time_Stamp_Id (Get_Field4 (Design)); + end Get_File_Time_Stamp; + + procedure Set_File_Time_Stamp (Design : Iir; Stamp : Time_Stamp_Id) is + begin + pragma Assert (Design /= Null_Iir); + pragma Assert (Has_File_Time_Stamp (Get_Kind (Design))); + Set_Field4 (Design, Time_Stamp_Id_To_Iir (Stamp)); + end Set_File_Time_Stamp; + + function Get_Analysis_Time_Stamp (Design : Iir) return Time_Stamp_Id is + begin + pragma Assert (Design /= Null_Iir); + pragma Assert (Has_Analysis_Time_Stamp (Get_Kind (Design))); + return Iir_To_Time_Stamp_Id (Get_Field3 (Design)); + end Get_Analysis_Time_Stamp; + + procedure Set_Analysis_Time_Stamp (Design : Iir; Stamp : Time_Stamp_Id) is + begin + pragma Assert (Design /= Null_Iir); + pragma Assert (Has_Analysis_Time_Stamp (Get_Kind (Design))); + Set_Field3 (Design, Time_Stamp_Id_To_Iir (Stamp)); + end Set_Analysis_Time_Stamp; + + function Get_Library (File : Iir_Design_File) return Iir is + begin + pragma Assert (File /= Null_Iir); + pragma Assert (Has_Library (Get_Kind (File))); + return Get_Field0 (File); + end Get_Library; + + procedure Set_Library (File : Iir_Design_File; Lib : Iir) is + begin + pragma Assert (File /= Null_Iir); + pragma Assert (Has_Library (Get_Kind (File))); + Set_Field0 (File, Lib); + end Set_Library; + + function Get_File_Dependence_List (File : Iir_Design_File) return Iir_List + is + begin + pragma Assert (File /= Null_Iir); + pragma Assert (Has_File_Dependence_List (Get_Kind (File))); + return Iir_To_Iir_List (Get_Field1 (File)); + end Get_File_Dependence_List; + + procedure Set_File_Dependence_List (File : Iir_Design_File; Lst : Iir_List) + is + begin + pragma Assert (File /= Null_Iir); + pragma Assert (Has_File_Dependence_List (Get_Kind (File))); + Set_Field1 (File, Iir_List_To_Iir (Lst)); + end Set_File_Dependence_List; + + function Get_Design_File_Filename (File : Iir_Design_File) return Name_Id + is + begin + pragma Assert (File /= Null_Iir); + pragma Assert (Has_Design_File_Filename (Get_Kind (File))); + return Name_Id'Val (Get_Field12 (File)); + end Get_Design_File_Filename; + + procedure Set_Design_File_Filename (File : Iir_Design_File; Name : Name_Id) + is + begin + pragma Assert (File /= Null_Iir); + pragma Assert (Has_Design_File_Filename (Get_Kind (File))); + Set_Field12 (File, Name_Id'Pos (Name)); + end Set_Design_File_Filename; + + function Get_Design_File_Directory (File : Iir_Design_File) return Name_Id + is + begin + pragma Assert (File /= Null_Iir); + pragma Assert (Has_Design_File_Directory (Get_Kind (File))); + return Name_Id'Val (Get_Field11 (File)); + end Get_Design_File_Directory; + + procedure Set_Design_File_Directory (File : Iir_Design_File; Dir : Name_Id) + is + begin + pragma Assert (File /= Null_Iir); + pragma Assert (Has_Design_File_Directory (Get_Kind (File))); + Set_Field11 (File, Name_Id'Pos (Dir)); + end Set_Design_File_Directory; + + function Get_Design_File (Unit : Iir_Design_Unit) return Iir is + begin + pragma Assert (Unit /= Null_Iir); + pragma Assert (Has_Design_File (Get_Kind (Unit))); + return Get_Field0 (Unit); + end Get_Design_File; + + procedure Set_Design_File (Unit : Iir_Design_Unit; File : Iir) is + begin + pragma Assert (Unit /= Null_Iir); + pragma Assert (Has_Design_File (Get_Kind (Unit))); + Set_Field0 (Unit, File); + end Set_Design_File; + + function Get_Design_File_Chain (Library : Iir) return Iir is + begin + pragma Assert (Library /= Null_Iir); + pragma Assert (Has_Design_File_Chain (Get_Kind (Library))); + return Get_Field1 (Library); + end Get_Design_File_Chain; + + procedure Set_Design_File_Chain (Library : Iir; Chain : Iir) is + begin + pragma Assert (Library /= Null_Iir); + pragma Assert (Has_Design_File_Chain (Get_Kind (Library))); + Set_Field1 (Library, Chain); + end Set_Design_File_Chain; + + function Get_Library_Directory (Library : Iir) return Name_Id is + begin + pragma Assert (Library /= Null_Iir); + pragma Assert (Has_Library_Directory (Get_Kind (Library))); + return Name_Id'Val (Get_Field11 (Library)); + end Get_Library_Directory; + + procedure Set_Library_Directory (Library : Iir; Dir : Name_Id) is + begin + pragma Assert (Library /= Null_Iir); + pragma Assert (Has_Library_Directory (Get_Kind (Library))); + Set_Field11 (Library, Name_Id'Pos (Dir)); + end Set_Library_Directory; + + function Get_Date (Target : Iir) return Date_Type is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Date (Get_Kind (Target))); + return Date_Type'Val (Get_Field10 (Target)); + end Get_Date; + + procedure Set_Date (Target : Iir; Date : Date_Type) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Date (Get_Kind (Target))); + Set_Field10 (Target, Date_Type'Pos (Date)); + end Set_Date; + + function Get_Context_Items (Design_Unit : Iir) return Iir is + begin + pragma Assert (Design_Unit /= Null_Iir); + pragma Assert (Has_Context_Items (Get_Kind (Design_Unit))); + return Get_Field1 (Design_Unit); + end Get_Context_Items; + + procedure Set_Context_Items (Design_Unit : Iir; Items_Chain : Iir) is + begin + pragma Assert (Design_Unit /= Null_Iir); + pragma Assert (Has_Context_Items (Get_Kind (Design_Unit))); + Set_Field1 (Design_Unit, Items_Chain); + end Set_Context_Items; + + function Get_Dependence_List (Unit : Iir) return Iir_List is + begin + pragma Assert (Unit /= Null_Iir); + pragma Assert (Has_Dependence_List (Get_Kind (Unit))); + return Iir_To_Iir_List (Get_Field8 (Unit)); + end Get_Dependence_List; + + procedure Set_Dependence_List (Unit : Iir; List : Iir_List) is + begin + pragma Assert (Unit /= Null_Iir); + pragma Assert (Has_Dependence_List (Get_Kind (Unit))); + Set_Field8 (Unit, Iir_List_To_Iir (List)); + end Set_Dependence_List; + + function Get_Analysis_Checks_List (Unit : Iir) return Iir_List is + begin + pragma Assert (Unit /= Null_Iir); + pragma Assert (Has_Analysis_Checks_List (Get_Kind (Unit))); + return Iir_To_Iir_List (Get_Field9 (Unit)); + end Get_Analysis_Checks_List; + + procedure Set_Analysis_Checks_List (Unit : Iir; List : Iir_List) is + begin + pragma Assert (Unit /= Null_Iir); + pragma Assert (Has_Analysis_Checks_List (Get_Kind (Unit))); + Set_Field9 (Unit, Iir_List_To_Iir (List)); + end Set_Analysis_Checks_List; + + function Get_Date_State (Unit : Iir_Design_Unit) return Date_State_Type is + begin + pragma Assert (Unit /= Null_Iir); + pragma Assert (Has_Date_State (Get_Kind (Unit))); + return Date_State_Type'Val (Get_State1 (Unit)); + end Get_Date_State; + + procedure Set_Date_State (Unit : Iir_Design_Unit; State : Date_State_Type) + is + begin + pragma Assert (Unit /= Null_Iir); + pragma Assert (Has_Date_State (Get_Kind (Unit))); + Set_State1 (Unit, Date_State_Type'Pos (State)); + end Set_Date_State; + + function Get_Guarded_Target_State (Stmt : Iir) return Tri_State_Type is + begin + pragma Assert (Stmt /= Null_Iir); + pragma Assert (Has_Guarded_Target_State (Get_Kind (Stmt))); + return Tri_State_Type'Val (Get_State3 (Stmt)); + end Get_Guarded_Target_State; + + procedure Set_Guarded_Target_State (Stmt : Iir; State : Tri_State_Type) is + begin + pragma Assert (Stmt /= Null_Iir); + pragma Assert (Has_Guarded_Target_State (Get_Kind (Stmt))); + Set_State3 (Stmt, Tri_State_Type'Pos (State)); + end Set_Guarded_Target_State; + + function Get_Library_Unit (Design_Unit : Iir_Design_Unit) return Iir is + begin + pragma Assert (Design_Unit /= Null_Iir); + pragma Assert (Has_Library_Unit (Get_Kind (Design_Unit))); + return Get_Field5 (Design_Unit); + end Get_Library_Unit; + + procedure Set_Library_Unit (Design_Unit : Iir_Design_Unit; Lib_Unit : Iir) + is + begin + pragma Assert (Design_Unit /= Null_Iir); + pragma Assert (Has_Library_Unit (Get_Kind (Design_Unit))); + Set_Field5 (Design_Unit, Lib_Unit); + end Set_Library_Unit; + + function Get_Hash_Chain (Design_Unit : Iir_Design_Unit) return Iir is + begin + pragma Assert (Design_Unit /= Null_Iir); + pragma Assert (Has_Hash_Chain (Get_Kind (Design_Unit))); + return Get_Field7 (Design_Unit); + end Get_Hash_Chain; + + procedure Set_Hash_Chain (Design_Unit : Iir_Design_Unit; Chain : Iir) is + begin + pragma Assert (Design_Unit /= Null_Iir); + pragma Assert (Has_Hash_Chain (Get_Kind (Design_Unit))); + Set_Field7 (Design_Unit, Chain); + end Set_Hash_Chain; + + function Get_Design_Unit_Source_Pos (Design_Unit : Iir) return Source_Ptr + is + begin + pragma Assert (Design_Unit /= Null_Iir); + pragma Assert (Has_Design_Unit_Source_Pos (Get_Kind (Design_Unit))); + return Iir_To_Source_Ptr (Get_Field4 (Design_Unit)); + end Get_Design_Unit_Source_Pos; + + procedure Set_Design_Unit_Source_Pos (Design_Unit : Iir; Pos : Source_Ptr) + is + begin + pragma Assert (Design_Unit /= Null_Iir); + pragma Assert (Has_Design_Unit_Source_Pos (Get_Kind (Design_Unit))); + Set_Field4 (Design_Unit, Source_Ptr_To_Iir (Pos)); + end Set_Design_Unit_Source_Pos; + + function Get_Design_Unit_Source_Line (Design_Unit : Iir) return Int32 is + begin + pragma Assert (Design_Unit /= Null_Iir); + pragma Assert (Has_Design_Unit_Source_Line (Get_Kind (Design_Unit))); + return Iir_To_Int32 (Get_Field11 (Design_Unit)); + end Get_Design_Unit_Source_Line; + + procedure Set_Design_Unit_Source_Line (Design_Unit : Iir; Line : Int32) is + begin + pragma Assert (Design_Unit /= Null_Iir); + pragma Assert (Has_Design_Unit_Source_Line (Get_Kind (Design_Unit))); + Set_Field11 (Design_Unit, Int32_To_Iir (Line)); + end Set_Design_Unit_Source_Line; + + function Get_Design_Unit_Source_Col (Design_Unit : Iir) return Int32 is + begin + pragma Assert (Design_Unit /= Null_Iir); + pragma Assert (Has_Design_Unit_Source_Col (Get_Kind (Design_Unit))); + return Iir_To_Int32 (Get_Field12 (Design_Unit)); + end Get_Design_Unit_Source_Col; + + procedure Set_Design_Unit_Source_Col (Design_Unit : Iir; Line : Int32) is + begin + pragma Assert (Design_Unit /= Null_Iir); + pragma Assert (Has_Design_Unit_Source_Col (Get_Kind (Design_Unit))); + Set_Field12 (Design_Unit, Int32_To_Iir (Line)); + end Set_Design_Unit_Source_Col; + + function Get_Value (Lit : Iir) return Iir_Int64 is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Value (Get_Kind (Lit))); + return Get_Int64 (Lit); + end Get_Value; + + procedure Set_Value (Lit : Iir; Val : Iir_Int64) is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Value (Get_Kind (Lit))); + Set_Int64 (Lit, Val); + end Set_Value; + + function Get_Enum_Pos (Lit : Iir) return Iir_Int32 is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Enum_Pos (Get_Kind (Lit))); + return Iir_Int32'Val (Get_Field10 (Lit)); + end Get_Enum_Pos; + + procedure Set_Enum_Pos (Lit : Iir; Val : Iir_Int32) is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Enum_Pos (Get_Kind (Lit))); + Set_Field10 (Lit, Iir_Int32'Pos (Val)); + end Set_Enum_Pos; + + function Get_Physical_Literal (Unit : Iir) return Iir is + begin + pragma Assert (Unit /= Null_Iir); + pragma Assert (Has_Physical_Literal (Get_Kind (Unit))); + return Get_Field6 (Unit); + end Get_Physical_Literal; + + procedure Set_Physical_Literal (Unit : Iir; Lit : Iir) is + begin + pragma Assert (Unit /= Null_Iir); + pragma Assert (Has_Physical_Literal (Get_Kind (Unit))); + Set_Field6 (Unit, Lit); + end Set_Physical_Literal; + + function Get_Physical_Unit_Value (Unit : Iir) return Iir is + begin + pragma Assert (Unit /= Null_Iir); + pragma Assert (Has_Physical_Unit_Value (Get_Kind (Unit))); + return Get_Field7 (Unit); + end Get_Physical_Unit_Value; + + procedure Set_Physical_Unit_Value (Unit : Iir; Lit : Iir) is + begin + pragma Assert (Unit /= Null_Iir); + pragma Assert (Has_Physical_Unit_Value (Get_Kind (Unit))); + Set_Field7 (Unit, Lit); + end Set_Physical_Unit_Value; + + function Get_Fp_Value (Lit : Iir) return Iir_Fp64 is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Fp_Value (Get_Kind (Lit))); + return Get_Fp64 (Lit); + end Get_Fp_Value; + + procedure Set_Fp_Value (Lit : Iir; Val : Iir_Fp64) is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Fp_Value (Get_Kind (Lit))); + Set_Fp64 (Lit, Val); + end Set_Fp_Value; + + function Get_Enumeration_Decl (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Enumeration_Decl (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_Enumeration_Decl; + + procedure Set_Enumeration_Decl (Target : Iir; Lit : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Enumeration_Decl (Get_Kind (Target))); + Set_Field6 (Target, Lit); + end Set_Enumeration_Decl; + + function Get_Simple_Aggregate_List (Target : Iir) return Iir_List is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Simple_Aggregate_List (Get_Kind (Target))); + return Iir_To_Iir_List (Get_Field3 (Target)); + end Get_Simple_Aggregate_List; + + procedure Set_Simple_Aggregate_List (Target : Iir; List : Iir_List) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Simple_Aggregate_List (Get_Kind (Target))); + Set_Field3 (Target, Iir_List_To_Iir (List)); + end Set_Simple_Aggregate_List; + + function Get_Bit_String_Base (Lit : Iir) return Base_Type is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Bit_String_Base (Get_Kind (Lit))); + return Base_Type'Val (Get_Field8 (Lit)); + end Get_Bit_String_Base; + + procedure Set_Bit_String_Base (Lit : Iir; Base : Base_Type) is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Bit_String_Base (Get_Kind (Lit))); + Set_Field8 (Lit, Base_Type'Pos (Base)); + end Set_Bit_String_Base; + + function Get_Bit_String_0 (Lit : Iir) return Iir is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Bit_String_0 (Get_Kind (Lit))); + return Get_Field6 (Lit); + end Get_Bit_String_0; + + procedure Set_Bit_String_0 (Lit : Iir; El : Iir) is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Bit_String_0 (Get_Kind (Lit))); + Set_Field6 (Lit, El); + end Set_Bit_String_0; + + function Get_Bit_String_1 (Lit : Iir) return Iir is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Bit_String_1 (Get_Kind (Lit))); + return Get_Field7 (Lit); + end Get_Bit_String_1; + + procedure Set_Bit_String_1 (Lit : Iir; El : Iir) is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Bit_String_1 (Get_Kind (Lit))); + Set_Field7 (Lit, El); + end Set_Bit_String_1; + + function Get_Literal_Origin (Lit : Iir) return Iir is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Literal_Origin (Get_Kind (Lit))); + return Get_Field2 (Lit); + end Get_Literal_Origin; + + procedure Set_Literal_Origin (Lit : Iir; Orig : Iir) is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Literal_Origin (Get_Kind (Lit))); + Set_Field2 (Lit, Orig); + end Set_Literal_Origin; + + function Get_Range_Origin (Lit : Iir) return Iir is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Range_Origin (Get_Kind (Lit))); + return Get_Field4 (Lit); + end Get_Range_Origin; + + procedure Set_Range_Origin (Lit : Iir; Orig : Iir) is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Range_Origin (Get_Kind (Lit))); + Set_Field4 (Lit, Orig); + end Set_Range_Origin; + + function Get_Literal_Subtype (Lit : Iir) return Iir is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Literal_Subtype (Get_Kind (Lit))); + return Get_Field5 (Lit); + end Get_Literal_Subtype; + + procedure Set_Literal_Subtype (Lit : Iir; Atype : Iir) is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_Literal_Subtype (Get_Kind (Lit))); + Set_Field5 (Lit, Atype); + end Set_Literal_Subtype; + + function Get_Entity_Class (Target : Iir) return Token_Type is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Entity_Class (Get_Kind (Target))); + return Iir_To_Token_Type (Get_Field3 (Target)); + end Get_Entity_Class; + + procedure Set_Entity_Class (Target : Iir; Kind : Token_Type) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Entity_Class (Get_Kind (Target))); + Set_Field3 (Target, Token_Type_To_Iir (Kind)); + end Set_Entity_Class; + + function Get_Entity_Name_List (Target : Iir) return Iir_List is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Entity_Name_List (Get_Kind (Target))); + return Iir_To_Iir_List (Get_Field1 (Target)); + end Get_Entity_Name_List; + + procedure Set_Entity_Name_List (Target : Iir; Names : Iir_List) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Entity_Name_List (Get_Kind (Target))); + Set_Field1 (Target, Iir_List_To_Iir (Names)); + end Set_Entity_Name_List; + + function Get_Attribute_Designator (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Attribute_Designator (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_Attribute_Designator; + + procedure Set_Attribute_Designator (Target : Iir; Designator : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Attribute_Designator (Get_Kind (Target))); + Set_Field6 (Target, Designator); + end Set_Attribute_Designator; + + function Get_Attribute_Specification_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Attribute_Specification_Chain (Get_Kind (Target))); + return Get_Field7 (Target); + end Get_Attribute_Specification_Chain; + + procedure Set_Attribute_Specification_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Attribute_Specification_Chain (Get_Kind (Target))); + Set_Field7 (Target, Chain); + end Set_Attribute_Specification_Chain; + + function Get_Attribute_Specification (Val : Iir) return Iir is + begin + pragma Assert (Val /= Null_Iir); + pragma Assert (Has_Attribute_Specification (Get_Kind (Val))); + return Get_Field4 (Val); + end Get_Attribute_Specification; + + procedure Set_Attribute_Specification (Val : Iir; Attr : Iir) is + begin + pragma Assert (Val /= Null_Iir); + pragma Assert (Has_Attribute_Specification (Get_Kind (Val))); + Set_Field4 (Val, Attr); + end Set_Attribute_Specification; + + function Get_Signal_List (Target : Iir) return Iir_List is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Signal_List (Get_Kind (Target))); + return Iir_To_Iir_List (Get_Field3 (Target)); + end Get_Signal_List; + + procedure Set_Signal_List (Target : Iir; List : Iir_List) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Signal_List (Get_Kind (Target))); + Set_Field3 (Target, Iir_List_To_Iir (List)); + end Set_Signal_List; + + function Get_Designated_Entity (Val : Iir_Attribute_Value) return Iir is + begin + pragma Assert (Val /= Null_Iir); + pragma Assert (Has_Designated_Entity (Get_Kind (Val))); + return Get_Field3 (Val); + end Get_Designated_Entity; + + procedure Set_Designated_Entity (Val : Iir_Attribute_Value; Entity : Iir) + is + begin + pragma Assert (Val /= Null_Iir); + pragma Assert (Has_Designated_Entity (Get_Kind (Val))); + Set_Field3 (Val, Entity); + end Set_Designated_Entity; + + function Get_Formal (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Formal (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Formal; + + procedure Set_Formal (Target : Iir; Formal : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Formal (Get_Kind (Target))); + Set_Field1 (Target, Formal); + end Set_Formal; + + function Get_Actual (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Actual (Get_Kind (Target))); + return Get_Field3 (Target); + end Get_Actual; + + procedure Set_Actual (Target : Iir; Actual : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Actual (Get_Kind (Target))); + Set_Field3 (Target, Actual); + end Set_Actual; + + function Get_In_Conversion (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_In_Conversion (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_In_Conversion; + + procedure Set_In_Conversion (Target : Iir; Conv : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_In_Conversion (Get_Kind (Target))); + Set_Field4 (Target, Conv); + end Set_In_Conversion; + + function Get_Out_Conversion (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Out_Conversion (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Out_Conversion; + + procedure Set_Out_Conversion (Target : Iir; Conv : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Out_Conversion (Get_Kind (Target))); + Set_Field5 (Target, Conv); + end Set_Out_Conversion; + + function Get_Whole_Association_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Whole_Association_Flag (Get_Kind (Target))); + return Get_Flag1 (Target); + end Get_Whole_Association_Flag; + + procedure Set_Whole_Association_Flag (Target : Iir; Flag : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Whole_Association_Flag (Get_Kind (Target))); + Set_Flag1 (Target, Flag); + end Set_Whole_Association_Flag; + + function Get_Collapse_Signal_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Collapse_Signal_Flag (Get_Kind (Target))); + return Get_Flag2 (Target); + end Get_Collapse_Signal_Flag; + + procedure Set_Collapse_Signal_Flag (Target : Iir; Flag : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Collapse_Signal_Flag (Get_Kind (Target))); + Set_Flag2 (Target, Flag); + end Set_Collapse_Signal_Flag; + + function Get_Artificial_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Artificial_Flag (Get_Kind (Target))); + return Get_Flag3 (Target); + end Get_Artificial_Flag; + + procedure Set_Artificial_Flag (Target : Iir; Flag : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Artificial_Flag (Get_Kind (Target))); + Set_Flag3 (Target, Flag); + end Set_Artificial_Flag; + + function Get_Open_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Open_Flag (Get_Kind (Target))); + return Get_Flag3 (Target); + end Get_Open_Flag; + + procedure Set_Open_Flag (Target : Iir; Flag : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Open_Flag (Get_Kind (Target))); + Set_Flag3 (Target, Flag); + end Set_Open_Flag; + + function Get_After_Drivers_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_After_Drivers_Flag (Get_Kind (Target))); + return Get_Flag5 (Target); + end Get_After_Drivers_Flag; + + procedure Set_After_Drivers_Flag (Target : Iir; Flag : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_After_Drivers_Flag (Get_Kind (Target))); + Set_Flag5 (Target, Flag); + end Set_After_Drivers_Flag; + + function Get_We_Value (We : Iir_Waveform_Element) return Iir is + begin + pragma Assert (We /= Null_Iir); + pragma Assert (Has_We_Value (Get_Kind (We))); + return Get_Field1 (We); + end Get_We_Value; + + procedure Set_We_Value (We : Iir_Waveform_Element; An_Iir : Iir) is + begin + pragma Assert (We /= Null_Iir); + pragma Assert (Has_We_Value (Get_Kind (We))); + Set_Field1 (We, An_Iir); + end Set_We_Value; + + function Get_Time (We : Iir_Waveform_Element) return Iir is + begin + pragma Assert (We /= Null_Iir); + pragma Assert (Has_Time (Get_Kind (We))); + return Get_Field3 (We); + end Get_Time; + + procedure Set_Time (We : Iir_Waveform_Element; An_Iir : Iir) is + begin + pragma Assert (We /= Null_Iir); + pragma Assert (Has_Time (Get_Kind (We))); + Set_Field3 (We, An_Iir); + end Set_Time; + + function Get_Associated_Expr (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Associated_Expr (Get_Kind (Target))); + return Get_Field3 (Target); + end Get_Associated_Expr; + + procedure Set_Associated_Expr (Target : Iir; Associated : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Associated_Expr (Get_Kind (Target))); + Set_Field3 (Target, Associated); + end Set_Associated_Expr; + + function Get_Associated_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Associated_Chain (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Associated_Chain; + + procedure Set_Associated_Chain (Target : Iir; Associated : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Associated_Chain (Get_Kind (Target))); + Set_Field4 (Target, Associated); + end Set_Associated_Chain; + + function Get_Choice_Name (Choice : Iir) return Iir is + begin + pragma Assert (Choice /= Null_Iir); + pragma Assert (Has_Choice_Name (Get_Kind (Choice))); + return Get_Field5 (Choice); + end Get_Choice_Name; + + procedure Set_Choice_Name (Choice : Iir; Name : Iir) is + begin + pragma Assert (Choice /= Null_Iir); + pragma Assert (Has_Choice_Name (Get_Kind (Choice))); + Set_Field5 (Choice, Name); + end Set_Choice_Name; + + function Get_Choice_Expression (Choice : Iir) return Iir is + begin + pragma Assert (Choice /= Null_Iir); + pragma Assert (Has_Choice_Expression (Get_Kind (Choice))); + return Get_Field5 (Choice); + end Get_Choice_Expression; + + procedure Set_Choice_Expression (Choice : Iir; Name : Iir) is + begin + pragma Assert (Choice /= Null_Iir); + pragma Assert (Has_Choice_Expression (Get_Kind (Choice))); + Set_Field5 (Choice, Name); + end Set_Choice_Expression; + + function Get_Choice_Range (Choice : Iir) return Iir is + begin + pragma Assert (Choice /= Null_Iir); + pragma Assert (Has_Choice_Range (Get_Kind (Choice))); + return Get_Field5 (Choice); + end Get_Choice_Range; + + procedure Set_Choice_Range (Choice : Iir; Name : Iir) is + begin + pragma Assert (Choice /= Null_Iir); + pragma Assert (Has_Choice_Range (Get_Kind (Choice))); + Set_Field5 (Choice, Name); + end Set_Choice_Range; + + function Get_Same_Alternative_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Same_Alternative_Flag (Get_Kind (Target))); + return Get_Flag1 (Target); + end Get_Same_Alternative_Flag; + + procedure Set_Same_Alternative_Flag (Target : Iir; Val : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Same_Alternative_Flag (Get_Kind (Target))); + Set_Flag1 (Target, Val); + end Set_Same_Alternative_Flag; + + function Get_Architecture (Target : Iir_Entity_Aspect_Entity) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Architecture (Get_Kind (Target))); + return Get_Field3 (Target); + end Get_Architecture; + + procedure Set_Architecture (Target : Iir_Entity_Aspect_Entity; Arch : Iir) + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Architecture (Get_Kind (Target))); + Set_Field3 (Target, Arch); + end Set_Architecture; + + function Get_Block_Specification (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Block_Specification (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Block_Specification; + + procedure Set_Block_Specification (Target : Iir; Block : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Block_Specification (Get_Kind (Target))); + Set_Field5 (Target, Block); + end Set_Block_Specification; + + function Get_Prev_Block_Configuration (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Prev_Block_Configuration (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Prev_Block_Configuration; + + procedure Set_Prev_Block_Configuration (Target : Iir; Block : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Prev_Block_Configuration (Get_Kind (Target))); + Set_Field4 (Target, Block); + end Set_Prev_Block_Configuration; + + function Get_Configuration_Item_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Configuration_Item_Chain (Get_Kind (Target))); + return Get_Field3 (Target); + end Get_Configuration_Item_Chain; + + procedure Set_Configuration_Item_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Configuration_Item_Chain (Get_Kind (Target))); + Set_Field3 (Target, Chain); + end Set_Configuration_Item_Chain; + + function Get_Attribute_Value_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Attribute_Value_Chain (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Attribute_Value_Chain; + + procedure Set_Attribute_Value_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Attribute_Value_Chain (Get_Kind (Target))); + Set_Field4 (Target, Chain); + end Set_Attribute_Value_Chain; + + function Get_Spec_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Spec_Chain (Get_Kind (Target))); + return Get_Field0 (Target); + end Get_Spec_Chain; + + procedure Set_Spec_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Spec_Chain (Get_Kind (Target))); + Set_Field0 (Target, Chain); + end Set_Spec_Chain; + + function Get_Attribute_Value_Spec_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Attribute_Value_Spec_Chain (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Attribute_Value_Spec_Chain; + + procedure Set_Attribute_Value_Spec_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Attribute_Value_Spec_Chain (Get_Kind (Target))); + Set_Field4 (Target, Chain); + end Set_Attribute_Value_Spec_Chain; + + function Get_Entity_Name (Arch : Iir) return Iir is + begin + pragma Assert (Arch /= Null_Iir); + pragma Assert (Has_Entity_Name (Get_Kind (Arch))); + return Get_Field2 (Arch); + end Get_Entity_Name; + + procedure Set_Entity_Name (Arch : Iir; Entity : Iir) is + begin + pragma Assert (Arch /= Null_Iir); + pragma Assert (Has_Entity_Name (Get_Kind (Arch))); + Set_Field2 (Arch, Entity); + end Set_Entity_Name; + + function Get_Package (Package_Body : Iir) return Iir is + begin + pragma Assert (Package_Body /= Null_Iir); + pragma Assert (Has_Package (Get_Kind (Package_Body))); + return Get_Field4 (Package_Body); + end Get_Package; + + procedure Set_Package (Package_Body : Iir; Decl : Iir) is + begin + pragma Assert (Package_Body /= Null_Iir); + pragma Assert (Has_Package (Get_Kind (Package_Body))); + Set_Field4 (Package_Body, Decl); + end Set_Package; + + function Get_Package_Body (Pkg : Iir) return Iir is + begin + pragma Assert (Pkg /= Null_Iir); + pragma Assert (Has_Package_Body (Get_Kind (Pkg))); + return Get_Field2 (Pkg); + end Get_Package_Body; + + procedure Set_Package_Body (Pkg : Iir; Decl : Iir) is + begin + pragma Assert (Pkg /= Null_Iir); + pragma Assert (Has_Package_Body (Get_Kind (Pkg))); + Set_Field2 (Pkg, Decl); + end Set_Package_Body; + + function Get_Need_Body (Decl : Iir_Package_Declaration) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Need_Body (Get_Kind (Decl))); + return Get_Flag1 (Decl); + end Get_Need_Body; + + procedure Set_Need_Body (Decl : Iir_Package_Declaration; Flag : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Need_Body (Get_Kind (Decl))); + Set_Flag1 (Decl, Flag); + end Set_Need_Body; + + function Get_Block_Configuration (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Block_Configuration (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Block_Configuration; + + procedure Set_Block_Configuration (Target : Iir; Block : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Block_Configuration (Get_Kind (Target))); + Set_Field5 (Target, Block); + end Set_Block_Configuration; + + function Get_Concurrent_Statement_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Concurrent_Statement_Chain (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Concurrent_Statement_Chain; + + procedure Set_Concurrent_Statement_Chain (Target : Iir; First : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Concurrent_Statement_Chain (Get_Kind (Target))); + Set_Field5 (Target, First); + end Set_Concurrent_Statement_Chain; + + function Get_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Chain (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Chain; + + procedure Set_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Chain (Get_Kind (Target))); + Set_Field2 (Target, Chain); + end Set_Chain; + + function Get_Port_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Port_Chain (Get_Kind (Target))); + return Get_Field7 (Target); + end Get_Port_Chain; + + procedure Set_Port_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Port_Chain (Get_Kind (Target))); + Set_Field7 (Target, Chain); + end Set_Port_Chain; + + function Get_Generic_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Generic_Chain (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_Generic_Chain; + + procedure Set_Generic_Chain (Target : Iir; Generics : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Generic_Chain (Get_Kind (Target))); + Set_Field6 (Target, Generics); + end Set_Generic_Chain; + + function Get_Type (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Type (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Type; + + procedure Set_Type (Target : Iir; Atype : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Type (Get_Kind (Target))); + Set_Field1 (Target, Atype); + end Set_Type; + + function Get_Subtype_Indication (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subtype_Indication (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Subtype_Indication; + + procedure Set_Subtype_Indication (Target : Iir; Atype : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subtype_Indication (Get_Kind (Target))); + Set_Field5 (Target, Atype); + end Set_Subtype_Indication; + + function Get_Discrete_Range (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Discrete_Range (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_Discrete_Range; + + procedure Set_Discrete_Range (Target : Iir; Rng : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Discrete_Range (Get_Kind (Target))); + Set_Field6 (Target, Rng); + end Set_Discrete_Range; + + function Get_Type_Definition (Decl : Iir) return Iir is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Type_Definition (Get_Kind (Decl))); + return Get_Field1 (Decl); + end Get_Type_Definition; + + procedure Set_Type_Definition (Decl : Iir; Atype : Iir) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Type_Definition (Get_Kind (Decl))); + Set_Field1 (Decl, Atype); + end Set_Type_Definition; + + function Get_Subtype_Definition (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subtype_Definition (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Subtype_Definition; + + procedure Set_Subtype_Definition (Target : Iir; Def : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subtype_Definition (Get_Kind (Target))); + Set_Field4 (Target, Def); + end Set_Subtype_Definition; + + function Get_Nature (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Nature (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Nature; + + procedure Set_Nature (Target : Iir; Nature : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Nature (Get_Kind (Target))); + Set_Field1 (Target, Nature); + end Set_Nature; + + function Get_Mode (Target : Iir) return Iir_Mode is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Mode (Get_Kind (Target))); + return Iir_Mode'Val (Get_Odigit1 (Target)); + end Get_Mode; + + procedure Set_Mode (Target : Iir; Mode : Iir_Mode) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Mode (Get_Kind (Target))); + Set_Odigit1 (Target, Iir_Mode'Pos (Mode)); + end Set_Mode; + + function Get_Signal_Kind (Target : Iir) return Iir_Signal_Kind is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Signal_Kind (Get_Kind (Target))); + return Iir_Signal_Kind'Val (Get_State3 (Target)); + end Get_Signal_Kind; + + procedure Set_Signal_Kind (Target : Iir; Signal_Kind : Iir_Signal_Kind) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Signal_Kind (Get_Kind (Target))); + Set_State3 (Target, Iir_Signal_Kind'Pos (Signal_Kind)); + end Set_Signal_Kind; + + function Get_Base_Name (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Base_Name (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Base_Name; + + procedure Set_Base_Name (Target : Iir; Name : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Base_Name (Get_Kind (Target))); + Set_Field5 (Target, Name); + end Set_Base_Name; + + function Get_Interface_Declaration_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Interface_Declaration_Chain (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Interface_Declaration_Chain; + + procedure Set_Interface_Declaration_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Interface_Declaration_Chain (Get_Kind (Target))); + Set_Field5 (Target, Chain); + end Set_Interface_Declaration_Chain; + + function Get_Subprogram_Specification (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subprogram_Specification (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Subprogram_Specification; + + procedure Set_Subprogram_Specification (Target : Iir; Spec : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subprogram_Specification (Get_Kind (Target))); + Set_Field4 (Target, Spec); + end Set_Subprogram_Specification; + + function Get_Sequential_Statement_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Sequential_Statement_Chain (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Sequential_Statement_Chain; + + procedure Set_Sequential_Statement_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Sequential_Statement_Chain (Get_Kind (Target))); + Set_Field5 (Target, Chain); + end Set_Sequential_Statement_Chain; + + function Get_Subprogram_Body (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subprogram_Body (Get_Kind (Target))); + return Get_Field9 (Target); + end Get_Subprogram_Body; + + procedure Set_Subprogram_Body (Target : Iir; A_Body : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subprogram_Body (Get_Kind (Target))); + Set_Field9 (Target, A_Body); + end Set_Subprogram_Body; + + function Get_Overload_Number (Target : Iir) return Iir_Int32 is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Overload_Number (Get_Kind (Target))); + return Iir_Int32'Val (Get_Field12 (Target)); + end Get_Overload_Number; + + procedure Set_Overload_Number (Target : Iir; Val : Iir_Int32) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Overload_Number (Get_Kind (Target))); + Set_Field12 (Target, Iir_Int32'Pos (Val)); + end Set_Overload_Number; + + function Get_Subprogram_Depth (Target : Iir) return Iir_Int32 is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subprogram_Depth (Get_Kind (Target))); + return Iir_Int32'Val (Get_Field10 (Target)); + end Get_Subprogram_Depth; + + procedure Set_Subprogram_Depth (Target : Iir; Depth : Iir_Int32) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subprogram_Depth (Get_Kind (Target))); + Set_Field10 (Target, Iir_Int32'Pos (Depth)); + end Set_Subprogram_Depth; + + function Get_Subprogram_Hash (Target : Iir) return Iir_Int32 is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subprogram_Hash (Get_Kind (Target))); + return Iir_Int32'Val (Get_Field11 (Target)); + end Get_Subprogram_Hash; + + procedure Set_Subprogram_Hash (Target : Iir; Val : Iir_Int32) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subprogram_Hash (Get_Kind (Target))); + Set_Field11 (Target, Iir_Int32'Pos (Val)); + end Set_Subprogram_Hash; + + function Get_Impure_Depth (Target : Iir) return Iir_Int32 is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Impure_Depth (Get_Kind (Target))); + return Iir_To_Iir_Int32 (Get_Field3 (Target)); + end Get_Impure_Depth; + + procedure Set_Impure_Depth (Target : Iir; Depth : Iir_Int32) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Impure_Depth (Get_Kind (Target))); + Set_Field3 (Target, Iir_Int32_To_Iir (Depth)); + end Set_Impure_Depth; + + function Get_Return_Type (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Return_Type (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Return_Type; + + procedure Set_Return_Type (Target : Iir; Decl : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Return_Type (Get_Kind (Target))); + Set_Field1 (Target, Decl); + end Set_Return_Type; + + function Get_Implicit_Definition (D : Iir) return Iir_Predefined_Functions + is + begin + pragma Assert (D /= Null_Iir); + pragma Assert (Has_Implicit_Definition (Get_Kind (D))); + return Iir_Predefined_Functions'Val (Get_Field9 (D)); + end Get_Implicit_Definition; + + procedure Set_Implicit_Definition (D : Iir; Def : Iir_Predefined_Functions) + is + begin + pragma Assert (D /= Null_Iir); + pragma Assert (Has_Implicit_Definition (Get_Kind (D))); + Set_Field9 (D, Iir_Predefined_Functions'Pos (Def)); + end Set_Implicit_Definition; + + function Get_Type_Reference (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Type_Reference (Get_Kind (Target))); + return Get_Field10 (Target); + end Get_Type_Reference; + + procedure Set_Type_Reference (Target : Iir; Decl : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Type_Reference (Get_Kind (Target))); + Set_Field10 (Target, Decl); + end Set_Type_Reference; + + function Get_Default_Value (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Default_Value (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_Default_Value; + + procedure Set_Default_Value (Target : Iir; Value : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Default_Value (Get_Kind (Target))); + Set_Field6 (Target, Value); + end Set_Default_Value; + + function Get_Deferred_Declaration (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Deferred_Declaration (Get_Kind (Target))); + return Get_Field7 (Target); + end Get_Deferred_Declaration; + + procedure Set_Deferred_Declaration (Target : Iir; Decl : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Deferred_Declaration (Get_Kind (Target))); + Set_Field7 (Target, Decl); + end Set_Deferred_Declaration; + + function Get_Deferred_Declaration_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Deferred_Declaration_Flag (Get_Kind (Target))); + return Get_Flag1 (Target); + end Get_Deferred_Declaration_Flag; + + procedure Set_Deferred_Declaration_Flag (Target : Iir; Flag : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Deferred_Declaration_Flag (Get_Kind (Target))); + Set_Flag1 (Target, Flag); + end Set_Deferred_Declaration_Flag; + + function Get_Shared_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Shared_Flag (Get_Kind (Target))); + return Get_Flag2 (Target); + end Get_Shared_Flag; + + procedure Set_Shared_Flag (Target : Iir; Shared : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Shared_Flag (Get_Kind (Target))); + Set_Flag2 (Target, Shared); + end Set_Shared_Flag; + + function Get_Design_Unit (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Design_Unit (Get_Kind (Target))); + return Get_Field0 (Target); + end Get_Design_Unit; + + procedure Set_Design_Unit (Target : Iir; Unit : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Design_Unit (Get_Kind (Target))); + Set_Field0 (Target, Unit); + end Set_Design_Unit; + + function Get_Block_Statement (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Block_Statement (Get_Kind (Target))); + return Get_Field7 (Target); + end Get_Block_Statement; + + procedure Set_Block_Statement (Target : Iir; Block : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Block_Statement (Get_Kind (Target))); + Set_Field7 (Target, Block); + end Set_Block_Statement; + + function Get_Signal_Driver (Target : Iir_Signal_Declaration) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Signal_Driver (Get_Kind (Target))); + return Get_Field7 (Target); + end Get_Signal_Driver; + + procedure Set_Signal_Driver (Target : Iir_Signal_Declaration; Driver : Iir) + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Signal_Driver (Get_Kind (Target))); + Set_Field7 (Target, Driver); + end Set_Signal_Driver; + + function Get_Declaration_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Declaration_Chain (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Declaration_Chain; + + procedure Set_Declaration_Chain (Target : Iir; Decls : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Declaration_Chain (Get_Kind (Target))); + Set_Field1 (Target, Decls); + end Set_Declaration_Chain; + + function Get_File_Logical_Name (Target : Iir_File_Declaration) return Iir + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_File_Logical_Name (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_File_Logical_Name; + + procedure Set_File_Logical_Name (Target : Iir_File_Declaration; Name : Iir) + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_File_Logical_Name (Get_Kind (Target))); + Set_Field6 (Target, Name); + end Set_File_Logical_Name; + + function Get_File_Open_Kind (Target : Iir_File_Declaration) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_File_Open_Kind (Get_Kind (Target))); + return Get_Field7 (Target); + end Get_File_Open_Kind; + + procedure Set_File_Open_Kind (Target : Iir_File_Declaration; Kind : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_File_Open_Kind (Get_Kind (Target))); + Set_Field7 (Target, Kind); + end Set_File_Open_Kind; + + function Get_Element_Position (Target : Iir) return Iir_Index32 is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Element_Position (Get_Kind (Target))); + return Iir_Index32'Val (Get_Field4 (Target)); + end Get_Element_Position; + + procedure Set_Element_Position (Target : Iir; Pos : Iir_Index32) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Element_Position (Get_Kind (Target))); + Set_Field4 (Target, Iir_Index32'Pos (Pos)); + end Set_Element_Position; + + function Get_Element_Declaration (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Element_Declaration (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Element_Declaration; + + procedure Set_Element_Declaration (Target : Iir; El : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Element_Declaration (Get_Kind (Target))); + Set_Field2 (Target, El); + end Set_Element_Declaration; + + function Get_Selected_Element (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Selected_Element (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Selected_Element; + + procedure Set_Selected_Element (Target : Iir; El : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Selected_Element (Get_Kind (Target))); + Set_Field2 (Target, El); + end Set_Selected_Element; + + function Get_Use_Clause_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Use_Clause_Chain (Get_Kind (Target))); + return Get_Field3 (Target); + end Get_Use_Clause_Chain; + + procedure Set_Use_Clause_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Use_Clause_Chain (Get_Kind (Target))); + Set_Field3 (Target, Chain); + end Set_Use_Clause_Chain; + + function Get_Selected_Name (Target : Iir_Use_Clause) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Selected_Name (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Selected_Name; + + procedure Set_Selected_Name (Target : Iir_Use_Clause; Name : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Selected_Name (Get_Kind (Target))); + Set_Field1 (Target, Name); + end Set_Selected_Name; + + function Get_Type_Declarator (Def : Iir) return Iir is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Type_Declarator (Get_Kind (Def))); + return Get_Field3 (Def); + end Get_Type_Declarator; + + procedure Set_Type_Declarator (Def : Iir; Decl : Iir) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Type_Declarator (Get_Kind (Def))); + Set_Field3 (Def, Decl); + end Set_Type_Declarator; + + function Get_Enumeration_Literal_List (Target : Iir) return Iir_List is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Enumeration_Literal_List (Get_Kind (Target))); + return Iir_To_Iir_List (Get_Field2 (Target)); + end Get_Enumeration_Literal_List; + + procedure Set_Enumeration_Literal_List (Target : Iir; List : Iir_List) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Enumeration_Literal_List (Get_Kind (Target))); + Set_Field2 (Target, Iir_List_To_Iir (List)); + end Set_Enumeration_Literal_List; + + function Get_Entity_Class_Entry_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Entity_Class_Entry_Chain (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Entity_Class_Entry_Chain; + + procedure Set_Entity_Class_Entry_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Entity_Class_Entry_Chain (Get_Kind (Target))); + Set_Field1 (Target, Chain); + end Set_Entity_Class_Entry_Chain; + + function Get_Group_Constituent_List (Group : Iir) return Iir_List is + begin + pragma Assert (Group /= Null_Iir); + pragma Assert (Has_Group_Constituent_List (Get_Kind (Group))); + return Iir_To_Iir_List (Get_Field1 (Group)); + end Get_Group_Constituent_List; + + procedure Set_Group_Constituent_List (Group : Iir; List : Iir_List) is + begin + pragma Assert (Group /= Null_Iir); + pragma Assert (Has_Group_Constituent_List (Get_Kind (Group))); + Set_Field1 (Group, Iir_List_To_Iir (List)); + end Set_Group_Constituent_List; + + function Get_Unit_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Unit_Chain (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Unit_Chain; + + procedure Set_Unit_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Unit_Chain (Get_Kind (Target))); + Set_Field1 (Target, Chain); + end Set_Unit_Chain; + + function Get_Primary_Unit (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Primary_Unit (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Primary_Unit; + + procedure Set_Primary_Unit (Target : Iir; Unit : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Primary_Unit (Get_Kind (Target))); + Set_Field1 (Target, Unit); + end Set_Primary_Unit; + + function Get_Identifier (Target : Iir) return Name_Id is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Identifier (Get_Kind (Target))); + return Iir_To_Name_Id (Get_Field3 (Target)); + end Get_Identifier; + + procedure Set_Identifier (Target : Iir; Identifier : Name_Id) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Identifier (Get_Kind (Target))); + Set_Field3 (Target, Name_Id_To_Iir (Identifier)); + end Set_Identifier; + + function Get_Label (Target : Iir) return Name_Id is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Label (Get_Kind (Target))); + return Iir_To_Name_Id (Get_Field3 (Target)); + end Get_Label; + + procedure Set_Label (Target : Iir; Label : Name_Id) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Label (Get_Kind (Target))); + Set_Field3 (Target, Name_Id_To_Iir (Label)); + end Set_Label; + + function Get_Visible_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Visible_Flag (Get_Kind (Target))); + return Get_Flag4 (Target); + end Get_Visible_Flag; + + procedure Set_Visible_Flag (Target : Iir; Flag : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Visible_Flag (Get_Kind (Target))); + Set_Flag4 (Target, Flag); + end Set_Visible_Flag; + + function Get_Range_Constraint (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Range_Constraint (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Range_Constraint; + + procedure Set_Range_Constraint (Target : Iir; Constraint : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Range_Constraint (Get_Kind (Target))); + Set_Field1 (Target, Constraint); + end Set_Range_Constraint; + + function Get_Direction (Decl : Iir) return Iir_Direction is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Direction (Get_Kind (Decl))); + return Iir_Direction'Val (Get_State2 (Decl)); + end Get_Direction; + + procedure Set_Direction (Decl : Iir; Dir : Iir_Direction) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Direction (Get_Kind (Decl))); + Set_State2 (Decl, Iir_Direction'Pos (Dir)); + end Set_Direction; + + function Get_Left_Limit (Decl : Iir_Range_Expression) return Iir is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Left_Limit (Get_Kind (Decl))); + return Get_Field2 (Decl); + end Get_Left_Limit; + + procedure Set_Left_Limit (Decl : Iir_Range_Expression; Limit : Iir) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Left_Limit (Get_Kind (Decl))); + Set_Field2 (Decl, Limit); + end Set_Left_Limit; + + function Get_Right_Limit (Decl : Iir_Range_Expression) return Iir is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Right_Limit (Get_Kind (Decl))); + return Get_Field3 (Decl); + end Get_Right_Limit; + + procedure Set_Right_Limit (Decl : Iir_Range_Expression; Limit : Iir) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Right_Limit (Get_Kind (Decl))); + Set_Field3 (Decl, Limit); + end Set_Right_Limit; + + function Get_Base_Type (Decl : Iir) return Iir is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Base_Type (Get_Kind (Decl))); + return Get_Field4 (Decl); + end Get_Base_Type; + + procedure Set_Base_Type (Decl : Iir; Base_Type : Iir) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Base_Type (Get_Kind (Decl))); + Set_Field4 (Decl, Base_Type); + end Set_Base_Type; + + function Get_Resolution_Indication (Decl : Iir) return Iir is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Resolution_Indication (Get_Kind (Decl))); + return Get_Field5 (Decl); + end Get_Resolution_Indication; + + procedure Set_Resolution_Indication (Decl : Iir; Ind : Iir) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Resolution_Indication (Get_Kind (Decl))); + Set_Field5 (Decl, Ind); + end Set_Resolution_Indication; + + function Get_Record_Element_Resolution_Chain (Res : Iir) return Iir is + begin + pragma Assert (Res /= Null_Iir); + pragma Assert (Has_Record_Element_Resolution_Chain (Get_Kind (Res))); + return Get_Field1 (Res); + end Get_Record_Element_Resolution_Chain; + + procedure Set_Record_Element_Resolution_Chain (Res : Iir; Chain : Iir) is + begin + pragma Assert (Res /= Null_Iir); + pragma Assert (Has_Record_Element_Resolution_Chain (Get_Kind (Res))); + Set_Field1 (Res, Chain); + end Set_Record_Element_Resolution_Chain; + + function Get_Tolerance (Def : Iir) return Iir is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Tolerance (Get_Kind (Def))); + return Get_Field7 (Def); + end Get_Tolerance; + + procedure Set_Tolerance (Def : Iir; Tol : Iir) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Tolerance (Get_Kind (Def))); + Set_Field7 (Def, Tol); + end Set_Tolerance; + + function Get_Plus_Terminal (Def : Iir) return Iir is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Plus_Terminal (Get_Kind (Def))); + return Get_Field8 (Def); + end Get_Plus_Terminal; + + procedure Set_Plus_Terminal (Def : Iir; Terminal : Iir) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Plus_Terminal (Get_Kind (Def))); + Set_Field8 (Def, Terminal); + end Set_Plus_Terminal; + + function Get_Minus_Terminal (Def : Iir) return Iir is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Minus_Terminal (Get_Kind (Def))); + return Get_Field9 (Def); + end Get_Minus_Terminal; + + procedure Set_Minus_Terminal (Def : Iir; Terminal : Iir) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Minus_Terminal (Get_Kind (Def))); + Set_Field9 (Def, Terminal); + end Set_Minus_Terminal; + + function Get_Simultaneous_Left (Def : Iir) return Iir is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Simultaneous_Left (Get_Kind (Def))); + return Get_Field5 (Def); + end Get_Simultaneous_Left; + + procedure Set_Simultaneous_Left (Def : Iir; Expr : Iir) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Simultaneous_Left (Get_Kind (Def))); + Set_Field5 (Def, Expr); + end Set_Simultaneous_Left; + + function Get_Simultaneous_Right (Def : Iir) return Iir is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Simultaneous_Right (Get_Kind (Def))); + return Get_Field6 (Def); + end Get_Simultaneous_Right; + + procedure Set_Simultaneous_Right (Def : Iir; Expr : Iir) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Simultaneous_Right (Get_Kind (Def))); + Set_Field6 (Def, Expr); + end Set_Simultaneous_Right; + + function Get_Text_File_Flag (Atype : Iir) return Boolean is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Text_File_Flag (Get_Kind (Atype))); + return Get_Flag4 (Atype); + end Get_Text_File_Flag; + + procedure Set_Text_File_Flag (Atype : Iir; Flag : Boolean) is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Text_File_Flag (Get_Kind (Atype))); + Set_Flag4 (Atype, Flag); + end Set_Text_File_Flag; + + function Get_Only_Characters_Flag (Atype : Iir) return Boolean is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Only_Characters_Flag (Get_Kind (Atype))); + return Get_Flag4 (Atype); + end Get_Only_Characters_Flag; + + procedure Set_Only_Characters_Flag (Atype : Iir; Flag : Boolean) is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Only_Characters_Flag (Get_Kind (Atype))); + Set_Flag4 (Atype, Flag); + end Set_Only_Characters_Flag; + + function Get_Type_Staticness (Atype : Iir) return Iir_Staticness is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Type_Staticness (Get_Kind (Atype))); + return Iir_Staticness'Val (Get_State1 (Atype)); + end Get_Type_Staticness; + + procedure Set_Type_Staticness (Atype : Iir; Static : Iir_Staticness) is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Type_Staticness (Get_Kind (Atype))); + Set_State1 (Atype, Iir_Staticness'Pos (Static)); + end Set_Type_Staticness; + + function Get_Constraint_State (Atype : Iir) return Iir_Constraint is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Constraint_State (Get_Kind (Atype))); + return Iir_Constraint'Val (Get_State2 (Atype)); + end Get_Constraint_State; + + procedure Set_Constraint_State (Atype : Iir; State : Iir_Constraint) is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Constraint_State (Get_Kind (Atype))); + Set_State2 (Atype, Iir_Constraint'Pos (State)); + end Set_Constraint_State; + + function Get_Index_Subtype_List (Decl : Iir) return Iir_List is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Index_Subtype_List (Get_Kind (Decl))); + return Iir_To_Iir_List (Get_Field9 (Decl)); + end Get_Index_Subtype_List; + + procedure Set_Index_Subtype_List (Decl : Iir; List : Iir_List) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Index_Subtype_List (Get_Kind (Decl))); + Set_Field9 (Decl, Iir_List_To_Iir (List)); + end Set_Index_Subtype_List; + + function Get_Index_Subtype_Definition_List (Def : Iir) return Iir_List is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Index_Subtype_Definition_List (Get_Kind (Def))); + return Iir_To_Iir_List (Get_Field6 (Def)); + end Get_Index_Subtype_Definition_List; + + procedure Set_Index_Subtype_Definition_List (Def : Iir; Idx : Iir_List) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Index_Subtype_Definition_List (Get_Kind (Def))); + Set_Field6 (Def, Iir_List_To_Iir (Idx)); + end Set_Index_Subtype_Definition_List; + + function Get_Element_Subtype_Indication (Decl : Iir) return Iir is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Element_Subtype_Indication (Get_Kind (Decl))); + return Get_Field2 (Decl); + end Get_Element_Subtype_Indication; + + procedure Set_Element_Subtype_Indication (Decl : Iir; Sub_Type : Iir) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Element_Subtype_Indication (Get_Kind (Decl))); + Set_Field2 (Decl, Sub_Type); + end Set_Element_Subtype_Indication; + + function Get_Element_Subtype (Decl : Iir) return Iir is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Element_Subtype (Get_Kind (Decl))); + return Get_Field1 (Decl); + end Get_Element_Subtype; + + procedure Set_Element_Subtype (Decl : Iir; Sub_Type : Iir) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Element_Subtype (Get_Kind (Decl))); + Set_Field1 (Decl, Sub_Type); + end Set_Element_Subtype; + + function Get_Index_Constraint_List (Def : Iir) return Iir_List is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Index_Constraint_List (Get_Kind (Def))); + return Iir_To_Iir_List (Get_Field6 (Def)); + end Get_Index_Constraint_List; + + procedure Set_Index_Constraint_List (Def : Iir; List : Iir_List) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Index_Constraint_List (Get_Kind (Def))); + Set_Field6 (Def, Iir_List_To_Iir (List)); + end Set_Index_Constraint_List; + + function Get_Array_Element_Constraint (Def : Iir) return Iir is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Array_Element_Constraint (Get_Kind (Def))); + return Get_Field8 (Def); + end Get_Array_Element_Constraint; + + procedure Set_Array_Element_Constraint (Def : Iir; El : Iir) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Array_Element_Constraint (Get_Kind (Def))); + Set_Field8 (Def, El); + end Set_Array_Element_Constraint; + + function Get_Elements_Declaration_List (Decl : Iir) return Iir_List is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Elements_Declaration_List (Get_Kind (Decl))); + return Iir_To_Iir_List (Get_Field1 (Decl)); + end Get_Elements_Declaration_List; + + procedure Set_Elements_Declaration_List (Decl : Iir; List : Iir_List) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Elements_Declaration_List (Get_Kind (Decl))); + Set_Field1 (Decl, Iir_List_To_Iir (List)); + end Set_Elements_Declaration_List; + + function Get_Designated_Type (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Designated_Type (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Designated_Type; + + procedure Set_Designated_Type (Target : Iir; Dtype : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Designated_Type (Get_Kind (Target))); + Set_Field1 (Target, Dtype); + end Set_Designated_Type; + + function Get_Designated_Subtype_Indication (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Designated_Subtype_Indication (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Designated_Subtype_Indication; + + procedure Set_Designated_Subtype_Indication (Target : Iir; Dtype : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Designated_Subtype_Indication (Get_Kind (Target))); + Set_Field5 (Target, Dtype); + end Set_Designated_Subtype_Indication; + + function Get_Index_List (Decl : Iir) return Iir_List is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Index_List (Get_Kind (Decl))); + return Iir_To_Iir_List (Get_Field2 (Decl)); + end Get_Index_List; + + procedure Set_Index_List (Decl : Iir; List : Iir_List) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Index_List (Get_Kind (Decl))); + Set_Field2 (Decl, Iir_List_To_Iir (List)); + end Set_Index_List; + + function Get_Reference (Def : Iir) return Iir is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Reference (Get_Kind (Def))); + return Get_Field2 (Def); + end Get_Reference; + + procedure Set_Reference (Def : Iir; Ref : Iir) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Reference (Get_Kind (Def))); + Set_Field2 (Def, Ref); + end Set_Reference; + + function Get_Nature_Declarator (Def : Iir) return Iir is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Nature_Declarator (Get_Kind (Def))); + return Get_Field3 (Def); + end Get_Nature_Declarator; + + procedure Set_Nature_Declarator (Def : Iir; Decl : Iir) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Nature_Declarator (Get_Kind (Def))); + Set_Field3 (Def, Decl); + end Set_Nature_Declarator; + + function Get_Across_Type (Def : Iir) return Iir is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Across_Type (Get_Kind (Def))); + return Get_Field7 (Def); + end Get_Across_Type; + + procedure Set_Across_Type (Def : Iir; Atype : Iir) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Across_Type (Get_Kind (Def))); + Set_Field7 (Def, Atype); + end Set_Across_Type; + + function Get_Through_Type (Def : Iir) return Iir is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Through_Type (Get_Kind (Def))); + return Get_Field8 (Def); + end Get_Through_Type; + + procedure Set_Through_Type (Def : Iir; Atype : Iir) is + begin + pragma Assert (Def /= Null_Iir); + pragma Assert (Has_Through_Type (Get_Kind (Def))); + Set_Field8 (Def, Atype); + end Set_Through_Type; + + function Get_Target (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Target (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Target; + + procedure Set_Target (Target : Iir; Atarget : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Target (Get_Kind (Target))); + Set_Field1 (Target, Atarget); + end Set_Target; + + function Get_Waveform_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Waveform_Chain (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Waveform_Chain; + + procedure Set_Waveform_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Waveform_Chain (Get_Kind (Target))); + Set_Field5 (Target, Chain); + end Set_Waveform_Chain; + + function Get_Guard (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Guard (Get_Kind (Target))); + return Get_Field8 (Target); + end Get_Guard; + + procedure Set_Guard (Target : Iir; Guard : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Guard (Get_Kind (Target))); + Set_Field8 (Target, Guard); + end Set_Guard; + + function Get_Delay_Mechanism (Target : Iir) return Iir_Delay_Mechanism is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Delay_Mechanism (Get_Kind (Target))); + return Iir_Delay_Mechanism'Val (Get_Field12 (Target)); + end Get_Delay_Mechanism; + + procedure Set_Delay_Mechanism (Target : Iir; Kind : Iir_Delay_Mechanism) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Delay_Mechanism (Get_Kind (Target))); + Set_Field12 (Target, Iir_Delay_Mechanism'Pos (Kind)); + end Set_Delay_Mechanism; + + function Get_Reject_Time_Expression (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Reject_Time_Expression (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_Reject_Time_Expression; + + procedure Set_Reject_Time_Expression (Target : Iir; Expr : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Reject_Time_Expression (Get_Kind (Target))); + Set_Field6 (Target, Expr); + end Set_Reject_Time_Expression; + + function Get_Sensitivity_List (Wait : Iir) return Iir_List is + begin + pragma Assert (Wait /= Null_Iir); + pragma Assert (Has_Sensitivity_List (Get_Kind (Wait))); + return Iir_To_Iir_List (Get_Field6 (Wait)); + end Get_Sensitivity_List; + + procedure Set_Sensitivity_List (Wait : Iir; List : Iir_List) is + begin + pragma Assert (Wait /= Null_Iir); + pragma Assert (Has_Sensitivity_List (Get_Kind (Wait))); + Set_Field6 (Wait, Iir_List_To_Iir (List)); + end Set_Sensitivity_List; + + function Get_Process_Origin (Proc : Iir) return Iir is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_Process_Origin (Get_Kind (Proc))); + return Get_Field8 (Proc); + end Get_Process_Origin; + + procedure Set_Process_Origin (Proc : Iir; Orig : Iir) is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_Process_Origin (Get_Kind (Proc))); + Set_Field8 (Proc, Orig); + end Set_Process_Origin; + + function Get_Condition_Clause (Wait : Iir_Wait_Statement) return Iir is + begin + pragma Assert (Wait /= Null_Iir); + pragma Assert (Has_Condition_Clause (Get_Kind (Wait))); + return Get_Field5 (Wait); + end Get_Condition_Clause; + + procedure Set_Condition_Clause (Wait : Iir_Wait_Statement; Cond : Iir) is + begin + pragma Assert (Wait /= Null_Iir); + pragma Assert (Has_Condition_Clause (Get_Kind (Wait))); + Set_Field5 (Wait, Cond); + end Set_Condition_Clause; + + function Get_Timeout_Clause (Wait : Iir_Wait_Statement) return Iir is + begin + pragma Assert (Wait /= Null_Iir); + pragma Assert (Has_Timeout_Clause (Get_Kind (Wait))); + return Get_Field1 (Wait); + end Get_Timeout_Clause; + + procedure Set_Timeout_Clause (Wait : Iir_Wait_Statement; Timeout : Iir) is + begin + pragma Assert (Wait /= Null_Iir); + pragma Assert (Has_Timeout_Clause (Get_Kind (Wait))); + Set_Field1 (Wait, Timeout); + end Set_Timeout_Clause; + + function Get_Postponed_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Postponed_Flag (Get_Kind (Target))); + return Get_Flag3 (Target); + end Get_Postponed_Flag; + + procedure Set_Postponed_Flag (Target : Iir; Value : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Postponed_Flag (Get_Kind (Target))); + Set_Flag3 (Target, Value); + end Set_Postponed_Flag; + + function Get_Callees_List (Proc : Iir) return Iir_List is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_Callees_List (Get_Kind (Proc))); + return Iir_To_Iir_List (Get_Field7 (Proc)); + end Get_Callees_List; + + procedure Set_Callees_List (Proc : Iir; List : Iir_List) is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_Callees_List (Get_Kind (Proc))); + Set_Field7 (Proc, Iir_List_To_Iir (List)); + end Set_Callees_List; + + function Get_Passive_Flag (Proc : Iir) return Boolean is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_Passive_Flag (Get_Kind (Proc))); + return Get_Flag2 (Proc); + end Get_Passive_Flag; + + procedure Set_Passive_Flag (Proc : Iir; Flag : Boolean) is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_Passive_Flag (Get_Kind (Proc))); + Set_Flag2 (Proc, Flag); + end Set_Passive_Flag; + + function Get_Resolution_Function_Flag (Func : Iir) return Boolean is + begin + pragma Assert (Func /= Null_Iir); + pragma Assert (Has_Resolution_Function_Flag (Get_Kind (Func))); + return Get_Flag7 (Func); + end Get_Resolution_Function_Flag; + + procedure Set_Resolution_Function_Flag (Func : Iir; Flag : Boolean) is + begin + pragma Assert (Func /= Null_Iir); + pragma Assert (Has_Resolution_Function_Flag (Get_Kind (Func))); + Set_Flag7 (Func, Flag); + end Set_Resolution_Function_Flag; + + function Get_Wait_State (Proc : Iir) return Tri_State_Type is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_Wait_State (Get_Kind (Proc))); + return Tri_State_Type'Val (Get_State1 (Proc)); + end Get_Wait_State; + + procedure Set_Wait_State (Proc : Iir; State : Tri_State_Type) is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_Wait_State (Get_Kind (Proc))); + Set_State1 (Proc, Tri_State_Type'Pos (State)); + end Set_Wait_State; + + function Get_All_Sensitized_State (Proc : Iir) return Iir_All_Sensitized is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_All_Sensitized_State (Get_Kind (Proc))); + return Iir_All_Sensitized'Val (Get_State3 (Proc)); + end Get_All_Sensitized_State; + + procedure Set_All_Sensitized_State (Proc : Iir; State : Iir_All_Sensitized) + is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_All_Sensitized_State (Get_Kind (Proc))); + Set_State3 (Proc, Iir_All_Sensitized'Pos (State)); + end Set_All_Sensitized_State; + + function Get_Seen_Flag (Proc : Iir) return Boolean is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_Seen_Flag (Get_Kind (Proc))); + return Get_Flag1 (Proc); + end Get_Seen_Flag; + + procedure Set_Seen_Flag (Proc : Iir; Flag : Boolean) is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_Seen_Flag (Get_Kind (Proc))); + Set_Flag1 (Proc, Flag); + end Set_Seen_Flag; + + function Get_Pure_Flag (Func : Iir) return Boolean is + begin + pragma Assert (Func /= Null_Iir); + pragma Assert (Has_Pure_Flag (Get_Kind (Func))); + return Get_Flag2 (Func); + end Get_Pure_Flag; + + procedure Set_Pure_Flag (Func : Iir; Flag : Boolean) is + begin + pragma Assert (Func /= Null_Iir); + pragma Assert (Has_Pure_Flag (Get_Kind (Func))); + Set_Flag2 (Func, Flag); + end Set_Pure_Flag; + + function Get_Foreign_Flag (Decl : Iir) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Foreign_Flag (Get_Kind (Decl))); + return Get_Flag3 (Decl); + end Get_Foreign_Flag; + + procedure Set_Foreign_Flag (Decl : Iir; Flag : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Foreign_Flag (Get_Kind (Decl))); + Set_Flag3 (Decl, Flag); + end Set_Foreign_Flag; + + function Get_Resolved_Flag (Atype : Iir) return Boolean is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Resolved_Flag (Get_Kind (Atype))); + return Get_Flag1 (Atype); + end Get_Resolved_Flag; + + procedure Set_Resolved_Flag (Atype : Iir; Flag : Boolean) is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Resolved_Flag (Get_Kind (Atype))); + Set_Flag1 (Atype, Flag); + end Set_Resolved_Flag; + + function Get_Signal_Type_Flag (Atype : Iir) return Boolean is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Signal_Type_Flag (Get_Kind (Atype))); + return Get_Flag2 (Atype); + end Get_Signal_Type_Flag; + + procedure Set_Signal_Type_Flag (Atype : Iir; Flag : Boolean) is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Signal_Type_Flag (Get_Kind (Atype))); + Set_Flag2 (Atype, Flag); + end Set_Signal_Type_Flag; + + function Get_Has_Signal_Flag (Atype : Iir) return Boolean is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Has_Signal_Flag (Get_Kind (Atype))); + return Get_Flag3 (Atype); + end Get_Has_Signal_Flag; + + procedure Set_Has_Signal_Flag (Atype : Iir; Flag : Boolean) is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Has_Signal_Flag (Get_Kind (Atype))); + Set_Flag3 (Atype, Flag); + end Set_Has_Signal_Flag; + + function Get_Purity_State (Proc : Iir) return Iir_Pure_State is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_Purity_State (Get_Kind (Proc))); + return Iir_Pure_State'Val (Get_State2 (Proc)); + end Get_Purity_State; + + procedure Set_Purity_State (Proc : Iir; State : Iir_Pure_State) is + begin + pragma Assert (Proc /= Null_Iir); + pragma Assert (Has_Purity_State (Get_Kind (Proc))); + Set_State2 (Proc, Iir_Pure_State'Pos (State)); + end Set_Purity_State; + + function Get_Elab_Flag (Design : Iir) return Boolean is + begin + pragma Assert (Design /= Null_Iir); + pragma Assert (Has_Elab_Flag (Get_Kind (Design))); + return Get_Flag3 (Design); + end Get_Elab_Flag; + + procedure Set_Elab_Flag (Design : Iir; Flag : Boolean) is + begin + pragma Assert (Design /= Null_Iir); + pragma Assert (Has_Elab_Flag (Get_Kind (Design))); + Set_Flag3 (Design, Flag); + end Set_Elab_Flag; + + function Get_Index_Constraint_Flag (Atype : Iir) return Boolean is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Index_Constraint_Flag (Get_Kind (Atype))); + return Get_Flag4 (Atype); + end Get_Index_Constraint_Flag; + + procedure Set_Index_Constraint_Flag (Atype : Iir; Flag : Boolean) is + begin + pragma Assert (Atype /= Null_Iir); + pragma Assert (Has_Index_Constraint_Flag (Get_Kind (Atype))); + Set_Flag4 (Atype, Flag); + end Set_Index_Constraint_Flag; + + function Get_Assertion_Condition (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Assertion_Condition (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Assertion_Condition; + + procedure Set_Assertion_Condition (Target : Iir; Cond : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Assertion_Condition (Get_Kind (Target))); + Set_Field1 (Target, Cond); + end Set_Assertion_Condition; + + function Get_Report_Expression (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Report_Expression (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_Report_Expression; + + procedure Set_Report_Expression (Target : Iir; Expr : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Report_Expression (Get_Kind (Target))); + Set_Field6 (Target, Expr); + end Set_Report_Expression; + + function Get_Severity_Expression (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Severity_Expression (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Severity_Expression; + + procedure Set_Severity_Expression (Target : Iir; Expr : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Severity_Expression (Get_Kind (Target))); + Set_Field5 (Target, Expr); + end Set_Severity_Expression; + + function Get_Instantiated_Unit (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Instantiated_Unit (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Instantiated_Unit; + + procedure Set_Instantiated_Unit (Target : Iir; Unit : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Instantiated_Unit (Get_Kind (Target))); + Set_Field1 (Target, Unit); + end Set_Instantiated_Unit; + + function Get_Generic_Map_Aspect_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Generic_Map_Aspect_Chain (Get_Kind (Target))); + return Get_Field8 (Target); + end Get_Generic_Map_Aspect_Chain; + + procedure Set_Generic_Map_Aspect_Chain (Target : Iir; Generics : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Generic_Map_Aspect_Chain (Get_Kind (Target))); + Set_Field8 (Target, Generics); + end Set_Generic_Map_Aspect_Chain; + + function Get_Port_Map_Aspect_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Port_Map_Aspect_Chain (Get_Kind (Target))); + return Get_Field9 (Target); + end Get_Port_Map_Aspect_Chain; + + procedure Set_Port_Map_Aspect_Chain (Target : Iir; Port : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Port_Map_Aspect_Chain (Get_Kind (Target))); + Set_Field9 (Target, Port); + end Set_Port_Map_Aspect_Chain; + + function Get_Configuration_Name (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Configuration_Name (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Configuration_Name; + + procedure Set_Configuration_Name (Target : Iir; Conf : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Configuration_Name (Get_Kind (Target))); + Set_Field1 (Target, Conf); + end Set_Configuration_Name; + + function Get_Component_Configuration (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Component_Configuration (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_Component_Configuration; + + procedure Set_Component_Configuration (Target : Iir; Conf : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Component_Configuration (Get_Kind (Target))); + Set_Field6 (Target, Conf); + end Set_Component_Configuration; + + function Get_Configuration_Specification (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Configuration_Specification (Get_Kind (Target))); + return Get_Field7 (Target); + end Get_Configuration_Specification; + + procedure Set_Configuration_Specification (Target : Iir; Conf : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Configuration_Specification (Get_Kind (Target))); + Set_Field7 (Target, Conf); + end Set_Configuration_Specification; + + function Get_Default_Binding_Indication (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Default_Binding_Indication (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Default_Binding_Indication; + + procedure Set_Default_Binding_Indication (Target : Iir; Conf : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Default_Binding_Indication (Get_Kind (Target))); + Set_Field5 (Target, Conf); + end Set_Default_Binding_Indication; + + function Get_Default_Configuration_Declaration (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert + (Has_Default_Configuration_Declaration (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_Default_Configuration_Declaration; + + procedure Set_Default_Configuration_Declaration (Target : Iir; Conf : Iir) + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert + (Has_Default_Configuration_Declaration (Get_Kind (Target))); + Set_Field6 (Target, Conf); + end Set_Default_Configuration_Declaration; + + function Get_Expression (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Expression (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Expression; + + procedure Set_Expression (Target : Iir; Expr : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Expression (Get_Kind (Target))); + Set_Field5 (Target, Expr); + end Set_Expression; + + function Get_Allocator_Designated_Type (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Allocator_Designated_Type (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Allocator_Designated_Type; + + procedure Set_Allocator_Designated_Type (Target : Iir; A_Type : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Allocator_Designated_Type (Get_Kind (Target))); + Set_Field2 (Target, A_Type); + end Set_Allocator_Designated_Type; + + function Get_Selected_Waveform_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Selected_Waveform_Chain (Get_Kind (Target))); + return Get_Field7 (Target); + end Get_Selected_Waveform_Chain; + + procedure Set_Selected_Waveform_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Selected_Waveform_Chain (Get_Kind (Target))); + Set_Field7 (Target, Chain); + end Set_Selected_Waveform_Chain; + + function Get_Conditional_Waveform_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Conditional_Waveform_Chain (Get_Kind (Target))); + return Get_Field7 (Target); + end Get_Conditional_Waveform_Chain; + + procedure Set_Conditional_Waveform_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Conditional_Waveform_Chain (Get_Kind (Target))); + Set_Field7 (Target, Chain); + end Set_Conditional_Waveform_Chain; + + function Get_Guard_Expression (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Guard_Expression (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Guard_Expression; + + procedure Set_Guard_Expression (Target : Iir; Expr : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Guard_Expression (Get_Kind (Target))); + Set_Field2 (Target, Expr); + end Set_Guard_Expression; + + function Get_Guard_Decl (Target : Iir_Block_Statement) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Guard_Decl (Get_Kind (Target))); + return Get_Field8 (Target); + end Get_Guard_Decl; + + procedure Set_Guard_Decl (Target : Iir_Block_Statement; Decl : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Guard_Decl (Get_Kind (Target))); + Set_Field8 (Target, Decl); + end Set_Guard_Decl; + + function Get_Guard_Sensitivity_List (Guard : Iir) return Iir_List is + begin + pragma Assert (Guard /= Null_Iir); + pragma Assert (Has_Guard_Sensitivity_List (Get_Kind (Guard))); + return Iir_To_Iir_List (Get_Field6 (Guard)); + end Get_Guard_Sensitivity_List; + + procedure Set_Guard_Sensitivity_List (Guard : Iir; List : Iir_List) is + begin + pragma Assert (Guard /= Null_Iir); + pragma Assert (Has_Guard_Sensitivity_List (Get_Kind (Guard))); + Set_Field6 (Guard, Iir_List_To_Iir (List)); + end Set_Guard_Sensitivity_List; + + function Get_Block_Block_Configuration (Block : Iir) return Iir is + begin + pragma Assert (Block /= Null_Iir); + pragma Assert (Has_Block_Block_Configuration (Get_Kind (Block))); + return Get_Field6 (Block); + end Get_Block_Block_Configuration; + + procedure Set_Block_Block_Configuration (Block : Iir; Conf : Iir) is + begin + pragma Assert (Block /= Null_Iir); + pragma Assert (Has_Block_Block_Configuration (Get_Kind (Block))); + Set_Field6 (Block, Conf); + end Set_Block_Block_Configuration; + + function Get_Package_Header (Pkg : Iir) return Iir is + begin + pragma Assert (Pkg /= Null_Iir); + pragma Assert (Has_Package_Header (Get_Kind (Pkg))); + return Get_Field5 (Pkg); + end Get_Package_Header; + + procedure Set_Package_Header (Pkg : Iir; Header : Iir) is + begin + pragma Assert (Pkg /= Null_Iir); + pragma Assert (Has_Package_Header (Get_Kind (Pkg))); + Set_Field5 (Pkg, Header); + end Set_Package_Header; + + function Get_Block_Header (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Block_Header (Get_Kind (Target))); + return Get_Field7 (Target); + end Get_Block_Header; + + procedure Set_Block_Header (Target : Iir; Header : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Block_Header (Get_Kind (Target))); + Set_Field7 (Target, Header); + end Set_Block_Header; + + function Get_Uninstantiated_Package_Name (Inst : Iir) return Iir is + begin + pragma Assert (Inst /= Null_Iir); + pragma Assert (Has_Uninstantiated_Package_Name (Get_Kind (Inst))); + return Get_Field5 (Inst); + end Get_Uninstantiated_Package_Name; + + procedure Set_Uninstantiated_Package_Name (Inst : Iir; Name : Iir) is + begin + pragma Assert (Inst /= Null_Iir); + pragma Assert (Has_Uninstantiated_Package_Name (Get_Kind (Inst))); + Set_Field5 (Inst, Name); + end Set_Uninstantiated_Package_Name; + + function Get_Generate_Block_Configuration (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Generate_Block_Configuration (Get_Kind (Target))); + return Get_Field7 (Target); + end Get_Generate_Block_Configuration; + + procedure Set_Generate_Block_Configuration (Target : Iir; Conf : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Generate_Block_Configuration (Get_Kind (Target))); + Set_Field7 (Target, Conf); + end Set_Generate_Block_Configuration; + + function Get_Generation_Scheme (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Generation_Scheme (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_Generation_Scheme; + + procedure Set_Generation_Scheme (Target : Iir; Scheme : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Generation_Scheme (Get_Kind (Target))); + Set_Field6 (Target, Scheme); + end Set_Generation_Scheme; + + function Get_Condition (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Condition (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Condition; + + procedure Set_Condition (Target : Iir; Condition : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Condition (Get_Kind (Target))); + Set_Field1 (Target, Condition); + end Set_Condition; + + function Get_Else_Clause (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Else_Clause (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_Else_Clause; + + procedure Set_Else_Clause (Target : Iir; Clause : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Else_Clause (Get_Kind (Target))); + Set_Field6 (Target, Clause); + end Set_Else_Clause; + + function Get_Parameter_Specification (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Parameter_Specification (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Parameter_Specification; + + procedure Set_Parameter_Specification (Target : Iir; Param : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Parameter_Specification (Get_Kind (Target))); + Set_Field1 (Target, Param); + end Set_Parameter_Specification; + + function Get_Parent (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Parent (Get_Kind (Target))); + return Get_Field0 (Target); + end Get_Parent; + + procedure Set_Parent (Target : Iir; Parent : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Parent (Get_Kind (Target))); + Set_Field0 (Target, Parent); + end Set_Parent; + + function Get_Loop_Label (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Loop_Label (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Loop_Label; + + procedure Set_Loop_Label (Target : Iir; Stmt : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Loop_Label (Get_Kind (Target))); + Set_Field5 (Target, Stmt); + end Set_Loop_Label; + + function Get_Component_Name (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Component_Name (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Component_Name; + + procedure Set_Component_Name (Target : Iir; Name : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Component_Name (Get_Kind (Target))); + Set_Field4 (Target, Name); + end Set_Component_Name; + + function Get_Instantiation_List (Target : Iir) return Iir_List is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Instantiation_List (Get_Kind (Target))); + return Iir_To_Iir_List (Get_Field1 (Target)); + end Get_Instantiation_List; + + procedure Set_Instantiation_List (Target : Iir; List : Iir_List) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Instantiation_List (Get_Kind (Target))); + Set_Field1 (Target, Iir_List_To_Iir (List)); + end Set_Instantiation_List; + + function Get_Entity_Aspect (Target : Iir_Binding_Indication) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Entity_Aspect (Get_Kind (Target))); + return Get_Field3 (Target); + end Get_Entity_Aspect; + + procedure Set_Entity_Aspect (Target : Iir_Binding_Indication; Entity : Iir) + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Entity_Aspect (Get_Kind (Target))); + Set_Field3 (Target, Entity); + end Set_Entity_Aspect; + + function Get_Default_Entity_Aspect (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Default_Entity_Aspect (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Default_Entity_Aspect; + + procedure Set_Default_Entity_Aspect (Target : Iir; Aspect : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Default_Entity_Aspect (Get_Kind (Target))); + Set_Field1 (Target, Aspect); + end Set_Default_Entity_Aspect; + + function Get_Default_Generic_Map_Aspect_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Default_Generic_Map_Aspect_Chain (Get_Kind (Target))); + return Get_Field6 (Target); + end Get_Default_Generic_Map_Aspect_Chain; + + procedure Set_Default_Generic_Map_Aspect_Chain (Target : Iir; Chain : Iir) + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Default_Generic_Map_Aspect_Chain (Get_Kind (Target))); + Set_Field6 (Target, Chain); + end Set_Default_Generic_Map_Aspect_Chain; + + function Get_Default_Port_Map_Aspect_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Default_Port_Map_Aspect_Chain (Get_Kind (Target))); + return Get_Field7 (Target); + end Get_Default_Port_Map_Aspect_Chain; + + procedure Set_Default_Port_Map_Aspect_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Default_Port_Map_Aspect_Chain (Get_Kind (Target))); + Set_Field7 (Target, Chain); + end Set_Default_Port_Map_Aspect_Chain; + + function Get_Binding_Indication (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Binding_Indication (Get_Kind (Target))); + return Get_Field3 (Target); + end Get_Binding_Indication; + + procedure Set_Binding_Indication (Target : Iir; Binding : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Binding_Indication (Get_Kind (Target))); + Set_Field3 (Target, Binding); + end Set_Binding_Indication; + + function Get_Named_Entity (Name : Iir) return Iir is + begin + pragma Assert (Name /= Null_Iir); + pragma Assert (Has_Named_Entity (Get_Kind (Name))); + return Get_Field4 (Name); + end Get_Named_Entity; + + procedure Set_Named_Entity (Name : Iir; Val : Iir) is + begin + pragma Assert (Name /= Null_Iir); + pragma Assert (Has_Named_Entity (Get_Kind (Name))); + Set_Field4 (Name, Val); + end Set_Named_Entity; + + function Get_Alias_Declaration (Name : Iir) return Iir is + begin + pragma Assert (Name /= Null_Iir); + pragma Assert (Has_Alias_Declaration (Get_Kind (Name))); + return Get_Field2 (Name); + end Get_Alias_Declaration; + + procedure Set_Alias_Declaration (Name : Iir; Val : Iir) is + begin + pragma Assert (Name /= Null_Iir); + pragma Assert (Has_Alias_Declaration (Get_Kind (Name))); + Set_Field2 (Name, Val); + end Set_Alias_Declaration; + + function Get_Expr_Staticness (Target : Iir) return Iir_Staticness is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Expr_Staticness (Get_Kind (Target))); + return Iir_Staticness'Val (Get_State1 (Target)); + end Get_Expr_Staticness; + + procedure Set_Expr_Staticness (Target : Iir; Static : Iir_Staticness) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Expr_Staticness (Get_Kind (Target))); + Set_State1 (Target, Iir_Staticness'Pos (Static)); + end Set_Expr_Staticness; + + function Get_Error_Origin (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Error_Origin (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Error_Origin; + + procedure Set_Error_Origin (Target : Iir; Origin : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Error_Origin (Get_Kind (Target))); + Set_Field2 (Target, Origin); + end Set_Error_Origin; + + function Get_Operand (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Operand (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Operand; + + procedure Set_Operand (Target : Iir; An_Iir : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Operand (Get_Kind (Target))); + Set_Field2 (Target, An_Iir); + end Set_Operand; + + function Get_Left (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Left (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Left; + + procedure Set_Left (Target : Iir; An_Iir : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Left (Get_Kind (Target))); + Set_Field2 (Target, An_Iir); + end Set_Left; + + function Get_Right (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Right (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Right; + + procedure Set_Right (Target : Iir; An_Iir : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Right (Get_Kind (Target))); + Set_Field4 (Target, An_Iir); + end Set_Right; + + function Get_Unit_Name (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Unit_Name (Get_Kind (Target))); + return Get_Field3 (Target); + end Get_Unit_Name; + + procedure Set_Unit_Name (Target : Iir; Name : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Unit_Name (Get_Kind (Target))); + Set_Field3 (Target, Name); + end Set_Unit_Name; + + function Get_Name (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Name (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Name; + + procedure Set_Name (Target : Iir; Name : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Name (Get_Kind (Target))); + Set_Field4 (Target, Name); + end Set_Name; + + function Get_Group_Template_Name (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Group_Template_Name (Get_Kind (Target))); + return Get_Field5 (Target); + end Get_Group_Template_Name; + + procedure Set_Group_Template_Name (Target : Iir; Name : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Group_Template_Name (Get_Kind (Target))); + Set_Field5 (Target, Name); + end Set_Group_Template_Name; + + function Get_Name_Staticness (Target : Iir) return Iir_Staticness is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Name_Staticness (Get_Kind (Target))); + return Iir_Staticness'Val (Get_State2 (Target)); + end Get_Name_Staticness; + + procedure Set_Name_Staticness (Target : Iir; Static : Iir_Staticness) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Name_Staticness (Get_Kind (Target))); + Set_State2 (Target, Iir_Staticness'Pos (Static)); + end Set_Name_Staticness; + + function Get_Prefix (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Prefix (Get_Kind (Target))); + return Get_Field0 (Target); + end Get_Prefix; + + procedure Set_Prefix (Target : Iir; Prefix : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Prefix (Get_Kind (Target))); + Set_Field0 (Target, Prefix); + end Set_Prefix; + + function Get_Signature_Prefix (Sign : Iir) return Iir is + begin + pragma Assert (Sign /= Null_Iir); + pragma Assert (Has_Signature_Prefix (Get_Kind (Sign))); + return Get_Field1 (Sign); + end Get_Signature_Prefix; + + procedure Set_Signature_Prefix (Sign : Iir; Prefix : Iir) is + begin + pragma Assert (Sign /= Null_Iir); + pragma Assert (Has_Signature_Prefix (Get_Kind (Sign))); + Set_Field1 (Sign, Prefix); + end Set_Signature_Prefix; + + function Get_Slice_Subtype (Slice : Iir) return Iir is + begin + pragma Assert (Slice /= Null_Iir); + pragma Assert (Has_Slice_Subtype (Get_Kind (Slice))); + return Get_Field3 (Slice); + end Get_Slice_Subtype; + + procedure Set_Slice_Subtype (Slice : Iir; Atype : Iir) is + begin + pragma Assert (Slice /= Null_Iir); + pragma Assert (Has_Slice_Subtype (Get_Kind (Slice))); + Set_Field3 (Slice, Atype); + end Set_Slice_Subtype; + + function Get_Suffix (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Suffix (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Suffix; + + procedure Set_Suffix (Target : Iir; Suffix : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Suffix (Get_Kind (Target))); + Set_Field2 (Target, Suffix); + end Set_Suffix; + + function Get_Index_Subtype (Attr : Iir) return Iir is + begin + pragma Assert (Attr /= Null_Iir); + pragma Assert (Has_Index_Subtype (Get_Kind (Attr))); + return Get_Field2 (Attr); + end Get_Index_Subtype; + + procedure Set_Index_Subtype (Attr : Iir; St : Iir) is + begin + pragma Assert (Attr /= Null_Iir); + pragma Assert (Has_Index_Subtype (Get_Kind (Attr))); + Set_Field2 (Attr, St); + end Set_Index_Subtype; + + function Get_Parameter (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Parameter (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Parameter; + + procedure Set_Parameter (Target : Iir; Param : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Parameter (Get_Kind (Target))); + Set_Field4 (Target, Param); + end Set_Parameter; + + function Get_Actual_Type (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Actual_Type (Get_Kind (Target))); + return Get_Field3 (Target); + end Get_Actual_Type; + + procedure Set_Actual_Type (Target : Iir; Atype : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Actual_Type (Get_Kind (Target))); + Set_Field3 (Target, Atype); + end Set_Actual_Type; + + function Get_Associated_Interface (Assoc : Iir) return Iir is + begin + pragma Assert (Assoc /= Null_Iir); + pragma Assert (Has_Associated_Interface (Get_Kind (Assoc))); + return Get_Field4 (Assoc); + end Get_Associated_Interface; + + procedure Set_Associated_Interface (Assoc : Iir; Inter : Iir) is + begin + pragma Assert (Assoc /= Null_Iir); + pragma Assert (Has_Associated_Interface (Get_Kind (Assoc))); + Set_Field4 (Assoc, Inter); + end Set_Associated_Interface; + + function Get_Association_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Association_Chain (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Association_Chain; + + procedure Set_Association_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Association_Chain (Get_Kind (Target))); + Set_Field2 (Target, Chain); + end Set_Association_Chain; + + function Get_Individual_Association_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Individual_Association_Chain (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Individual_Association_Chain; + + procedure Set_Individual_Association_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Individual_Association_Chain (Get_Kind (Target))); + Set_Field4 (Target, Chain); + end Set_Individual_Association_Chain; + + function Get_Aggregate_Info (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Aggregate_Info (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Aggregate_Info; + + procedure Set_Aggregate_Info (Target : Iir; Info : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Aggregate_Info (Get_Kind (Target))); + Set_Field2 (Target, Info); + end Set_Aggregate_Info; + + function Get_Sub_Aggregate_Info (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Sub_Aggregate_Info (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Sub_Aggregate_Info; + + procedure Set_Sub_Aggregate_Info (Target : Iir; Info : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Sub_Aggregate_Info (Get_Kind (Target))); + Set_Field1 (Target, Info); + end Set_Sub_Aggregate_Info; + + function Get_Aggr_Dynamic_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Aggr_Dynamic_Flag (Get_Kind (Target))); + return Get_Flag3 (Target); + end Get_Aggr_Dynamic_Flag; + + procedure Set_Aggr_Dynamic_Flag (Target : Iir; Val : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Aggr_Dynamic_Flag (Get_Kind (Target))); + Set_Flag3 (Target, Val); + end Set_Aggr_Dynamic_Flag; + + function Get_Aggr_Min_Length (Info : Iir_Aggregate_Info) return Iir_Int32 + is + begin + pragma Assert (Info /= Null_Iir); + pragma Assert (Has_Aggr_Min_Length (Get_Kind (Info))); + return Iir_To_Iir_Int32 (Get_Field4 (Info)); + end Get_Aggr_Min_Length; + + procedure Set_Aggr_Min_Length (Info : Iir_Aggregate_Info; Nbr : Iir_Int32) + is + begin + pragma Assert (Info /= Null_Iir); + pragma Assert (Has_Aggr_Min_Length (Get_Kind (Info))); + Set_Field4 (Info, Iir_Int32_To_Iir (Nbr)); + end Set_Aggr_Min_Length; + + function Get_Aggr_Low_Limit (Target : Iir_Aggregate_Info) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Aggr_Low_Limit (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Aggr_Low_Limit; + + procedure Set_Aggr_Low_Limit (Target : Iir_Aggregate_Info; Limit : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Aggr_Low_Limit (Get_Kind (Target))); + Set_Field2 (Target, Limit); + end Set_Aggr_Low_Limit; + + function Get_Aggr_High_Limit (Target : Iir_Aggregate_Info) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Aggr_High_Limit (Get_Kind (Target))); + return Get_Field3 (Target); + end Get_Aggr_High_Limit; + + procedure Set_Aggr_High_Limit (Target : Iir_Aggregate_Info; Limit : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Aggr_High_Limit (Get_Kind (Target))); + Set_Field3 (Target, Limit); + end Set_Aggr_High_Limit; + + function Get_Aggr_Others_Flag (Target : Iir_Aggregate_Info) return Boolean + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Aggr_Others_Flag (Get_Kind (Target))); + return Get_Flag2 (Target); + end Get_Aggr_Others_Flag; + + procedure Set_Aggr_Others_Flag (Target : Iir_Aggregate_Info; Val : Boolean) + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Aggr_Others_Flag (Get_Kind (Target))); + Set_Flag2 (Target, Val); + end Set_Aggr_Others_Flag; + + function Get_Aggr_Named_Flag (Target : Iir_Aggregate_Info) return Boolean + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Aggr_Named_Flag (Get_Kind (Target))); + return Get_Flag4 (Target); + end Get_Aggr_Named_Flag; + + procedure Set_Aggr_Named_Flag (Target : Iir_Aggregate_Info; Val : Boolean) + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Aggr_Named_Flag (Get_Kind (Target))); + Set_Flag4 (Target, Val); + end Set_Aggr_Named_Flag; + + function Get_Value_Staticness (Target : Iir) return Iir_Staticness is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Value_Staticness (Get_Kind (Target))); + return Iir_Staticness'Val (Get_State2 (Target)); + end Get_Value_Staticness; + + procedure Set_Value_Staticness (Target : Iir; Staticness : Iir_Staticness) + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Value_Staticness (Get_Kind (Target))); + Set_State2 (Target, Iir_Staticness'Pos (Staticness)); + end Set_Value_Staticness; + + function Get_Association_Choices_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Association_Choices_Chain (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Association_Choices_Chain; + + procedure Set_Association_Choices_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Association_Choices_Chain (Get_Kind (Target))); + Set_Field4 (Target, Chain); + end Set_Association_Choices_Chain; + + function Get_Case_Statement_Alternative_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Case_Statement_Alternative_Chain (Get_Kind (Target))); + return Get_Field1 (Target); + end Get_Case_Statement_Alternative_Chain; + + procedure Set_Case_Statement_Alternative_Chain (Target : Iir; Chain : Iir) + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Case_Statement_Alternative_Chain (Get_Kind (Target))); + Set_Field1 (Target, Chain); + end Set_Case_Statement_Alternative_Chain; + + function Get_Choice_Staticness (Target : Iir) return Iir_Staticness is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Choice_Staticness (Get_Kind (Target))); + return Iir_Staticness'Val (Get_State2 (Target)); + end Get_Choice_Staticness; + + procedure Set_Choice_Staticness (Target : Iir; Staticness : Iir_Staticness) + is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Choice_Staticness (Get_Kind (Target))); + Set_State2 (Target, Iir_Staticness'Pos (Staticness)); + end Set_Choice_Staticness; + + function Get_Procedure_Call (Stmt : Iir) return Iir is + begin + pragma Assert (Stmt /= Null_Iir); + pragma Assert (Has_Procedure_Call (Get_Kind (Stmt))); + return Get_Field1 (Stmt); + end Get_Procedure_Call; + + procedure Set_Procedure_Call (Stmt : Iir; Call : Iir) is + begin + pragma Assert (Stmt /= Null_Iir); + pragma Assert (Has_Procedure_Call (Get_Kind (Stmt))); + Set_Field1 (Stmt, Call); + end Set_Procedure_Call; + + function Get_Implementation (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Implementation (Get_Kind (Target))); + return Get_Field3 (Target); + end Get_Implementation; + + procedure Set_Implementation (Target : Iir; Decl : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Implementation (Get_Kind (Target))); + Set_Field3 (Target, Decl); + end Set_Implementation; + + function Get_Parameter_Association_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Parameter_Association_Chain (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Parameter_Association_Chain; + + procedure Set_Parameter_Association_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Parameter_Association_Chain (Get_Kind (Target))); + Set_Field2 (Target, Chain); + end Set_Parameter_Association_Chain; + + function Get_Method_Object (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Method_Object (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Method_Object; + + procedure Set_Method_Object (Target : Iir; Object : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Method_Object (Get_Kind (Target))); + Set_Field4 (Target, Object); + end Set_Method_Object; + + function Get_Subtype_Type_Mark (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subtype_Type_Mark (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Subtype_Type_Mark; + + procedure Set_Subtype_Type_Mark (Target : Iir; Mark : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subtype_Type_Mark (Get_Kind (Target))); + Set_Field2 (Target, Mark); + end Set_Subtype_Type_Mark; + + function Get_Type_Conversion_Subtype (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Type_Conversion_Subtype (Get_Kind (Target))); + return Get_Field3 (Target); + end Get_Type_Conversion_Subtype; + + procedure Set_Type_Conversion_Subtype (Target : Iir; Atype : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Type_Conversion_Subtype (Get_Kind (Target))); + Set_Field3 (Target, Atype); + end Set_Type_Conversion_Subtype; + + function Get_Type_Mark (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Type_Mark (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Type_Mark; + + procedure Set_Type_Mark (Target : Iir; Mark : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Type_Mark (Get_Kind (Target))); + Set_Field4 (Target, Mark); + end Set_Type_Mark; + + function Get_File_Type_Mark (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_File_Type_Mark (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_File_Type_Mark; + + procedure Set_File_Type_Mark (Target : Iir; Mark : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_File_Type_Mark (Get_Kind (Target))); + Set_Field2 (Target, Mark); + end Set_File_Type_Mark; + + function Get_Return_Type_Mark (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Return_Type_Mark (Get_Kind (Target))); + return Get_Field8 (Target); + end Get_Return_Type_Mark; + + procedure Set_Return_Type_Mark (Target : Iir; Mark : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Return_Type_Mark (Get_Kind (Target))); + Set_Field8 (Target, Mark); + end Set_Return_Type_Mark; + + function Get_Lexical_Layout (Decl : Iir) return Iir_Lexical_Layout_Type is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Lexical_Layout (Get_Kind (Decl))); + return Iir_Lexical_Layout_Type'Val (Get_Odigit2 (Decl)); + end Get_Lexical_Layout; + + procedure Set_Lexical_Layout (Decl : Iir; Lay : Iir_Lexical_Layout_Type) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Lexical_Layout (Get_Kind (Decl))); + Set_Odigit2 (Decl, Iir_Lexical_Layout_Type'Pos (Lay)); + end Set_Lexical_Layout; + + function Get_Incomplete_Type_List (Target : Iir) return Iir_List is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Incomplete_Type_List (Get_Kind (Target))); + return Iir_To_Iir_List (Get_Field2 (Target)); + end Get_Incomplete_Type_List; + + procedure Set_Incomplete_Type_List (Target : Iir; List : Iir_List) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Incomplete_Type_List (Get_Kind (Target))); + Set_Field2 (Target, Iir_List_To_Iir (List)); + end Set_Incomplete_Type_List; + + function Get_Has_Disconnect_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Has_Disconnect_Flag (Get_Kind (Target))); + return Get_Flag1 (Target); + end Get_Has_Disconnect_Flag; + + procedure Set_Has_Disconnect_Flag (Target : Iir; Val : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Has_Disconnect_Flag (Get_Kind (Target))); + Set_Flag1 (Target, Val); + end Set_Has_Disconnect_Flag; + + function Get_Has_Active_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Has_Active_Flag (Get_Kind (Target))); + return Get_Flag2 (Target); + end Get_Has_Active_Flag; + + procedure Set_Has_Active_Flag (Target : Iir; Val : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Has_Active_Flag (Get_Kind (Target))); + Set_Flag2 (Target, Val); + end Set_Has_Active_Flag; + + function Get_Is_Within_Flag (Target : Iir) return Boolean is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Is_Within_Flag (Get_Kind (Target))); + return Get_Flag5 (Target); + end Get_Is_Within_Flag; + + procedure Set_Is_Within_Flag (Target : Iir; Val : Boolean) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Is_Within_Flag (Get_Kind (Target))); + Set_Flag5 (Target, Val); + end Set_Is_Within_Flag; + + function Get_Type_Marks_List (Target : Iir) return Iir_List is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Type_Marks_List (Get_Kind (Target))); + return Iir_To_Iir_List (Get_Field2 (Target)); + end Get_Type_Marks_List; + + procedure Set_Type_Marks_List (Target : Iir; List : Iir_List) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Type_Marks_List (Get_Kind (Target))); + Set_Field2 (Target, Iir_List_To_Iir (List)); + end Set_Type_Marks_List; + + function Get_Implicit_Alias_Flag (Decl : Iir) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Implicit_Alias_Flag (Get_Kind (Decl))); + return Get_Flag1 (Decl); + end Get_Implicit_Alias_Flag; + + procedure Set_Implicit_Alias_Flag (Decl : Iir; Flag : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Implicit_Alias_Flag (Get_Kind (Decl))); + Set_Flag1 (Decl, Flag); + end Set_Implicit_Alias_Flag; + + function Get_Alias_Signature (Alias : Iir) return Iir is + begin + pragma Assert (Alias /= Null_Iir); + pragma Assert (Has_Alias_Signature (Get_Kind (Alias))); + return Get_Field5 (Alias); + end Get_Alias_Signature; + + procedure Set_Alias_Signature (Alias : Iir; Signature : Iir) is + begin + pragma Assert (Alias /= Null_Iir); + pragma Assert (Has_Alias_Signature (Get_Kind (Alias))); + Set_Field5 (Alias, Signature); + end Set_Alias_Signature; + + function Get_Attribute_Signature (Attr : Iir) return Iir is + begin + pragma Assert (Attr /= Null_Iir); + pragma Assert (Has_Attribute_Signature (Get_Kind (Attr))); + return Get_Field2 (Attr); + end Get_Attribute_Signature; + + procedure Set_Attribute_Signature (Attr : Iir; Signature : Iir) is + begin + pragma Assert (Attr /= Null_Iir); + pragma Assert (Has_Attribute_Signature (Get_Kind (Attr))); + Set_Field2 (Attr, Signature); + end Set_Attribute_Signature; + + function Get_Overload_List (Target : Iir) return Iir_List is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Overload_List (Get_Kind (Target))); + return Iir_To_Iir_List (Get_Field1 (Target)); + end Get_Overload_List; + + procedure Set_Overload_List (Target : Iir; List : Iir_List) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Overload_List (Get_Kind (Target))); + Set_Field1 (Target, Iir_List_To_Iir (List)); + end Set_Overload_List; + + function Get_Simple_Name_Identifier (Target : Iir) return Name_Id is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Simple_Name_Identifier (Get_Kind (Target))); + return Iir_To_Name_Id (Get_Field3 (Target)); + end Get_Simple_Name_Identifier; + + procedure Set_Simple_Name_Identifier (Target : Iir; Ident : Name_Id) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Simple_Name_Identifier (Get_Kind (Target))); + Set_Field3 (Target, Name_Id_To_Iir (Ident)); + end Set_Simple_Name_Identifier; + + function Get_Simple_Name_Subtype (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Simple_Name_Subtype (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Simple_Name_Subtype; + + procedure Set_Simple_Name_Subtype (Target : Iir; Atype : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Simple_Name_Subtype (Get_Kind (Target))); + Set_Field4 (Target, Atype); + end Set_Simple_Name_Subtype; + + function Get_Protected_Type_Body (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Protected_Type_Body (Get_Kind (Target))); + return Get_Field2 (Target); + end Get_Protected_Type_Body; + + procedure Set_Protected_Type_Body (Target : Iir; Bod : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Protected_Type_Body (Get_Kind (Target))); + Set_Field2 (Target, Bod); + end Set_Protected_Type_Body; + + function Get_Protected_Type_Declaration (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Protected_Type_Declaration (Get_Kind (Target))); + return Get_Field4 (Target); + end Get_Protected_Type_Declaration; + + procedure Set_Protected_Type_Declaration (Target : Iir; Decl : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Protected_Type_Declaration (Get_Kind (Target))); + Set_Field4 (Target, Decl); + end Set_Protected_Type_Declaration; + + function Get_End_Location (Target : Iir) return Location_Type is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_End_Location (Get_Kind (Target))); + return Iir_To_Location_Type (Get_Field6 (Target)); + end Get_End_Location; + + procedure Set_End_Location (Target : Iir; Loc : Location_Type) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_End_Location (Get_Kind (Target))); + Set_Field6 (Target, Location_Type_To_Iir (Loc)); + end Set_End_Location; + + function Get_String_Id (Lit : Iir) return String_Id is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_String_Id (Get_Kind (Lit))); + return Iir_To_String_Id (Get_Field3 (Lit)); + end Get_String_Id; + + procedure Set_String_Id (Lit : Iir; Id : String_Id) is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_String_Id (Get_Kind (Lit))); + Set_Field3 (Lit, String_Id_To_Iir (Id)); + end Set_String_Id; + + function Get_String_Length (Lit : Iir) return Int32 is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_String_Length (Get_Kind (Lit))); + return Iir_To_Int32 (Get_Field4 (Lit)); + end Get_String_Length; + + procedure Set_String_Length (Lit : Iir; Len : Int32) is + begin + pragma Assert (Lit /= Null_Iir); + pragma Assert (Has_String_Length (Get_Kind (Lit))); + Set_Field4 (Lit, Int32_To_Iir (Len)); + end Set_String_Length; + + function Get_Use_Flag (Decl : Iir) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Use_Flag (Get_Kind (Decl))); + return Get_Flag6 (Decl); + end Get_Use_Flag; + + procedure Set_Use_Flag (Decl : Iir; Val : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Use_Flag (Get_Kind (Decl))); + Set_Flag6 (Decl, Val); + end Set_Use_Flag; + + function Get_End_Has_Reserved_Id (Decl : Iir) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_End_Has_Reserved_Id (Get_Kind (Decl))); + return Get_Flag8 (Decl); + end Get_End_Has_Reserved_Id; + + procedure Set_End_Has_Reserved_Id (Decl : Iir; Flag : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_End_Has_Reserved_Id (Get_Kind (Decl))); + Set_Flag8 (Decl, Flag); + end Set_End_Has_Reserved_Id; + + function Get_End_Has_Identifier (Decl : Iir) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_End_Has_Identifier (Get_Kind (Decl))); + return Get_Flag9 (Decl); + end Get_End_Has_Identifier; + + procedure Set_End_Has_Identifier (Decl : Iir; Flag : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_End_Has_Identifier (Get_Kind (Decl))); + Set_Flag9 (Decl, Flag); + end Set_End_Has_Identifier; + + function Get_End_Has_Postponed (Decl : Iir) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_End_Has_Postponed (Get_Kind (Decl))); + return Get_Flag10 (Decl); + end Get_End_Has_Postponed; + + procedure Set_End_Has_Postponed (Decl : Iir; Flag : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_End_Has_Postponed (Get_Kind (Decl))); + Set_Flag10 (Decl, Flag); + end Set_End_Has_Postponed; + + function Get_Has_Begin (Decl : Iir) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Has_Begin (Get_Kind (Decl))); + return Get_Flag10 (Decl); + end Get_Has_Begin; + + procedure Set_Has_Begin (Decl : Iir; Flag : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Has_Begin (Get_Kind (Decl))); + Set_Flag10 (Decl, Flag); + end Set_Has_Begin; + + function Get_Has_Is (Decl : Iir) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Has_Is (Get_Kind (Decl))); + return Get_Flag7 (Decl); + end Get_Has_Is; + + procedure Set_Has_Is (Decl : Iir; Flag : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Has_Is (Get_Kind (Decl))); + Set_Flag7 (Decl, Flag); + end Set_Has_Is; + + function Get_Has_Pure (Decl : Iir) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Has_Pure (Get_Kind (Decl))); + return Get_Flag8 (Decl); + end Get_Has_Pure; + + procedure Set_Has_Pure (Decl : Iir; Flag : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Has_Pure (Get_Kind (Decl))); + Set_Flag8 (Decl, Flag); + end Set_Has_Pure; + + function Get_Has_Body (Decl : Iir) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Has_Body (Get_Kind (Decl))); + return Get_Flag9 (Decl); + end Get_Has_Body; + + procedure Set_Has_Body (Decl : Iir; Flag : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Has_Body (Get_Kind (Decl))); + Set_Flag9 (Decl, Flag); + end Set_Has_Body; + + function Get_Has_Identifier_List (Decl : Iir) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Has_Identifier_List (Get_Kind (Decl))); + return Get_Flag3 (Decl); + end Get_Has_Identifier_List; + + procedure Set_Has_Identifier_List (Decl : Iir; Flag : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Has_Identifier_List (Get_Kind (Decl))); + Set_Flag3 (Decl, Flag); + end Set_Has_Identifier_List; + + function Get_Has_Mode (Decl : Iir) return Boolean is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Has_Mode (Get_Kind (Decl))); + return Get_Flag8 (Decl); + end Get_Has_Mode; + + procedure Set_Has_Mode (Decl : Iir; Flag : Boolean) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Has_Mode (Get_Kind (Decl))); + Set_Flag8 (Decl, Flag); + end Set_Has_Mode; + + function Get_Is_Ref (N : Iir) return Boolean is + begin + pragma Assert (N /= Null_Iir); + pragma Assert (Has_Is_Ref (Get_Kind (N))); + return Get_Flag7 (N); + end Get_Is_Ref; + + procedure Set_Is_Ref (N : Iir; Ref : Boolean) is + begin + pragma Assert (N /= Null_Iir); + pragma Assert (Has_Is_Ref (Get_Kind (N))); + Set_Flag7 (N, Ref); + end Set_Is_Ref; + + function Get_Psl_Property (Decl : Iir) return PSL_Node is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Psl_Property (Get_Kind (Decl))); + return Iir_To_PSL_Node (Get_Field1 (Decl)); + end Get_Psl_Property; + + procedure Set_Psl_Property (Decl : Iir; Prop : PSL_Node) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Psl_Property (Get_Kind (Decl))); + Set_Field1 (Decl, PSL_Node_To_Iir (Prop)); + end Set_Psl_Property; + + function Get_Psl_Declaration (Decl : Iir) return PSL_Node is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Psl_Declaration (Get_Kind (Decl))); + return Iir_To_PSL_Node (Get_Field1 (Decl)); + end Get_Psl_Declaration; + + procedure Set_Psl_Declaration (Decl : Iir; Prop : PSL_Node) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Psl_Declaration (Get_Kind (Decl))); + Set_Field1 (Decl, PSL_Node_To_Iir (Prop)); + end Set_Psl_Declaration; + + function Get_Psl_Expression (Decl : Iir) return PSL_Node is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Psl_Expression (Get_Kind (Decl))); + return Iir_To_PSL_Node (Get_Field3 (Decl)); + end Get_Psl_Expression; + + procedure Set_Psl_Expression (Decl : Iir; Prop : PSL_Node) is + begin + pragma Assert (Decl /= Null_Iir); + pragma Assert (Has_Psl_Expression (Get_Kind (Decl))); + Set_Field3 (Decl, PSL_Node_To_Iir (Prop)); + end Set_Psl_Expression; + + function Get_Psl_Boolean (N : Iir) return PSL_Node is + begin + pragma Assert (N /= Null_Iir); + pragma Assert (Has_Psl_Boolean (Get_Kind (N))); + return Iir_To_PSL_Node (Get_Field1 (N)); + end Get_Psl_Boolean; + + procedure Set_Psl_Boolean (N : Iir; Bool : PSL_Node) is + begin + pragma Assert (N /= Null_Iir); + pragma Assert (Has_Psl_Boolean (Get_Kind (N))); + Set_Field1 (N, PSL_Node_To_Iir (Bool)); + end Set_Psl_Boolean; + + function Get_PSL_Clock (N : Iir) return PSL_Node is + begin + pragma Assert (N /= Null_Iir); + pragma Assert (Has_PSL_Clock (Get_Kind (N))); + return Iir_To_PSL_Node (Get_Field7 (N)); + end Get_PSL_Clock; + + procedure Set_PSL_Clock (N : Iir; Clock : PSL_Node) is + begin + pragma Assert (N /= Null_Iir); + pragma Assert (Has_PSL_Clock (Get_Kind (N))); + Set_Field7 (N, PSL_Node_To_Iir (Clock)); + end Set_PSL_Clock; + + function Get_PSL_NFA (N : Iir) return PSL_NFA is + begin + pragma Assert (N /= Null_Iir); + pragma Assert (Has_PSL_NFA (Get_Kind (N))); + return Iir_To_PSL_NFA (Get_Field8 (N)); + end Get_PSL_NFA; + + procedure Set_PSL_NFA (N : Iir; Fa : PSL_NFA) is + begin + pragma Assert (N /= Null_Iir); + pragma Assert (Has_PSL_NFA (Get_Kind (N))); + Set_Field8 (N, PSL_NFA_To_Iir (Fa)); + end Set_PSL_NFA; + +end Iirs; diff --git a/src/vhdl/iirs.adb.in b/src/vhdl/iirs.adb.in new file mode 100644 index 000000000..04511bb67 --- /dev/null +++ b/src/vhdl/iirs.adb.in @@ -0,0 +1,229 @@ +-- Tree node definitions. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Unchecked_Conversion; +with Ada.Text_IO; +with Nodes; use Nodes; +with Lists; use Lists; +with Nodes_Meta; use Nodes_Meta; + +package body Iirs is + function Is_Null (Node : Iir) return Boolean is + begin + return Node = Null_Iir; + end Is_Null; + + function Is_Null_List (Node : Iir_List) return Boolean is + begin + return Node = Null_Iir_List; + end Is_Null_List; + + --------------------------------------------------- + -- General subprograms that operate on every iir -- + --------------------------------------------------- + + function Get_Format (Kind : Iir_Kind) return Format_Type; + + function Create_Iir (Kind : Iir_Kind) return Iir + is + Res : Iir; + Format : Format_Type; + begin + Format := Get_Format (Kind); + Res := Create_Node (Format); + Set_Nkind (Res, Iir_Kind'Pos (Kind)); + return Res; + end Create_Iir; + + -- Statistics. + procedure Disp_Stats + is + use Ada.Text_IO; + type Num_Array is array (Iir_Kind) of Natural; + Num : Num_Array := (others => 0); + type Format_Array is array (Format_Type) of Natural; + Formats : Format_Array := (others => 0); + Kind : Iir_Kind; + I : Iir; + Last_I : Iir; + Format : Format_Type; + begin + I := Error_Node + 1; + Last_I := Get_Last_Node; + while I < Last_I loop + Kind := Get_Kind (I); + Num (Kind) := Num (Kind) + 1; + Format := Get_Format (Kind); + Formats (Format) := Formats (Format) + 1; + case Format is + when Format_Medium => + I := I + 2; + when Format_Short + | Format_Fp + | Format_Int => + I := I + 1; + end case; + end loop; + + Put_Line ("Stats per iir_kind:"); + for J in Iir_Kind loop + if Num (J) /= 0 then + Put_Line (' ' & Iir_Kind'Image (J) & ':' + & Natural'Image (Num (J))); + end if; + end loop; + Put_Line ("Stats per formats:"); + for J in Format_Type loop + Put_Line (' ' & Format_Type'Image (J) & ':' + & Natural'Image (Formats (J))); + end loop; + end Disp_Stats; + + function Iir_Predefined_Shortcut_P (Func : Iir_Predefined_Functions) + return Boolean is + begin + case Func is + when Iir_Predefined_Bit_And + | Iir_Predefined_Bit_Or + | Iir_Predefined_Bit_Nand + | Iir_Predefined_Bit_Nor + | Iir_Predefined_Boolean_And + | Iir_Predefined_Boolean_Or + | Iir_Predefined_Boolean_Nand + | Iir_Predefined_Boolean_Nor => + return True; + when others => + return False; + end case; + end Iir_Predefined_Shortcut_P; + + function Create_Iir_Error return Iir + is + Res : Iir; + begin + Res := Create_Node (Format_Short); + Set_Nkind (Res, Iir_Kind'Pos (Iir_Kind_Error)); + Set_Base_Type (Res, Res); + return Res; + end Create_Iir_Error; + + procedure Location_Copy (Target: Iir; Src: Iir) is + begin + Set_Location (Target, Get_Location (Src)); + end Location_Copy; + + -- Get kind + function Get_Kind (An_Iir: Iir) return Iir_Kind + is + -- Speed up: avoid to check that nkind is in the bounds of Iir_Kind. + pragma Suppress (Range_Check); + begin + return Iir_Kind'Val (Get_Nkind (An_Iir)); + end Get_Kind; + + function Time_Stamp_Id_To_Iir is new Ada.Unchecked_Conversion + (Source => Time_Stamp_Id, Target => Iir); + + function Iir_To_Time_Stamp_Id is new Ada.Unchecked_Conversion + (Source => Iir, Target => Time_Stamp_Id); + + function Iir_To_Iir_List is new Ada.Unchecked_Conversion + (Source => Iir, Target => Iir_List); + function Iir_List_To_Iir is new Ada.Unchecked_Conversion + (Source => Iir_List, Target => Iir); + + function Iir_To_Token_Type (N : Iir) return Token_Type is + begin + return Token_Type'Val (N); + end Iir_To_Token_Type; + + function Token_Type_To_Iir (T : Token_Type) return Iir is + begin + 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_Name_Id (N : Iir) return Name_Id is + begin + return Iir'Pos (N); + end Iir_To_Name_Id; + pragma Inline (Iir_To_Name_Id); + + function Name_Id_To_Iir (V : Name_Id) return Iir is + begin + return Name_Id'Pos (V); + end Name_Id_To_Iir; + + function Iir_To_Iir_Int32 is new Ada.Unchecked_Conversion + (Source => Iir, Target => Iir_Int32); + + function Iir_Int32_To_Iir is new Ada.Unchecked_Conversion + (Source => Iir_Int32, Target => Iir); + + function Iir_To_Source_Ptr (N : Iir) return Source_Ptr is + begin + return Source_Ptr (N); + end Iir_To_Source_Ptr; + + function Source_Ptr_To_Iir (P : Source_Ptr) return Iir is + begin + return Iir (P); + end Source_Ptr_To_Iir; + + function Iir_To_Location_Type (N : Iir) return Location_Type is + begin + return Location_Type (N); + end Iir_To_Location_Type; + + function Location_Type_To_Iir (L : Location_Type) return Iir is + begin + return Iir (L); + end Location_Type_To_Iir; + + function Iir_To_String_Id is new Ada.Unchecked_Conversion + (Source => Iir, Target => String_Id); + function String_Id_To_Iir is new Ada.Unchecked_Conversion + (Source => String_Id, Target => Iir); + + function Iir_To_Int32 is new Ada.Unchecked_Conversion + (Source => Iir, Target => Int32); + function Int32_To_Iir is new Ada.Unchecked_Conversion + (Source => Int32, Target => Iir); + + function Iir_To_PSL_Node is new Ada.Unchecked_Conversion + (Source => Iir, Target => PSL_Node); + + function PSL_Node_To_Iir is new Ada.Unchecked_Conversion + (Source => PSL_Node, Target => Iir); + + function Iir_To_PSL_NFA is new Ada.Unchecked_Conversion + (Source => Iir, Target => PSL_NFA); + + function PSL_NFA_To_Iir is new Ada.Unchecked_Conversion + (Source => PSL_NFA, Target => Iir); + + -- Subprograms +end Iirs; diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads new file mode 100644 index 000000000..cd58daa56 --- /dev/null +++ b/src/vhdl/iirs.ads @@ -0,0 +1,6445 @@ +-- Tree node definitions. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Unchecked_Deallocation; +with Types; use Types; +with Tokens; use Tokens; +with Nodes; +with Lists; + +package Iirs is + -- This package defines the semantic tree and functions to handle it. + -- The tree is roughly based on IIR (Internal Intermediate Representation), + -- [AIRE/CE Advanced Intermediate Representation with Extensibility, + -- Common Environment. http://www.vhdl.org/aire/index.html ] + -- but oriented object features are not used, and sometimes, functions + -- or fields have changed. + + -- Note: this tree is also used during syntaxic analysis, but with + -- a little bit different meanings for the fields. + -- The parser (parse package) build the tree. + -- The semantic pass (sem, sem_expr, sem_name) transforms it into a + -- semantic tree. + + -- Documentation: + -- Only the semantic aspect is to be fully documented. + -- The syntaxic aspect is only used between parse and sem. + + -- Each node of the tree is a record of type iir. The record has only + -- one discriminent, which contains the kind of the node. There is + -- currenlty no variant (but this can change, this is not public). + + -- The root of a semantic tree is a library_declaration. + -- All the library_declarations are kept in a private list, held by + -- package libraries. + -- Exemple of a tree: + -- library_declaration + -- +-- design_file + -- +-- design_unit + -- | +-- entity_declaration + -- +-- design_unit + -- +-- architecture_body + -- ... + + -- Since the tree can represent all the libraries and their contents, it + -- is not always loaded into memory. + -- When a library is loaded, only library_declaration, design_file, + -- design_unit and library_unit nodes are created. When a design_unit is + -- really loaded, the design_unit node is not replaced but modified (ie, + -- access to this node are still valid). + + -- To add a new kind of node: + -- the name should be of the form iir_kind_NAME + -- add iir_kind_NAME in the definition of type iir_kind_type + -- document the node below: grammar, methods. + -- for each methods, add the name if the case statement in the body + -- (this enables the methods) + -- add an entry in disp_tree (debugging) + -- handle this node in Errorout.Disp_Node + + -- Meta-grammar + -- This file is processed by a tool to automatically generate the body, so + -- it must follow a meta-grammar. + -- + -- The low level representation is described in nodes.ads. + -- + -- The literals for the nodes must be declared in this file like this: + -- type Iir_Kind is + -- ( + -- Iir_Kind_AAA, + -- ... + -- Iir_Kind_ZZZ + -- ); + -- The tool doesn't check for uniqness as this is done by the compiler. + -- + -- It is possible to declare ranges of kinds like this: + -- subtype Iir_Kinds_RANGE is Iir_Kind range + -- Iir_Kind_FIRST .. + -- --Iir_Kind_MID + -- Iir_Kind_LAST; + -- Literals Iir_Kind_MID are optionnal (FIXME: make them required ?), but + -- if present all the values between FIRST and LAST must be present. + -- + -- The methods appear after the comment: ' -- General methods.' + -- They have the following format: + -- -- Field: FIELD ATTR (CONV) + -- function Get_NAME (PNAME : PTYPE) return RTYPE; + -- procedure Set_NAME (PNAME : PTYPE; RNAME : RTYPE); + -- 'FIELD' indicate which field of the node is used to store the value. + -- ATTR is optional and if present must be one of: + -- Ref: the field is a reference to an existing node + -- Chain: the field contains a chain of nodes + -- Chain_Next: the field contains the next element of a chain (present + -- only on one field: Set/Get_Chain). + -- ' (CONV)' is present if the type of the value (indicated by RTYPE) is + -- different from the type of the field. CONV can be either 'uc' or 'pos'. + -- 'uc' indicates an unchecked conversion while 'pos' a pos/val conversion. + -- + -- Nodes content is described between ' -- Start of Iir_Kind.' and + -- ' -- End of Iir_Kind.' like this: + -- -- Iir_Kind_NODE1 (FORMAT1) + -- -- Iir_Kind_NODE2 (FORMAT2) + -- -- + -- -- Get/Set_NAME1 (FIELD1) + -- -- + -- -- Get/Set_NAME2 (FIELD2) + -- -- Get/Set_NAME3 (Alias FIELD2) + -- -- + -- -- Only for Iir_Kind_NODE1: + -- -- Get/Set_NAME4 (FIELD3) + -- Severals nodes can be described at once; at least one must be described. + -- Fields FIELD1, FIELD2, FIELD3 must be different, unless 'Alias ' is + -- present. The number of spaces is significant. The 'Only for ' lines + -- are optionnal and there may be severals of them. + + ------------------------------------------------- + -- General methods (can be used on all nodes): -- + ------------------------------------------------- + + -- Create a node of kind KIND. + -- function Create_Iir (Kind: Iir_Kind) return Iir; + -- + -- Deallocate a node. Deallocate fields that where allocated by + -- create_iir. + -- procedure Free_Iir (Target: in out Iir); + -- + -- Get the kind of the iir. + -- See below for the (public) list of kinds. + -- function Get_Kind (An_Iir: Iir) return Iir_Kind; + + -- Get the location of the node: ie the current position in the source + -- file when the node was created. This is a little bit fuzzy. + -- + -- procedure Set_Location (Target: in out Iir; Location: Location_Type); + -- function Get_Location (Target: in out Iir) return Location_Type; + -- + -- Copy a location from a node to another one. + -- procedure Location_Copy (Target: in out Iir; Src: in Iir); + + -- The next line marks the start of the node description. + -- Start of Iir_Kind. + + -------------------------------------------------- + -- A set of methods are associed with a kind. -- + -------------------------------------------------- + + -- Iir_Kind_Design_File (Medium) + -- LRM93 11 + -- design_file ::= design_unit { design_unit } + -- + -- The library containing this design file. + -- Get/Set_Library (Field0) + -- Get/Set_Parent (Alias Field0) + -- + -- Get/Set_File_Dependence_List (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Analysis_Time_Stamp (Field3) + -- + -- Get/Set_File_Time_Stamp (Field4) + -- + -- Get the chain of unit contained in the file. This is a simply linked + -- chain, but the tail is kept to speed-up appending operation. + -- Get/Set_First_Design_Unit (Field5) + -- + -- Get/Set_Last_Design_Unit (Field6) + -- + -- Identifier for the design file file name and dirname. + -- Get/Set_Design_File_Filename (Field12) + -- Get/Set_Design_File_Directory (Field11) + -- + -- Flag used during elaboration. Set when the file was already seen. + -- Get/Set_Elab_Flag (Flag3) + + -- Iir_Kind_Design_Unit (Medium) + -- LRM93 11 + -- design_unit ::= context_clause library_unit + -- + -- The design_file containing this design unit. + -- Get/Set_Design_File (Field0) + -- Get/Set_Parent (Alias Field0) + -- + -- Get the chain of context clause. + -- Get/Set_Context_Items (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set the library unit, which can be an entity, an architecture, + -- a package, a package body or a configuration. + -- Get/Set_Library_Unit (Field5) + -- + -- Get/Set_End_Location (Field6) + -- + -- Collision chain for units. + -- Get/Set_Hash_Chain (Field7) + -- + -- Get the list of design units that must be analysed before this unit. + -- See LRM93 11.4 for the rules defining the order of analysis. + -- Get/Set_Dependence_List (Field8) + -- + -- FIXME: this field can be put in the library_unit, since it is only used + -- when the units have been analyzed. + -- Get/Set_Analysis_Checks_List (Field9) + -- + -- This is a symbolic date, only used as a order of analysis of design + -- units. + -- Get/Set_Date (Field10) + -- + -- Set the line and the offset in the line, only for the library manager. + -- This is valid until the file is really loaded in memory. On loading, + -- location will contain all this informations. + -- Get/Set_Design_Unit_Source_Pos (Field4) + -- + -- Get/Set_Design_Unit_Source_Line (Field11) + -- + -- Get/Set_Design_Unit_Source_Col (Field12) + -- + -- Get/Set the date state, which indicates whether this design unit is in + -- memory or not. + -- Get/Set_Date_State (State1) + -- + -- Flag used during elaboration. Set when the file was already seen. + -- Get/Set_Elab_Flag (Flag3) + + -- Iir_Kind_Library_Clause (Short) + -- + -- LRM08 13.2 Design libraries + -- + -- library_clause ::= LIBRARY logical_name_list ; + -- + -- logical_name_list ::= logical_name { , logical_name } + -- + -- logical_name ::= identifier + -- + -- Note: a library_clause node is created for every logical_name. + -- As a consequence, the scope of the library starts after the logical_name + -- and not after the library_clause. However, since an identifier + -- can only be used as a logical_name, and since the second occurence has + -- no effect, this is correct. + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Library_Declaration (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Has_Identifier_List (Flag3) + + --------------- + -- Literals -- + --------------- + + -- Iir_Kind_String_Literal (Short) + -- Iir_Kind_Bit_String_Literal (Medium) + -- + -- Get/Set_Type (Field1) + -- + -- Used for computed literals. Literal_Origin contains the expression + -- whose value was computed during analysis and replaces the expression. + -- Get/Set_Literal_Origin (Field2) + -- + -- Get/Set_String_Id (Field3) + -- + -- As bit-strings are expanded to '0'/'1' strings, this is the number of + -- characters. + -- Get/Set_String_Length (Field4) + -- + -- Same as Type, but marked as property of that node. + -- Get/Set_Literal_Subtype (Field5) + -- + -- For bit string only: + -- Enumeration literal which correspond to '0' and '1'. + -- This cannot be defined only in the enumeration type definition, due to + -- possible aliases. + -- Only for Iir_Kind_Bit_String_Literal: + -- Get/Set_Bit_String_0 (Field6) + -- Only for Iir_Kind_Bit_String_Literal: + -- Get/Set_Bit_String_1 (Field7) + -- + -- Only for Iir_Kind_Bit_String_Literal: + -- Get/Set_Bit_String_Base (Field8) + -- + -- Get/Set_Expr_Staticness (State1) + + -- Iir_Kind_Integer_Literal (Int) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set the value of the integer. + -- Get/Set_Value (Int64) + -- + -- Get/Set_Literal_Origin (Field2) + -- + -- Get/Set_Expr_Staticness (State1) + + -- Iir_Kind_Floating_Point_Literal (Fp) + -- + -- Get/Set_Type (Field1) + -- + -- The value of the literal. + -- Get/Set_Fp_Value (Fp64) + -- + -- Get/Set_Literal_Origin (Field2) + -- + -- Get/Set_Expr_Staticness (State1) + + -- Iir_Kind_Null_Literal (Short) + -- The null literal, which can be a disconnection or a null access. + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Expr_Staticness (State1) + + -- Iir_Kind_Physical_Int_Literal (Int) + -- Iir_Kind_Physical_Fp_Literal (Fp) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Literal_Origin (Field2) + -- + -- The physical unit of the literal. + -- Get/Set_Unit_Name (Field3) + -- + -- Must be set to locally except for time literal, which is globally. + -- Get/Set_Expr_Staticness (State1) + -- + -- Only for Iir_Kind_Physical_Int_Literal: + -- The multiplicand. + -- Get/Set_Value (Int64) + -- + -- Only for Iir_Kind_Physical_Fp_Literal: + -- The multiplicand. + -- Get/Set_Fp_Value (Fp64) + + -- Iir_Kind_Simple_Aggregate (Short) + -- This node can only be generated by evaluation: it is an unidimentional + -- positional aggregate. + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Literal_Origin (Field2) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- List of elements + -- Get/Set_Simple_Aggregate_List (Field3) + -- + -- Same as Type, but marked as property of that node. + -- Get/Set_Literal_Subtype (Field5) + + -- Iir_Kind_Overflow_Literal (Short) + -- This node can only be generated by evaluation to represent an error: out + -- of range, division by zero... + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Literal_Origin (Field2) + -- + -- Get/Set_Expr_Staticness (State1) + + ------------- + -- Tuples -- + ------------- + + -- Iir_Kind_Association_Element_By_Expression (Short) + -- Iir_Kind_Association_Element_Open (Short) + -- Iir_Kind_Association_Element_By_Individual (Short) + -- Iir_Kind_Association_Element_Package (Short) + -- These are used for association element of an association list with + -- an interface (ie subprogram call, port map, generic map). + -- + -- Get/Set_Formal (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Only for Iir_Kind_Association_Element_By_Expression: + -- Only for Iir_Kind_Association_Element_Package: + -- Get/Set_Actual (Field3) + -- + -- Only for Iir_Kind_Association_Element_By_Individual: + -- Get/Set_Actual_Type (Field3) + -- + -- Only for Iir_Kind_Association_Element_By_Individual: + -- Get/Set_Individual_Association_Chain (Field4) + -- + -- Only for Iir_Kind_Association_Element_Package: + -- Get/Set_Associated_Interface (Field4) + -- + -- A function call or a type conversion for the association. + -- FIXME: should be a name ? + -- Only for Iir_Kind_Association_Element_By_Expression: + -- Get/Set_In_Conversion (Field4) + -- + -- Only for Iir_Kind_Association_Element_By_Expression: + -- Get/Set_Out_Conversion (Field5) + -- + -- Get/Set the whole association flag (true if the formal is associated in + -- whole and not individually, see LRM93 4.3.2.2) + -- Get/Set_Whole_Association_Flag (Flag1) + -- + -- Get/Set_Collapse_Signal_Flag (Flag2) + -- + -- Only for Iir_Kind_Association_Element_Open: + -- Get/Set_Artificial_Flag (Flag3) + + -- Iir_Kind_Waveform_Element (Short) + -- + -- Get/Set_We_Value (Field1) + -- + -- Get/Set_Time (Field3) + -- + -- Get/Set_Chain (Field2) + + -- Iir_Kind_Conditional_Waveform (Short) + -- + -- Get/Set_Condition (Field1) + -- + -- Get/Set_Waveform_Chain (Field5) + -- + -- Get/Set_Chain (Field2) + + -- Iir_Kind_Choice_By_Others (Short) + -- Iir_Kind_Choice_By_None (Short) + -- Iir_Kind_Choice_By_Range (Short) + -- Iir_Kind_Choice_By_Name (Short) + -- Iir_Kind_Choice_By_Expression (Short) + -- (Iir_Kinds_Choice) + -- + -- Get/Set_Parent (Field0) + -- + -- For a list of choices, only the first one is associated, the following + -- associations have the same_alternative_flag set. + -- Get/Set_Chain (Field2) + -- + -- These are elements of an choice chain, which is used for + -- case_statement, concurrent_select_signal_assignment, aggregates. + -- + -- Get/Set what is associated with the choice. There are two different + -- nodes, one for simple association and the other for chain association. + -- This simplifies walkers. But both nodes are never used at the same + -- time. + -- + -- For: + -- * an expression for an aggregate + -- * an individual association + -- Get/Set_Associated_Expr (Field3) + -- + -- For + -- * a waveform_chain for a concurrent_select_signal_assignment, + -- * a sequential statement chain for a case_statement. + -- Get/Set_Associated_Chain (Field4) + -- + -- Only for Iir_Kind_Choice_By_Name: + -- Get/Set_Choice_Name (Field5) + -- + -- Only for Iir_Kind_Choice_By_Expression: + -- Get/Set_Choice_Expression (Field5) + -- + -- Only for Iir_Kind_Choice_By_Range: + -- Get/Set_Choice_Range (Field5) + -- + -- Get/Set_Same_Alternative_Flag (Flag1) + -- + -- Only for Iir_Kind_Choice_By_Range: + -- Only for Iir_Kind_Choice_By_Expression: + -- Get/Set_Choice_Staticness (State2) + + -- Iir_Kind_Entity_Aspect_Entity (Short) + -- + -- Get/Set_Entity_Name (Field2) + -- + -- parse: a simple name. + -- sem: an architecture declaration or NULL_IIR. + -- Get/Set_Architecture (Field3) + + -- Iir_Kind_Entity_Aspect_Open (Short) + + -- Iir_Kind_Entity_Aspect_Configuration (Short) + -- + -- Get/Set_Configuration_Name (Field1) + + -- Iir_Kind_Block_Configuration (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Configuration_Item_Chain (Field3) + -- + -- Note: for default block configurations of iterative generate statement, + -- the block specification is an indexed_name, whose index_list is others. + -- Get/Set_Block_Specification (Field5) + -- + -- Single linked list of block configuration that apply to the same + -- for scheme generate block. + -- Get/Set_Prev_Block_Configuration (Field4) + + -- Iir_Kind_Binding_Indication (Medium) + -- + -- Get/Set_Default_Entity_Aspect (Field1) + -- + -- The entity aspect. + -- It is a iir_kind_entity_aspect_entity, iir_kind_entity_aspect_open or + -- iir_kind_entity_aspect_configuration. This may be transformed into a + -- declaration by semantic. + -- Get/Set_Entity_Aspect (Field3) + -- + -- Get/Set_Default_Generic_Map_Aspect_Chain (Field6) + -- + -- Get/Set_Default_Port_Map_Aspect_Chain (Field7) + -- + -- Get/Set_Generic_Map_Aspect_Chain (Field8) + -- + -- Get/Set_Port_Map_Aspect_Chain (Field9) + + -- Iir_Kind_Component_Configuration (Short) + -- Iir_Kind_Configuration_Specification (Short) + -- + -- LRM08 7.3 Configuration specification + -- + -- configuration_specification ::= + -- simple_configuration_specification + -- | compound_configuration_specification + -- + -- simple_configuration_specification ::= + -- FOR component_specification binding_indication ; + -- [ END FOR ; ] + -- + -- compound_configuration_specification ::= + -- FOR component_specification binding_indication ; + -- verification_unit_binding_indication ; + -- { verification_unit_binding_indication ; } + -- END FOR ; + -- + -- component_specification ::= + -- instantiation_list : component_name + -- + -- instantiation_list ::= + -- instantiation_label { , instantiation_label } + -- | OTHERS + -- | ALL + -- + -- The declaration containing this type declaration. + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Component_Name (Field4) + -- + -- Must be one of designator_list, designator_by_others or + -- designator_by_all. + -- Get/Set_Instantiation_List (Field1) + -- + -- Only for Iir_Kind_Component_Configuration: + -- Get/Set_Block_Configuration (Field5) + -- + -- Get/Set_Binding_Indication (Field3) + -- + -- Get/Set_Chain (Field2) + + -- Iir_Kind_Disconnection_Specification (Short) + -- + -- LRM08 7.4 Disconnection specification + -- + -- disconnection_specification ::= + -- DISCONNECT guarded_signal_specification AFTER time_expression ; + -- + -- guarded_signal_specification ::= + -- guarded_signal_list : type_mark + -- + -- signal_list ::= + -- signal_name { , signal_name } + -- | OTHERS + -- | ALL + -- + -- The declaration containing this type declaration. + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Signal_List (Field3) + -- + -- Get/Set_Type_Mark (Field4) + -- + -- Get/Set_Expression (Field5) + + -- Iir_Kind_Block_Header (Medium) + -- + -- Get/Set_Generic_Chain (Field6) + -- + -- Get/Set_Port_Chain (Field7) + -- + -- Get/Set_Generic_Map_Aspect_Chain (Field8) + -- + -- Get/Set_Port_Map_Aspect_Chain (Field9) + + -- Iir_Kind_Entity_Class (Short) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Entity_Class (Field3) + + -- Iir_Kind_Attribute_Specification (Medium) + -- + -- LRM08 7.2 Attribute specification + -- + -- attribute_specification ::= + -- ATTRIBUTE attribute_designator OF entity_specification + -- IS expression ; + -- + -- entity_specification ::= entity_name_list : entity_class + -- + -- entity_name_list ::= + -- entity_designator { , entity_designator } + -- | OTHERS + -- | ALL + -- + -- entity_designator ::= entity_tag [ signature ] + -- + -- entity_tag ::= simple_name | character_literal | operator_symbol + -- + -- LRM08 8.6 Attribute names + -- + -- attribute_designator ::= /attribute/_simple_name + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Entity_Name_List (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Entity_Class (Field3) + -- + -- Get/Set_Attribute_Value_Spec_Chain (Field4) + -- + -- Get/Set_Expression (Field5) + -- + -- Always a simple name. + -- Get/Set_Attribute_Designator (Field6) + -- + -- Get/Set_Attribute_Specification_Chain (Field7) + + -- Iir_Kind_Attribute_Value (Short) + -- An attribute value is the element of the chain of attribute of an + -- entity, marking the entity as decorated by the attribute. + -- This node is built only by sem. + -- In fact, the node is member of the chain of attribute of an entity, and + -- of the chain of entity of the attribute specification. + -- This makes elaboration (and more precisely, expression evaluation) + -- easier. + -- + -- Get/Set_Spec_Chain (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Designated_Entity (Field3) + -- + -- Get/Set_Attribute_Specification (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Psl_Expression (Short) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Psl_Expression (Field3) + + -- Iir_Kind_Signature (Medium) + -- + -- LRM08 4.5.3 Signatures + -- + -- signature ::= '[' [ type_mark { , type_mark } ] [ RETURN type_mark ] ']' + -- + -- Get/Set_Signature_Prefix (Field1) + -- + -- Get/Set_Type_Marks_List (Field2) + -- + -- Get/Set_Return_Type_Mark (Field8) + + -- Iir_Kind_Overload_List (Short) + -- + -- Get/Set_Overload_List (Field1) + + ------------------- + -- Declarations -- + ------------------- + + -- Iir_Kind_Entity_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- Get/Set_Design_Unit (Alias Field0) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Concurrent_Statement_Chain (Field5) + -- + -- Get/Set_Generic_Chain (Field6) + -- + -- Get/Set_Port_Chain (Field7) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Is_Within_Flag (Flag5) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + -- + -- Get/Set_Has_Begin (Flag10) + + -- Iir_Kind_Architecture_Body (Medium) + -- + -- Get/Set_Parent (Field0) + -- Get/Set_Design_Unit (Alias Field0) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Name of the entity declaration for the architecture. + -- Get/Set_Entity_Name (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Concurrent_Statement_Chain (Field5) + -- + -- The default configuration created by canon. This is a design unit. + -- Get/Set_Default_Configuration_Declaration (Field6) + -- + -- Get/Set_Foreign_Flag (Flag3) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Is_Within_Flag (Flag5) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_Configuration_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- Get/Set_Design_Unit (Alias Field0) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Name of the entity of a configuration. + -- Get/Set_Entity_Name (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Block_Configuration (Field5) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_Package_Header (Medium) + -- + -- Get/Set_Generic_Chain (Field6) + -- + -- Get/Set_Generic_Map_Aspect_Chain (Field8) + + -- Iir_Kind_Package_Declaration (Short) + -- + -- Get/Set_Parent (Field0) + -- Get/Set_Design_Unit (Alias Field0) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Package_Body (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Package_Header (Field5) + -- + -- Get/Set_Need_Body (Flag1) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_Package_Body (Short) + -- Note: a body is not a declaration, that's the reason why there is no + -- _declaration suffix in the name. + -- + -- Get/Set_Parent (Field0) + -- Get/Set_Design_Unit (Alias Field0) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Identifier (Field3) + -- + -- The corresponding package declaration. + -- Get/Set_Package (Field4) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_Package_Instantiation_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- Get/Set_Design_Unit (Alias Field0) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Package_Body (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Uninstantiated_Package_Name (Field5) + -- + -- Get/Set_Generic_Chain (Field6) + -- + -- Get/Set_Generic_Map_Aspect_Chain (Field8) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_Library_Declaration (Medium) + -- + -- Design files in the library. + -- Get/Set_Design_File_Chain (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- This node is used to contain all a library. Only internaly used. + -- Name (identifier) of the library. + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Date (Field10) + -- + -- Get/Set_Library_Directory (Field11) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Component_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Generic_Chain (Field6) + -- + -- Get/Set_Port_Chain (Field7) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Has_Is (Flag7) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- LRM08 6.6 Alias declarations + -- + -- alias_declaration ::= + -- ALIAS alias_designator [ : subtype_indication ] IS + -- name [ signature ] ; + -- + -- alias_designator ::= identifier | character_literal | operator_symbol + -- + -- Object aliases and non-object aliases are represented by two different + -- nodes, as their semantic is different. The parser only creates object + -- alias declaration nodes, but sem_decl replaces the node for non-object + -- alias declarations. + + -- Iir_Kind_Object_Alias_Declaration (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- The type can be deduced from the subtype indication, but this field is + -- present for uniformity (and speed). + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Name (Field4) + -- + -- The subtype indication may not be present. + -- Get/Set_Subtype_Indication (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_After_Drivers_Flag (Flag5) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Is_Ref (Flag7) + + -- Iir_Kind_Non_Object_Alias_Declaration (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Name (Field4) + -- + -- Get/Set_Alias_Signature (Field5) + -- + -- Set when the alias was implicitely created (by Sem) because of an + -- explicit alias of a type. + -- Get/Set_Implicit_Alias_Flag (Flag1) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + + -- Iir_Kind_Anonymous_Type_Declaration (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type_Definition (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Used for informative purpose only. + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Subtype_Definition (Field4) + + -- Iir_Kind_Type_Declaration (Short) + -- + -- LRM08 6.3 Type declarations + -- + -- type_declaration ::= + -- full_type_declaration + -- | incomplete_type_declaration + -- + -- full_type_declaration ::= + -- TYPE identifier IS type_definition ; + -- + -- type_definition ::= + -- scalar_type_definition + -- | composite_type_definition + -- | access_type_definition + -- | file_type_definition + -- | protected_type_definition + -- + -- LRM08 5.4.2 Incomplete type declarations + -- + -- incomplete_type_declaration ::= + -- TYPE identifier ; + -- + -- Get/Set_Parent (Field0) + -- + -- Definition of the type. + -- Note: the type definition can be a real type (unconstrained array, + -- enumeration, file, record, access) or a subtype (integer, floating + -- point). + -- The parser set this field to null_iir for an incomplete type + -- declaration. This field is set to an incomplete_type_definition node + -- when first semantized. + -- Get/Set_Type_Definition (Field1) + -- Get/Set_Type (Alias Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + + -- Iir_Kind_Subtype_Declaration (Short) + -- + -- LRM08 6.3 Subtype declarations + -- + -- subtype_declaration ::= + -- SUBTYPE identifier IS subtype_indication ; + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Subtype_Indication (Field5) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Is_Ref (Flag7) + + -- Iir_Kind_Nature_Declaration (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Nature (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + + -- Iir_Kind_Subnature_Declaration (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Nature (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + + -- Iir_Kind_Interface_Signal_Declaration (Medium) + -- Iir_Kind_Interface_Constant_Declaration (Medium) + -- Iir_Kind_Interface_Variable_Declaration (Medium) + -- Iir_Kind_Interface_File_Declaration (Medium) + -- + -- Get/Set the parent of an interface declaration. + -- The parent is an entity declaration, a subprogram specification, a + -- component declaration, a loop statement, a block declaration or ?? + -- Useful to distinguish a port and an interface. + -- Get/Set_Parent (Field0) + -- + -- The type can be deduced from the subtype indication, but this field is + -- present for uniformity (and speed). + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Subtype_Indication (Field5) + -- + -- Must always be null_iir for iir_kind_interface_file_declaration. + -- Get/Set_Default_Value (Field6) + -- + -- Get/Set_Mode (Odigit1) + -- + -- Get/Set_Lexical_Layout (Odigit2) + -- + -- Only for Iir_Kind_Interface_Signal_Declaration: + -- Get/Set_Has_Disconnect_Flag (Flag1) + -- + -- Only for Iir_Kind_Interface_Signal_Declaration: + -- Get/Set_Has_Active_Flag (Flag2) + -- + -- Only for Iir_Kind_Interface_Signal_Declaration: + -- Get/Set_Open_Flag (Flag3) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_After_Drivers_Flag (Flag5) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Is_Ref (Flag7) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + -- + -- Only for Iir_Kind_Interface_Signal_Declaration: + -- Get/Set_Signal_Kind (State3) + + -- Iir_Kind_Interface_Package_Declaration (Medium) + -- + -- LRM08 6.5.5 Interface package declarations + -- + -- interface_package_declaration ::= + -- PACKAGE identifier IS NEW /uninstantiated_package/_name + -- interface_package_generic_map_aspect + -- + -- interface_package_generic_map_aspect ::= + -- generic_map_aspect + -- | GENERIC MAP ( <> ) -- Represented by Null_Iir + -- | GENERIC MAP ( DEFAULT ) -- Not yet implemented + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Uninstantiated_Package_Name (Field5) + -- + -- Get/Set_Generic_Chain (Field6) + -- + -- Get/Set_Generic_Map_Aspect_Chain (Field8) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Function_Declaration (Medium) + -- Iir_Kind_Procedure_Declaration (Medium) + -- + -- LRM08 4.2 Subprogram declarations + -- + -- subprogram_declaration ::= subprogram_specification ; + -- + -- subprogram_specification ::= + -- procedure_specification | function_specification + -- + -- procedure_specification ::= + -- PROCEDURE designator + -- subprogram_header + -- [ [ PARAMETER ] ( formal_parameter_list ) ] + -- + -- function_specification ::= + -- [ PURE | IMPURE ] FUNCTION designator + -- subprogram_header + -- [ [ PARAMETER ] ( formal_parameter_list ) ] return type_mark + -- + -- designator ::= identifier | operator_symbol + -- + -- operator_symbol ::= string_literal + -- + -- Note: the subprogram specification of a body is kept, but should be + -- ignored if there is a subprogram declaration. The function + -- Is_Second_Subprogram_Specification returns True on such specification. + -- + -- The declaration containing this subrogram declaration. + -- Get/Set_Parent (Field0) + -- + -- Only for Iir_Kind_Function_Declaration: + -- Get/Set_Return_Type (Field1) + -- + -- Only for Iir_Kind_Function_Declaration: + -- Get/Set_Type (Alias Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Interface_Declaration_Chain (Field5) + -- + -- Get/Set_Generic_Chain (Field6) + -- + -- --Get/Set_Generic_Map_Aspect_Chain (Field8) + -- + -- Get/Set_Return_Type_Mark (Field8) + -- + -- Get/Set_Subprogram_Body (Field9) + -- + -- Get/Set_Subprogram_Depth (Field10) + -- + -- Get/Set_Subprogram_Hash (Field11) + -- + -- Get/Set_Overload_Number (Field12) + -- + -- Get/Set_Seen_Flag (Flag1) + -- + -- Only for Iir_Kind_Function_Declaration: + -- Get/Set_Pure_Flag (Flag2) + -- + -- Only for Iir_Kind_Procedure_Declaration: + -- Get/Set_Passive_Flag (Flag2) + -- + -- Get/Set_Foreign_Flag (Flag3) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Is_Within_Flag (Flag5) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Only for Iir_Kind_Function_Declaration: + -- Get/Set_Resolution_Function_Flag (Flag7) + -- + -- Only for Iir_Kind_Function_Declaration: + -- Get/Set_Has_Pure (Flag8) + -- + -- True is the specification is immediately followed by a body. + -- Get/Set_Has_Body (Flag9) + -- + -- Get/Set_Wait_State (State1) + -- + -- Only for Iir_Kind_Procedure_Declaration: + -- Get/Set_Purity_State (State2) + -- + -- Get/Set_All_Sensitized_State (State3) + + -- Iir_Kind_Function_Body (Medium) + -- Iir_Kind_Procedure_Body (Medium) + -- + -- LRM08 4.3 Subprogram bodies + -- + -- subprogram_body ::= + -- subprogram_specification IS + -- subprogram_declarative_part + -- BEGIN + -- subprogram_statement_part + -- END [ subprogram_kind ] [ designator ] ; + -- + -- subprogram_kind ::= PROCEDURE | FUNCTION + -- + -- Get/Set_Parent (Field0) + -- + -- The parse stage always puts a declaration before a body. + -- Sem will remove the declaration if there is a forward declaration. + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Impure_Depth (Field3) + -- + -- Get/Set_Subprogram_Specification (Field4) + -- + -- Get/Set_Sequential_Statement_Chain (Field5) + -- + -- Get/Set_Callees_List (Field7) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_Implicit_Procedure_Declaration (Medium) + -- Iir_Kind_Implicit_Function_Declaration (Medium) + -- + -- This node contains a subprogram_declaration that was implicitly defined + -- just after a type declaration. + -- This declaration is inserted by sem. + -- + -- Get/Set_Parent (Field0) + -- + -- Only for Iir_Kind_Implicit_Function_Declaration: + -- Get/Set_Return_Type (Field1) + -- + -- Only for Iir_Kind_Implicit_Function_Declaration: + -- Get/Set_Type (Alias Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Interface_Declaration_Chain (Field5) + -- + -- Get/Set_Generic_Chain (Field6) + -- + -- Get/Set_Generic_Map_Aspect_Chain (Field8) + -- + -- Get/Set_Implicit_Definition (Field9) + -- + -- Get/Set_Type_Reference (Field10) + -- + -- Get/Set_Subprogram_Hash (Field11) + -- + -- Get/Set_Overload_Number (Field12) + -- + -- Get/Set_Wait_State (State1) + -- + -- Get/Set_Seen_Flag (Flag1) + -- + -- Only for Iir_Kind_Implicit_Function_Declaration: + -- Get/Set_Pure_Flag (Flag2) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Is_Within_Flag (Flag5) + -- + -- Get/Set_Use_Flag (Flag6) + + -- Iir_Kind_Signal_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Subtype_Indication (Field5) + -- + -- Get/Set_Default_Value (Field6) + -- + -- For a non-resolved signal: null_iir if the signal has no driver, or + -- a process/concurrent_statement for which the signal should have a + -- driver. This is used to catch at analyse time unresolved signals with + -- several drivers. + -- Get/Set_Signal_Driver (Field7) + -- + -- Get/Set_Has_Disconnect_Flag (Flag1) + -- + -- Get/Set_Has_Identifier_List (Flag3) + -- + -- Get/Set_Has_Active_Flag (Flag2) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_After_Drivers_Flag (Flag5) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Is_Ref (Flag7) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + -- + -- Get/Set_Signal_Kind (State3) + + -- Iir_Kind_Guard_Signal_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Guard_Expression (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Guard_Sensitivity_List (Field6) + -- + -- Get/Set_Block_Statement (Field7) + -- + -- Get/Set_Has_Active_Flag (Flag2) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + -- + -- Get/Set_Signal_Kind (State3) + + -- Iir_Kind_Constant_Declaration (Medium) + -- Iir_Kind_Iterator_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- For iterator, this is the reconstructed subtype indication. + -- Get/Set_Subtype_Indication (Field5) + -- + -- Only for Iir_Kind_Iterator_Declaration: + -- Get/Set_Discrete_Range (Field6) + -- + -- Only for Iir_Kind_Constant_Declaration: + -- Default value of a deferred constant points to the full constant + -- declaration. + -- Get/Set_Default_Value (Field6) + -- + -- Only for Iir_Kind_Constant_Declaration: + -- Summary: + -- | constant C1 : integer; -- Deferred declaration (in a package) + -- | constant C2 : integer := 4; -- Declaration + -- | constant C1 : integer := 3; -- Full declaration (in a body) + -- | NAME Deferred_declaration Deferred_declaration_flag + -- | C1 Null_iir or C1' (*) True + -- | C2 Null_Iir False + -- | C1' C1 False + -- |(*): Deferred_declaration is Null_Iir as long as the full declaration + -- | has not been analyzed. + -- Get/Set_Deferred_Declaration (Field7) + -- + -- Only for Iir_Kind_Constant_Declaration: + -- Get/Set_Deferred_Declaration_Flag (Flag1) + -- + -- Get/Set_Has_Identifier_List (Flag3) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Is_Ref (Flag7) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Variable_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Subtype_Indication (Field5) + -- + -- Get/Set_Default_Value (Field6) + -- + -- True if the variable is a shared variable. + -- Get/Set_Shared_Flag (Flag2) + -- + -- Get/Set_Has_Identifier_List (Flag3) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Is_Ref (Flag7) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_File_Declaration (Medium) + -- + -- LRM08 6.4.2.5 File declarations + -- + -- file_declaration ::= + -- FILE identifier_list : subtype_indication [ file_open_information ] ; + -- + -- file_open_information ::= + -- [ OPEN file_open_kind_expression ] IS file_logical_name + -- + -- file_logical_name ::= string_expression + -- + -- LRM87 + -- + -- file_declaration ::= + -- FILE identifier : subtype_indication IS [ mode ] file_logical_name ; + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Subtype_Indication (Field5) + -- + -- Get/Set_File_Logical_Name (Field6) + -- + -- This is not used in vhdl 87. + -- Get/Set_File_Open_Kind (Field7) + -- + -- This is used only in vhdl 87. + -- Get/Set_Mode (Odigit1) + -- + -- Get/Set_Has_Identifier_List (Flag3) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Is_Ref (Flag7) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + -- + -- Get/Set_Has_Mode (Flag8) + + -- Iir_Kind_Element_Declaration (Short) + -- + -- LRM08 5.3.3 Record types + -- + -- element_declaration ::= + -- identifier_list : element_subtype_definition ; + -- + -- identifier_list ::= identifier { , identifier } + -- + -- element_subtype_definition ::= subtype_indication + -- + -- The type can be deduced from the subtype indication, but this field is + -- present for uniformity (and speed). + -- Get/Set_Type (Field1) + -- + -- 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_Subtype_Indication (Field5) + -- + -- Get/Set_Has_Identifier_List (Flag3) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Is_Ref (Flag7) + + -- 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) + -- + -- 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_Attribute_Declaration (Short) + -- + -- LRM08 6.7 Attribute declarations + -- + -- attribute_declaration ::= + -- ATTRIBUTE identifier : type_mark ; + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Type_Mark (Field4) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + + -- Iir_Kind_Group_Template_Declaration (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- List of entity class entry. + -- To handle `<>', the last element of the list can be an entity_class of + -- kind tok_box. + -- Get/Set_Entity_Class_Entry_Chain (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + + -- Iir_Kind_Group_Declaration (Short) + -- + -- The declaration containing this type declaration. + -- Get/Set_Parent (Field0) + -- + -- List of constituents. + -- Get/Set_Group_Constituent_List (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Group_Template_Name (Field5) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + + -- Iir_Kind_Psl_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Psl_Declaration (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Valid only for property declaration. + -- Get/Set_PSL_Clock (Field7) + -- + -- Valid only for property declaration without parameters. + -- Get/Set_PSL_NFA (Field8) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + + -- Iir_Kind_Terminal_Declaration (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Nature (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + + -- Iir_Kind_Free_Quantity_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Default_Value (Field6) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Across_Quantity_Declaration (Medium) + -- Iir_Kind_Through_Quantity_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Default_Value (Field6) + -- + -- Get/Set_Tolerance (Field7) + -- + -- Get/Set_Plus_Terminal (Field8) + -- + -- Get/Set_Minus_Terminal (Field9) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Use_Clause (Short) + -- + -- LRM08 12.4 Use clauses + -- + -- use_clause ::= + -- USE selected_name { , selected_name } ; + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Selected_Name (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Use_Clause_Chain (Field3) + + + ----------------------- + -- type definitions -- + ----------------------- + + -- For Iir_Kinds_Type_And_Subtype_Definition: + -- + -- Type_Declarator: + -- Points to the type declaration or subtype declaration that has created + -- this definition. For some types, such as integer and floating point + -- types, both type and subtype points to the declaration. + -- However, there are cases where a type definition doesn't point to + -- a declarator: anonymous subtype created by index contraints, or + -- anonymous subtype created by an object declaration. + -- Note: a type definition cannot be anoynymous. + -- Get/Set_Type_Declarator (Field3) + -- + -- The base type. + -- For a subtype, it returns the type. + -- For a type, it must return the type itself. + -- Get/Set_Base_Type (Field4) + -- + -- The staticness of a type, according to LRM93 7.4.1. + -- Note: These types definition are always locally static: + -- enumeration, integer, floating. + -- However, their subtype are not necessary locally static. + -- Get/Set_Type_Staticness (State1) + -- + -- The resolved flag of a subtype, according to LRM93 2.4 + -- Get/Set_Resolved_Flag (Flag1) + -- + -- The signal_type flag of a type definition. + -- It is true when the type can be used for a signal. + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) + + -- Iir_Kind_Enumeration_Type_Definition (Short) + -- + -- Get the range of the type (This is just an ascending range from the + -- first literal to the last declared literal). + -- Get/Set_Range_Constraint (Field1) + -- + -- Return the list of literals. This list is created when the node is + -- created. + -- Get/Set_Enumeration_Literal_List (Field2) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) + -- + -- Get/Set_Only_Characters_Flag (Flag4) + -- + -- Get/Set_Type_Staticness (State1) + + -- Iir_Kind_Enumeration_Literal (Medium) + -- + -- Nota: two literals of the same type are equal iff their value is the + -- same; in other words, there may be severals literals with the same + -- value. + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- Get/Set_Return_Type (Alias Field1) + -- + -- Get/Set_Literal_Origin (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- The declaration of the literal. If LITERAL_ORIGIN is not set, then this + -- is the node itself, else this is the literal defined. + -- Get/Set_Enumeration_Decl (Field6) + -- + -- The value of an enumeration literal is the position. + -- Get/Set_Enum_Pos (Field10) + -- + -- Get/Set_Subprogram_Hash (Field11) + -- + -- Get/Set_Seen_Flag (Flag1) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Never set to true, but possible when used as a prefix of an expanded + -- name in a overloaded subprogram. + -- Get/Set_Is_Within_Flag (Flag5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Physical_Type_Definition (Short) + -- + -- Get/Set_Unit_Chain (Field1) + -- Get/Set_Primary_Unit (Alias Field1) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) + -- + -- Get/Set_Type_Staticness (State1) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_Unit_Declaration (Medium) + -- + -- LRM08 5.2.4 Physical types + -- + -- primary_unit_declaration ::= identifier ; + -- + -- secondary_unit_declaration ::= identifier = physical_literal ; + -- + -- physical_literal ::= [ abstract_literal ] /unit/_name + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- The Physical_Literal is the expression that appear in the sources, so + -- this is Null_Iir for a primary unit. + -- Get/Set_Physical_Literal (Field6) + -- + -- The value of the unit, computed from the primary unit. This is always + -- a physical integer literal. + -- Get/Set_Physical_Unit_Value (Field7) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- LRM08 5.2 Scalar types + -- + -- range_constraint ::= RANGE range + -- + -- range ::= + -- range_attribute_name + -- | simple_expression direction simple_expression + -- + -- direction ::= to | downto + + -- Iir_Kind_Integer_Type_Definition (Short) + -- Iir_Kind_Floating_Type_Definition (Short) + -- + -- The type declarator that has created this type. + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Type staticness is always locally. + -- Get/Set_Type_Staticness (State1) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) + + -- Iir_Kind_Array_Type_Definition (Medium) + -- + -- LRM08 5.3.2 Array types / LRM93 3.2.1 + -- + -- unbounded_array_definition ::= + -- ARRAY ( index_subtype_definition { , index_subtype_definition } ) + -- OF element_subtype_indication + -- + -- index_subtype_definition ::= type_mark RANGE <> + -- + -- Get/Set_Element_Subtype (Field1) + -- + -- Get/Set_Element_Subtype_Indication (Field2) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- This is a list of type marks. + -- Get/Set_Index_Subtype_Definition_List (Field6) + -- + -- Same as the index_subtype_definition_list. + -- Get/Set_Index_Subtype_List (Field9) + -- + -- 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) + -- + -- LRM08 5.3.3 Record types / LRM93 3.2.2 Record types + -- + -- record_type_definition ::= + -- RECORD + -- element_declaration + -- { element_declaration } + -- END RECORD [ /record_type/_simple_name ] + -- + -- Get/Set_Elements_Declaration_List (Field1) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- 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_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_Access_Type_Definition (Short) + -- + -- LRM08 5.4 Access types + -- + -- access_type_definition ::= ACCESS subtype_indication + -- + -- Get/Set_Designated_Type (Field1) + -- + -- Get/Set_Designated_Subtype_Indication (Field5) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Type_Staticness (State1) + + -- Iir_Kind_File_Type_Definition (Short) + -- + -- Get/Set_File_Type_Mark (Field2) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- True if this is the std.textio.text file type, which may require special + -- handling. + -- Get/Set_Text_File_Flag (Flag4) + -- + -- Get/Set_Type_Staticness (State1) + + -- Iir_Kind_Incomplete_Type_Definition (Short) + -- Type definition for an incomplete type. This is created during the + -- semantisation of the incomplete type declaration. + -- + -- Get/Set_Incomplete_Type_List (Field2) + -- + -- Set to the incomplete type declaration when semantized, and set to the + -- complete type declaration when the latter one is semantized. + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Type_Staticness (State1) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) + + -- Iir_Kind_Protected_Type_Declaration (Short) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Protected_Type_Body (Field2) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Type_Staticness (State1) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_Protected_Type_Body (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Protected_Type_Declaration (Field4) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -------------------------- + -- subtype definitions -- + -------------------------- + + -- LRM08 6.3 Subtype declarations + -- + -- subtype_indication ::= + -- [ resolution_indication ] type_mark [ constraint ] + -- + -- There is no uniq representation for a subtype indication. If there is + -- only a type_mark, then a subtype indication is represented by a name + -- (a simple name or an expanded name); otherwise it is represented by one + -- of the subtype definition node. + -- + -- resolution_indication ::= + -- resolution_function_name | ( element_resolution ) + -- + -- element_resolution ::= array_element_resolution | record_resolution + -- + -- If there is no constraint but a resolution function name, the subtype + -- indication is represented by a subtype_definition (which will be + -- replaced by the correct subtype definition). If there is an array + -- element resolution the subtype indication is represented by an array + -- subtype definition, and if there is a record resolution, it is + -- represented by a record subtype definition. + -- + -- constraint ::= + -- range_constraint + -- | index_constraint + -- | array_constraint + -- | record_constraint + -- + -- There is no node for constraint, it is directly represented by one of + -- the rhs. + -- + -- element_constraint ::= + -- array_constraint + -- | record_constraint + -- + -- Likewise, there is no node for element_constraint. + -- + -- index_constraint ::= ( discrete_range { , discrete_range } ) + -- + -- An index_constraint is represented by an array_subtype_definition. + -- + -- discrete_range ::= /discrete/_subtype_indication | range + -- + -- array_constraint ::= + -- index_constraint [ array_element_constraint ] + -- | ( OPEN ) [ array_element_constraint ] + -- + -- An array_constraint is also represented by an array_subtype_definition. + -- + -- array_element_constraint ::= element_constraint + -- + -- There is no node for array_element_constraint. + -- + -- record_constraint ::= + -- ( record_element_constraint { , record_element_constraint } ) + -- + -- A record_constraint is represented by a record_subtype_definition. + -- + -- record_element_constraint ::= + -- record_element_simple_name element_constraint + -- + -- Represented by Record_Element_Constraint. + + -- Iir_Kind_Enumeration_Subtype_Definition (Short) + -- Iir_Kind_Integer_Subtype_Definition (Short) + -- Iir_Kind_Physical_Subtype_Definition (Short) + -- + -- Get/Set_Range_Constraint (Field1) + -- + -- Get/Set_Subtype_Type_Mark (Field2) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Resolution_Indication (Field5) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) + -- + -- Get/Set_Type_Staticness (State1) + + -- Iir_Kind_Floating_Subtype_Definition (Medium) + -- + -- Get/Set_Range_Constraint (Field1) + -- + -- Get/Set_Subtype_Type_Mark (Field2) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Resolution_Indication (Field5) + -- + -- Get/Set_Tolerance (Field7) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) + -- + -- Get/Set_Type_Staticness (State1) + + -- Iir_Kind_Access_Subtype_Definition (Short) + -- + -- Get/Set_Designated_Type (Field1) + -- + -- Get/Set_Subtype_Type_Mark (Field2) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Designated_Subtype_Indication (Field5) + -- + -- Note: no resolution function for access subtype. + -- + -- Get/Set_Type_Staticness (State1) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + + -- Iir_Kind_Array_Element_Resolution (Short) + -- + -- LRM08 6.3 Subtype declarations + -- + -- array_element_resolution ::= resolution_indication + -- + -- Get/Set_Resolution_Indication (Field5) + + -- Iir_Kind_Record_Resolution (Short) + -- + -- LRM08 6.3 Subtype declarations + -- + -- record_resolution ::= + -- record_element_resolution { , record_element_resolution } + -- + -- Get/Set_Record_Element_Resolution_Chain (Field1) + + -- Iir_Kind_Record_Element_Resolution (Short) + -- + -- LRM08 6.3 Subtype declarations + -- + -- record_element_resolution ::= + -- /record_element/_simple_name resolution_indication + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Resolution_Indication (Field5) + + -- Iir_Kind_Record_Subtype_Definition (Medium) + -- + -- Get/Set_Elements_Declaration_List (Field1) + -- + -- Get/Set_Subtype_Type_Mark (Field2) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Resolution_Indication (Field5) + -- + -- Get/Set_Tolerance (Field7) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) + -- + -- Get/Set_Type_Staticness (State1) + -- + -- Get/Set_Constraint_State (State2) + + -- Iir_Kind_Array_Subtype_Definition (Medium) + -- + -- Get/Set_Element_Subtype (Field1) + -- + -- Get/Set_Subtype_Type_Mark (Field2) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Resolution_Indication (Field5) + -- + -- The index_constraint list as it appears in the subtype indication (if + -- present). This is a list of subtype indication. + -- Get/Set_Index_Constraint_List (Field6) + -- + -- Get/Set_Tolerance (Field7) + -- + -- Get/Set_Array_Element_Constraint (Field8) + -- + -- The type of the index. This is either the index_constraint list or the + -- index subtypes of the type_mark. + -- Get/Set_Index_Subtype_List (Field9) + -- + -- 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) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Left_Limit (Field2) + -- + -- Get/Set_Right_Limit (Field3) + -- + -- Get/Set_Range_Origin (Field4) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Direction (State2) + + -- Iir_Kind_Subtype_Definition (Medium) + -- Such a node is only created by parse and transformed into the correct + -- kind (enumeration_subtype, integer_subtype...) by sem. + -- + -- Get/Set_Range_Constraint (Field1) + -- + -- Get/Set_Subtype_Type_Mark (Field2) + -- + -- Get/Set_Resolution_Indication (Field5) + -- + -- Get/Set_Tolerance (Field7) + + ------------------------- + -- Nature definitions -- + ------------------------- + + -- Iir_Kind_Scalar_Nature_Definition (Medium) + -- + -- Get/Set_Reference (Field2) + -- + -- The declarator that has created this nature type. + -- Get/Set_Nature_Declarator (Field3) + -- + -- C-- Get/Set_Base_Type (Field4) + -- + -- Type staticness is always locally. + -- C-- Get/Set_Type_Staticness (State1) + -- + -- Get/Set_Across_Type (Field7) + -- + -- Get/Set_Through_Type (Field8) + + ---------------------------- + -- concurrent statements -- + ---------------------------- + + -- Iir_Kind_Concurrent_Conditional_Signal_Assignment (Medium) + -- Iir_Kind_Concurrent_Selected_Signal_Assignment (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Target (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Only for Iir_Kind_Concurrent_Selected_Signal_Assignment: + -- Get/Set_Expression (Field5) + -- + -- Get/Set_Reject_Time_Expression (Field6) + -- + -- Only for Iir_Kind_Concurrent_Conditional_Signal_Assignment: + -- Get/Set_Conditional_Waveform_Chain (Field7) + -- + -- Only for Iir_Kind_Concurrent_Selected_Signal_Assignment: + -- Get/Set_Selected_Waveform_Chain (Field7) + -- + -- If the assignment is guarded, then get_guard must return the + -- declaration of the signal guard, otherwise, null_iir. + -- If the guard signal decl is not known, as a kludge and only to mark this + -- assignment guarded, the guard can be this assignment. + -- Get/Set_Guard (Field8) + -- + -- Get/Set_Delay_Mechanism (Field12) + -- + -- Get/Set_Postponed_Flag (Flag3) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- True if the target of the assignment is guarded + -- Get/Set_Guarded_Target_State (State3) + + -- Iir_Kind_Sensitized_Process_Statement (Medium) + -- Iir_Kind_Process_Statement (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Sequential_Statement_Chain (Field5) + -- + -- Only for Iir_Kind_Sensitized_Process_Statement: + -- Get/Set_Sensitivity_List (Field6) + -- + -- Get/Set_Callees_List (Field7) + -- + -- The concurrent statement at the origin of that process. This is + -- Null_Iir for a user process. + -- Get/Set_Process_Origin (Field8) + -- + -- Get/Set_Wait_State (State1) + -- + -- Get/Set_Seen_Flag (Flag1) + -- + -- Get/Set_Passive_Flag (Flag2) + -- + -- Get/Set_Postponed_Flag (Flag3) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Is_Within_Flag (Flag5) + -- + -- Get/Set_Has_Is (Flag7) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + -- + -- Get/Set_End_Has_Postponed (Flag10) + + -- Iir_Kind_Concurrent_Assertion_Statement (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Assertion_Condition (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Severity_Expression (Field5) + -- + -- Get/Set_Report_Expression (Field6) + -- + -- Get/Set_Postponed_Flag (Flag3) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Psl_Default_Clock (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Psl_Boolean (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + + -- Iir_Kind_Psl_Assert_Statement (Medium) + -- Iir_Kind_Psl_Cover_Statement (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Psl_Property (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Severity_Expression (Field5) + -- + -- Get/Set_Report_Expression (Field6) + -- + -- Get/Set_PSL_Clock (Field7) + -- + -- Get/Set_PSL_NFA (Field8) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Component_Instantiation_Statement (Medium) + -- + -- LRM08 11.7 Component instantiation statements + -- + -- component_instantiation_statement ::= + -- instantiation_label : + -- instantiated_unit + -- [ generic_map_aspect ] + -- [ port_map_aspect ] ; + -- + -- instantiated_unit ::= + -- [ COMPONENT ] component_name + -- | ENTITY entity_name [ ( architecture_identifier ) ] + -- | CONFIGURATION configuration_name + -- + -- Get/Set_Parent (Field0) + -- + -- Unit instantiated. This is a name, an entity_aspect_entity or an + -- entity_aspect_configuration. + -- Get/Set_Instantiated_Unit (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Default_Binding_Indication (Field5) + -- + -- Get/Set_Generic_Map_Aspect_Chain (Field8) + -- + -- Get/Set_Port_Map_Aspect_Chain (Field9) + -- + -- Configuration: + -- In case of a configuration specification, the node is put into + -- default configuration. In the absence of a specification, the + -- default entity aspect, if any; if none, this field is null_iir. + -- Get/Set_Configuration_Specification (Field7) + -- + -- During Sem and elaboration, the configuration field can be filled by + -- a component configuration declaration. + -- + -- Configuration for this component. + -- FIXME: must be get/set_binding_indication. + -- Get/Set_Component_Configuration (Field6) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Block_Statement (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Concurrent_Statement_Chain (Field5) + -- + -- Get/Set_Block_Block_Configuration (Field6) + -- + -- Get/Set_Block_Header (Field7) + -- + -- get/set_guard_decl is used for semantic analysis, in order to add + -- a signal declaration. + -- Get/Set_Guard_Decl (Field8) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Is_Within_Flag (Flag5) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_Generate_Statement (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Concurrent_Statement_Chain (Field5) + -- + -- The generation scheme. + -- A (boolean) expression for a conditionnal elaboration (if). + -- A (iterator) declaration for an iterative elaboration (for). + -- Get/Set_Generation_Scheme (Field6) + -- + -- The block configuration for this statement. + -- Get/Set_Generate_Block_Configuration (Field7) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_End_Has_Reserved_Id (Flag8) + -- + -- Get/Set_End_Has_Identifier (Flag9) + -- + -- Get/Set_Has_Begin (Flag10) + + -- Iir_Kind_Simple_Simultaneous_Statement (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Simultaneous_Left (Field5) + -- + -- Get/Set_Simultaneous_Right (Field6) + -- + -- Get/Set_Tolerance (Field7) + -- + -- Get/Set_Visible_Flag (Flag4) + + ---------------------------- + -- sequential statements -- + ---------------------------- + + -- Iir_Kind_If_Statement (Medium) + -- Iir_Kind_Elsif (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- May be NULL only for an iir_kind_elsif node, and then means the else + -- clause. + -- Get/Set_Condition (Field1) + -- + -- Only for Iir_Kind_If_Statement: + -- Get/Set_Chain (Field2) + -- + -- Only for Iir_Kind_If_Statement: + -- Get/Set_Label (Field3) + -- + -- Only for Iir_Kind_If_Statement: + -- Get/Set_Identifier (Alias Field3) + -- + -- Only for Iir_Kind_If_Statement: + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Sequential_Statement_Chain (Field5) + -- + -- Must be an Iir_kind_elsif node, or NULL for no more elsif clauses. + -- Get/Set_Else_Clause (Field6) + -- + -- Only for Iir_Kind_If_Statement: + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- LRM08 10.10 Loop statement / LRM93 8.9 + -- + -- loop_statement ::= + -- [ loop_label : ] + -- [ iteration_scheme ] LOOP + -- sequence_of_statements + -- END LOOP [ loop_label ] ; + -- + -- iteration_scheme ::= + -- WHILE condition + -- | FOR loop_parameter_specification + -- + -- parameter_specification ::= + -- identifier IN discrete_range + + -- Iir_Kind_For_Loop_Statement (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- The parameters specification is represented by an Iterator_Declaration. + -- Get/Set_Parameter_Specification (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Sequential_Statement_Chain (Field5) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Is_Within_Flag (Flag5) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_While_Loop_Statement (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Condition (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Sequential_Statement_Chain (Field5) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_Exit_Statement (Short) + -- Iir_Kind_Next_Statement (Short) + -- + -- LRM08 10.11 Next statement + -- + -- next_statement ::= + -- [ label : ] NEXT [ loop_label ] [ WHEN condition ] ; + -- + -- LRM08 10.12 Exit statement + -- + -- exit_statement ::= + -- [ label : ] exit [ loop_label ] [ when condition ] ; + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Condition (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Loop_Label (Field5) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Signal_Assignment_Statement (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Target (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- The waveform. + -- If the waveform_chain is null_iir, then the signal assignment is a + -- disconnection statement, ie TARGET <= null_iir after disconection_time, + -- where disconnection_time is specified by a disconnection specification. + -- Get/Set_Waveform_Chain (Field5) + -- + -- Get/Set_Reject_Time_Expression (Field6) + -- + -- Get/Set_Delay_Mechanism (Field12) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- True if the target of the assignment is guarded + -- Get/Set_Guarded_Target_State (State3) + + -- Iir_Kind_Variable_Assignment_Statement (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Target (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Expression (Field5) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Assertion_Statement (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Assertion_Condition (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Severity_Expression (Field5) + -- + -- Get/Set_Report_Expression (Field6) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Report_Statement (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Severity_Expression (Field5) + -- + -- Get/Set_Report_Expression (Field6) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Wait_Statement (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Timeout_Clause (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Condition_Clause (Field5) + -- + -- Get/Set_Sensitivity_List (Field6) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Return_Statement (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Type of the return value of the function. This is a copy of + -- return_type. + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Expression (Field5) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Case_Statement (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Chain is compose of Iir_Kind_Choice_By_XXX. + -- Get/Set_Case_Statement_Alternative_Chain (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Expression (Field5) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_End_Has_Identifier (Flag9) + + -- Iir_Kind_Procedure_Call_Statement (Short) + -- Iir_Kind_Concurrent_Procedure_Call_Statement (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Procedure_Call (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Only for Iir_Kind_Concurrent_Procedure_Call_Statement: + -- Get/Set_Postponed_Flag (Flag3) + -- + -- Get/Set_Visible_Flag (Flag4) + + -- Iir_Kind_Procedure_Call (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Parameter_Association_Chain (Field2) + -- + -- Procedure declaration corresponding to the procedure to call. + -- Get/Set_Implementation (Field3) + -- + -- Get/Set_Method_Object (Field4) + + -- Iir_Kind_Null_Statement (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Visible_Flag (Flag4) + + ---------------- + -- operators -- + ---------------- + + -- Iir_Kinds_Monadic_Operator (Short) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Operand (Field2) + -- + -- Function declaration corresponding to the function to call. + -- Get/Set_Implementation (Field3) + -- + -- Expr_staticness is defined by §7.4 + -- Get/Set_Expr_Staticness (State1) + + -- Iir_Kinds_Dyadic_Operator (Short) + -- + -- Get/Set_Type (Field1) + -- + -- Left and Right operands. + -- Get/Set_Left (Field2) + -- + -- Function declaration corresponding to the function to call. + -- Get/Set_Implementation (Field3) + -- + -- Get/Set_Right (Field4) + -- + -- Get/Set_Expr_Staticness (State1) + + -- Iir_Kind_Function_Call (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Parameter_Association_Chain (Field2) + -- + -- Function declaration corresponding to the function to call. + -- Get/Set_Implementation (Field3) + -- + -- Get/Set_Method_Object (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Aggregate (Short) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Aggregate_Info (Field2) + -- + -- Get/Set_Association_Choices_Chain (Field4) + -- + -- Same as Type, but marked as property of that node. + -- Get/Set_Literal_Subtype (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Value_Staticness (State2) + + -- Iir_Kind_Aggregate_Info (Short) + -- + -- Get info for the next dimension. NULL_IIR terminated. + -- Get/Set_Sub_Aggregate_Info (Field1) + -- + -- For array aggregate only: + -- If TRUE, the choices are not locally static. + -- This flag is only valid when the array aggregate is constrained, ie + -- has no 'others' choice. + -- Get/Set_Aggr_Dynamic_Flag (Flag3) + -- + -- If TRUE, the aggregate is named, else it is positionnal. + -- Get/Set_Aggr_Named_Flag (Flag4) + -- + -- The following three fields are used to check bounds of an array + -- aggregate. + -- For named aggregate, low and high bounds are computed, for positionnal + -- aggregate, the (minimum) number of elements is computed. + -- Note there may be elements beyond the bounds, due to other choice. + -- These fields may apply for the aggregate or for the aggregate and its + -- brothers if the node is for a sub-aggregate. + -- + -- The low and high index choice, if any. + -- Get/Set_Aggr_Low_Limit (Field2) + -- + -- Get/Set_Aggr_High_Limit (Field3) + -- + -- The minimum number of elements, if any. This is a minimax. + -- Get/Set_Aggr_Min_Length (Field4) + -- + -- True if the choice list has an 'others' choice. + -- Get/Set_Aggr_Others_Flag (Flag2) + + -- Iir_Kind_Parenthesis_Expression (Short) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Expression (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + + -- Iir_Kind_Qualified_Expression (Short) + -- + -- LRM08 9.3.5 Qualified expressions + -- + -- qualified_expression ::= + -- type_mark ' ( expression ) + -- | type_mark ' aggregate + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Type_Mark (Field4) + -- + -- Get/Set_Expression (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + + -- Iir_Kind_Type_Conversion (Short) + -- + -- LRM08 9.3.6 Type conversions + -- + -- type_conversion ::= type_mark ( expression ) + -- + -- Get/Set_Type (Field1) + -- + -- If the type mark denotes an unconstrained array and the expression is + -- locally static, the result should be locally static according to vhdl93 + -- (which is not clear on that point). As a subtype is created, it is + -- referenced by this field. + -- Get/Set_Type_Conversion_Subtype (Field3) + -- + -- Get/Set_Type_Mark (Field4) + -- + -- Get/Set_Expression (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + + -- Iir_Kind_Allocator_By_Expression (Short) + -- Iir_Kind_Allocator_By_Subtype (Short) + -- + -- LRM08 9.3.7 Allocators + -- + -- allocator ::= + -- NEW subtype_indication + -- | NEW qualified_expression + -- + -- Get/Set_Type (Field1) + -- + -- To ease analysis: set to the designated type (either the type of the + -- expression or the subtype) + -- Get/Set_Allocator_Designated_Type (Field2) + -- + -- Only for Iir_Kind_Allocator_By_Expression: + -- Contains the expression for a by expression allocator. + -- Get/Set_Expression (Field5) + -- + -- Only for Iir_Kind_Allocator_By_Subtype: + -- Contains the subtype indication for a by subtype allocator. + -- Get/Set_Subtype_Indication (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + + ------------ + -- Names -- + ------------ + + -- Iir_Kind_Simple_Name (Short) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Alias_Declaration (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Named_Entity (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Character_Literal (Short) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Alias_Declaration (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Named_Entity (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Operator_Symbol (Short) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Alias_Declaration (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Named_Entity (Field4) + -- + -- Get/Set_Base_Name (Field5) + + -- Iir_Kind_Selected_Name (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Alias_Declaration (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Named_Entity (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Selected_By_All_Name (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Named_Entity (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + + -- Iir_Kind_Indexed_Name (Short) + -- Select the element designed with the INDEX_LIST from array PREFIX. + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Index_List (Field2) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Slice_Name (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Suffix (Field2) + -- + -- Get/Set_Slice_Subtype (Field3) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Parenthesis_Name (Short) + -- Created by the parser, and mutated into the correct iir node: it can be + -- either a function call, an indexed array, a type conversion or a slice + -- name. + -- + -- Get/Set_Prefix (Field0) + -- + -- Always returns null_iir. + -- Get/Set_Type (Field1) + -- + -- Get/Set_Association_Chain (Field2) + -- + -- Get/Set_Named_Entity (Field4) + + -- Iir_Kind_Selected_Element (Short) + -- A record element selection. This corresponds to a reffined selected + -- names. The production doesn't exist in the VHDL grammar. + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Selected_Element (Field2) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Implicit_Dereference (Short) + -- Iir_Kind_Dereference (Short) + -- An implicit access dereference. + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + ----------------- + -- Attributes -- + ----------------- + + -- Iir_Kind_Attribute_Name (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Attribute_Signature (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Named_Entity (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Base_Attribute (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + + -- Iir_Kind_Left_Type_Attribute (Short) + -- Iir_Kind_Right_Type_Attribute (Short) + -- Iir_Kind_High_Type_Attribute (Short) + -- Iir_Kind_Low_Type_Attribute (Short) + -- Iir_Kind_Ascending_Type_Attribute (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Range_Array_Attribute (Short) + -- Iir_Kind_Reverse_Range_Array_Attribute (Short) + -- Iir_Kind_Left_Array_Attribute (Short) + -- Iir_Kind_Right_Array_Attribute (Short) + -- Iir_Kind_High_Array_Attribute (Short) + -- Iir_Kind_Low_Array_Attribute (Short) + -- Iir_Kind_Ascending_Array_Attribute (Short) + -- Iir_Kind_Length_Array_Attribute (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Index_Subtype (Field2) + -- + -- Get/Set_Parameter (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Stable_Attribute (Short) + -- Iir_Kind_Delayed_Attribute (Short) + -- Iir_Kind_Quiet_Attribute (Short) + -- Iir_Kind_Transaction_Attribute (Short) + -- (Iir_Kinds_Signal_Attribute) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Not used by Iir_Kind_Transaction_Attribute + -- Get/Set_Parameter (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Has_Active_Flag (Flag2) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Event_Attribute (Short) + -- Iir_Kind_Last_Event_Attribute (Short) + -- Iir_Kind_Last_Value_Attribute (Short) + -- Iir_Kind_Active_Attribute (Short) + -- Iir_Kind_Last_Active_Attribute (Short) + -- Iir_Kind_Driving_Attribute (Short) + -- Iir_Kind_Driving_Value_Attribute (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Pos_Attribute (Short) + -- Iir_Kind_Val_Attribute (Short) + -- Iir_Kind_Succ_Attribute (Short) + -- Iir_Kind_Pred_Attribute (Short) + -- Iir_Kind_Leftof_Attribute (Short) + -- Iir_Kind_Rightof_Attribute (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Parameter (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Image_Attribute (Short) + -- Iir_Kind_Value_Attribute (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Parameter (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Simple_Name_Attribute (Short) + -- Iir_Kind_Instance_Name_Attribute (Short) + -- Iir_Kind_Path_Name_Attribute (Short) + -- + -- Get/Set_Prefix (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Only for Iir_Kind_Simple_Name_Attribute: + -- Get/Set_Simple_Name_Identifier (Field3) + -- + -- Only for Iir_Kind_Simple_Name_Attribute: + -- Get/Set_Simple_Name_Subtype (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Behavior_Attribute (Short) + -- Iir_Kind_Structure_Attribute (Short) + -- FIXME: to describe (Short) + + -- Iir_Kind_Error (Short) + -- Can be used instead of an expression or a type. + -- Get/Set_Type (Field1) + -- + -- Get/Set_Error_Origin (Field2) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Type_Staticness (Alias State1) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) + + -- Iir_Kind_Unused (Short) + + -- End of Iir_Kind. + + + type Iir_Kind is + ( + Iir_Kind_Unused, + Iir_Kind_Error, + + Iir_Kind_Design_File, + Iir_Kind_Design_Unit, + Iir_Kind_Library_Clause, + Iir_Kind_Use_Clause, + + -- Literals. + Iir_Kind_Integer_Literal, + Iir_Kind_Floating_Point_Literal, + Iir_Kind_Null_Literal, + Iir_Kind_String_Literal, + Iir_Kind_Physical_Int_Literal, + Iir_Kind_Physical_Fp_Literal, + Iir_Kind_Bit_String_Literal, + Iir_Kind_Simple_Aggregate, + Iir_Kind_Overflow_Literal, + + -- Tuple, + Iir_Kind_Waveform_Element, + Iir_Kind_Conditional_Waveform, + Iir_Kind_Association_Element_By_Expression, + Iir_Kind_Association_Element_By_Individual, + Iir_Kind_Association_Element_Open, + Iir_Kind_Association_Element_Package, + Iir_Kind_Choice_By_Others, + Iir_Kind_Choice_By_Expression, + Iir_Kind_Choice_By_Range, + Iir_Kind_Choice_By_None, + Iir_Kind_Choice_By_Name, + Iir_Kind_Entity_Aspect_Entity, + Iir_Kind_Entity_Aspect_Configuration, + Iir_Kind_Entity_Aspect_Open, + Iir_Kind_Block_Configuration, + Iir_Kind_Block_Header, + Iir_Kind_Component_Configuration, + Iir_Kind_Binding_Indication, + Iir_Kind_Entity_Class, + Iir_Kind_Attribute_Value, + Iir_Kind_Signature, + Iir_Kind_Aggregate_Info, + Iir_Kind_Procedure_Call, + Iir_Kind_Record_Element_Constraint, + Iir_Kind_Array_Element_Resolution, + Iir_Kind_Record_Resolution, + Iir_Kind_Record_Element_Resolution, + + Iir_Kind_Attribute_Specification, + Iir_Kind_Disconnection_Specification, + Iir_Kind_Configuration_Specification, + + -- Type definitions. + -- iir_kinds_type_and_subtype_definition + -- kinds: disc: discrete, st: subtype. + Iir_Kind_Access_Type_Definition, + Iir_Kind_Incomplete_Type_Definition, + Iir_Kind_File_Type_Definition, + Iir_Kind_Protected_Type_Declaration, + Iir_Kind_Record_Type_Definition, -- composite + Iir_Kind_Array_Type_Definition, -- composite, array + Iir_Kind_Array_Subtype_Definition, -- composite, array, st + Iir_Kind_Record_Subtype_Definition, -- composite, st + Iir_Kind_Access_Subtype_Definition, -- st + Iir_Kind_Physical_Subtype_Definition, -- scalar, st, rng + Iir_Kind_Floating_Subtype_Definition, -- scalar, st, rng + Iir_Kind_Integer_Subtype_Definition, -- scalar, disc, st, rng + Iir_Kind_Enumeration_Subtype_Definition, -- scalar, disc, st, rng + Iir_Kind_Enumeration_Type_Definition, -- scalar, disc, rng + Iir_Kind_Integer_Type_Definition, -- scalar, disc + Iir_Kind_Floating_Type_Definition, -- scalar + Iir_Kind_Physical_Type_Definition, -- scalar + Iir_Kind_Range_Expression, + Iir_Kind_Protected_Type_Body, + Iir_Kind_Subtype_Definition, -- temporary (must not appear after sem). + + -- Nature definition + Iir_Kind_Scalar_Nature_Definition, + + -- Lists. + Iir_Kind_Overload_List, -- used internally by sem_expr. + + -- Declarations. + Iir_Kind_Type_Declaration, + Iir_Kind_Anonymous_Type_Declaration, + Iir_Kind_Subtype_Declaration, + Iir_Kind_Nature_Declaration, + Iir_Kind_Subnature_Declaration, + Iir_Kind_Package_Declaration, + Iir_Kind_Package_Instantiation_Declaration, + Iir_Kind_Package_Body, + Iir_Kind_Configuration_Declaration, + Iir_Kind_Entity_Declaration, + Iir_Kind_Architecture_Body, + Iir_Kind_Package_Header, + Iir_Kind_Unit_Declaration, + Iir_Kind_Library_Declaration, + Iir_Kind_Component_Declaration, + 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_Psl_Declaration, + Iir_Kind_Terminal_Declaration, + Iir_Kind_Free_Quantity_Declaration, + Iir_Kind_Across_Quantity_Declaration, + Iir_Kind_Through_Quantity_Declaration, + + Iir_Kind_Enumeration_Literal, + Iir_Kind_Function_Declaration, -- Subprg, Func + Iir_Kind_Implicit_Function_Declaration, -- Subprg, Func, Imp_Subprg + Iir_Kind_Implicit_Procedure_Declaration, -- Subprg, Proc, Imp_Subprg + Iir_Kind_Procedure_Declaration, -- Subprg, Proc + Iir_Kind_Function_Body, + Iir_Kind_Procedure_Body, + + Iir_Kind_Object_Alias_Declaration, -- object + Iir_Kind_File_Declaration, -- object + Iir_Kind_Guard_Signal_Declaration, -- object + Iir_Kind_Signal_Declaration, -- object + Iir_Kind_Variable_Declaration, -- object + Iir_Kind_Constant_Declaration, -- object + Iir_Kind_Iterator_Declaration, -- object + Iir_Kind_Interface_Constant_Declaration, -- object, interface + Iir_Kind_Interface_Variable_Declaration, -- object, interface + Iir_Kind_Interface_Signal_Declaration, -- object, interface + Iir_Kind_Interface_File_Declaration, -- object, interface + Iir_Kind_Interface_Package_Declaration, + + -- Expressions. + Iir_Kind_Identity_Operator, + Iir_Kind_Negation_Operator, + Iir_Kind_Absolute_Operator, + Iir_Kind_Not_Operator, + Iir_Kind_Condition_Operator, + Iir_Kind_Reduction_And_Operator, + Iir_Kind_Reduction_Or_Operator, + Iir_Kind_Reduction_Nand_Operator, + Iir_Kind_Reduction_Nor_Operator, + Iir_Kind_Reduction_Xor_Operator, + Iir_Kind_Reduction_Xnor_Operator, + Iir_Kind_And_Operator, + Iir_Kind_Or_Operator, + Iir_Kind_Nand_Operator, + Iir_Kind_Nor_Operator, + Iir_Kind_Xor_Operator, + Iir_Kind_Xnor_Operator, + Iir_Kind_Equality_Operator, + Iir_Kind_Inequality_Operator, + Iir_Kind_Less_Than_Operator, + Iir_Kind_Less_Than_Or_Equal_Operator, + Iir_Kind_Greater_Than_Operator, + Iir_Kind_Greater_Than_Or_Equal_Operator, + Iir_Kind_Match_Equality_Operator, + Iir_Kind_Match_Inequality_Operator, + Iir_Kind_Match_Less_Than_Operator, + Iir_Kind_Match_Less_Than_Or_Equal_Operator, + Iir_Kind_Match_Greater_Than_Operator, + Iir_Kind_Match_Greater_Than_Or_Equal_Operator, + Iir_Kind_Sll_Operator, + Iir_Kind_Sla_Operator, + Iir_Kind_Srl_Operator, + Iir_Kind_Sra_Operator, + Iir_Kind_Rol_Operator, + Iir_Kind_Ror_Operator, + Iir_Kind_Addition_Operator, + Iir_Kind_Substraction_Operator, + Iir_Kind_Concatenation_Operator, + Iir_Kind_Multiplication_Operator, + Iir_Kind_Division_Operator, + Iir_Kind_Modulus_Operator, + Iir_Kind_Remainder_Operator, + Iir_Kind_Exponentiation_Operator, + Iir_Kind_Function_Call, + Iir_Kind_Aggregate, + Iir_Kind_Parenthesis_Expression, + Iir_Kind_Qualified_Expression, + Iir_Kind_Type_Conversion, + Iir_Kind_Allocator_By_Expression, + Iir_Kind_Allocator_By_Subtype, + Iir_Kind_Selected_Element, + Iir_Kind_Dereference, + Iir_Kind_Implicit_Dereference, + Iir_Kind_Slice_Name, + Iir_Kind_Indexed_Name, + Iir_Kind_Psl_Expression, + + -- Concurrent statements. + Iir_Kind_Sensitized_Process_Statement, + Iir_Kind_Process_Statement, + Iir_Kind_Concurrent_Conditional_Signal_Assignment, + Iir_Kind_Concurrent_Selected_Signal_Assignment, + Iir_Kind_Concurrent_Assertion_Statement, + Iir_Kind_Psl_Default_Clock, + Iir_Kind_Psl_Assert_Statement, + Iir_Kind_Psl_Cover_Statement, + Iir_Kind_Concurrent_Procedure_Call_Statement, + Iir_Kind_Block_Statement, + Iir_Kind_Generate_Statement, + Iir_Kind_Component_Instantiation_Statement, + + Iir_Kind_Simple_Simultaneous_Statement, + + -- Iir_Kind_Sequential_Statement + Iir_Kind_Signal_Assignment_Statement, + Iir_Kind_Null_Statement, + Iir_Kind_Assertion_Statement, + Iir_Kind_Report_Statement, + Iir_Kind_Wait_Statement, + Iir_Kind_Variable_Assignment_Statement, + Iir_Kind_Return_Statement, + Iir_Kind_For_Loop_Statement, + Iir_Kind_While_Loop_Statement, + Iir_Kind_Next_Statement, + Iir_Kind_Exit_Statement, + Iir_Kind_Case_Statement, + Iir_Kind_Procedure_Call_Statement, + Iir_Kind_If_Statement, + Iir_Kind_Elsif, + + -- Names + Iir_Kind_Character_Literal, -- denoting_name + Iir_Kind_Simple_Name, -- denoting_name + Iir_Kind_Selected_Name, -- denoting_name + Iir_Kind_Operator_Symbol, -- denoting_name + + Iir_Kind_Selected_By_All_Name, + Iir_Kind_Parenthesis_Name, + + -- Attributes + Iir_Kind_Base_Attribute, + Iir_Kind_Left_Type_Attribute, -- type_attribute + Iir_Kind_Right_Type_Attribute, -- type_attribute + Iir_Kind_High_Type_Attribute, -- type_attribute + Iir_Kind_Low_Type_Attribute, -- type_attribute + Iir_Kind_Ascending_Type_Attribute, -- type_attribute + Iir_Kind_Image_Attribute, + Iir_Kind_Value_Attribute, + Iir_Kind_Pos_Attribute, -- scalar_type_attribute + Iir_Kind_Val_Attribute, -- scalar_type_attribute + Iir_Kind_Succ_Attribute, -- scalar_type_attribute + Iir_Kind_Pred_Attribute, -- scalar_type_attribute + Iir_Kind_Leftof_Attribute, -- scalar_type_attribute + Iir_Kind_Rightof_Attribute, -- scalar_type_attribute + Iir_Kind_Delayed_Attribute, -- signal_attribute + Iir_Kind_Stable_Attribute, -- signal_attribute + Iir_Kind_Quiet_Attribute, -- signal_attribute + Iir_Kind_Transaction_Attribute, -- signal_attribute + Iir_Kind_Event_Attribute, -- signal_value_attribute + Iir_Kind_Active_Attribute, -- signal_value_attribute + Iir_Kind_Last_Event_Attribute, -- signal_value_attribute + Iir_Kind_Last_Active_Attribute, -- signal_value_attribute + Iir_Kind_Last_Value_Attribute, -- signal_value_attribute + Iir_Kind_Driving_Attribute, -- signal_value_attribute + Iir_Kind_Driving_Value_Attribute, -- signal_value_attribute + Iir_Kind_Behavior_Attribute, + Iir_Kind_Structure_Attribute, + Iir_Kind_Simple_Name_Attribute, + Iir_Kind_Instance_Name_Attribute, + Iir_Kind_Path_Name_Attribute, + Iir_Kind_Left_Array_Attribute, -- array_attribute + Iir_Kind_Right_Array_Attribute, -- array_attribute + Iir_Kind_High_Array_Attribute, -- array_attribute + Iir_Kind_Low_Array_Attribute, -- array_attribute + Iir_Kind_Length_Array_Attribute, -- array_attribute + Iir_Kind_Ascending_Array_Attribute, -- array_attribute + Iir_Kind_Range_Array_Attribute, -- array_attribute + Iir_Kind_Reverse_Range_Array_Attribute, -- array_attribute + + Iir_Kind_Attribute_Name + ); + + type Iir_Signal_Kind is + ( + Iir_No_Signal_Kind, + Iir_Register_Kind, + Iir_Bus_Kind + ); + + -- If the order of elements in IIR_MODE is modified, also modify the + -- order in GRT (types and rtis). + type Iir_Mode is + ( + Iir_Unknown_Mode, + Iir_Linkage_Mode, + Iir_Buffer_Mode, + Iir_Out_Mode, + Iir_Inout_Mode, + Iir_In_Mode + ); + + subtype Iir_In_Modes is Iir_Mode range Iir_Inout_Mode .. Iir_In_Mode; + subtype Iir_Out_Modes is Iir_Mode range Iir_Out_Mode .. Iir_Inout_Mode; + + type Iir_Delay_Mechanism is (Iir_Inertial_Delay, Iir_Transport_Delay); + + type Iir_Direction is (Iir_To, Iir_Downto); + + -- Iir_Lexical_Layout_type describe the lexical token used to describe + -- an interface declaration. This has no semantics meaning, but it is + -- necessary to keep how lexically an interface was declared due to + -- LRM93 2.7 (conformance rules). + -- To keep this simple, the layout is stored as a bit-string. + -- Fields are: + -- Has_type: set if the interface is the last of a list. + -- has_mode: set if mode is explicit + -- has_class: set if class (constant, signal, variable or file) is explicit + -- + -- Exemple: + -- procedure P ( A, B: integer; + -- constant C: in bit; + -- D: inout bit; + -- variable E: bit; + -- F, G: in bit; + -- constant H, I: bit; + -- constant J, K: in bit); + -- A: + -- B: has_type + -- C, has_class, has_mode, has_type + -- D: has_mode, has_type + -- E, has_class, has_type + -- F: has_mode + -- G: has_mode, has_type + -- H: has_class + -- I: has_class, has_type + -- J: has_class, has_mode + -- K: has_class, has_mode, has_type + type Iir_Lexical_Layout_Type is mod 2 ** 3; + Iir_Lexical_Has_Mode : constant Iir_Lexical_Layout_Type := 2 ** 0; + Iir_Lexical_Has_Class : constant Iir_Lexical_Layout_Type := 2 ** 1; + Iir_Lexical_Has_Type : constant Iir_Lexical_Layout_Type := 2 ** 2; + + -- List of predefined operators and functions. + type Iir_Predefined_Functions is + ( + Iir_Predefined_Error, + + -- Predefined operators for BOOLEAN type. + Iir_Predefined_Boolean_And, + Iir_Predefined_Boolean_Or, + Iir_Predefined_Boolean_Nand, + Iir_Predefined_Boolean_Nor, + Iir_Predefined_Boolean_Xor, + Iir_Predefined_Boolean_Xnor, + Iir_Predefined_Boolean_Not, + + Iir_Predefined_Boolean_Rising_Edge, + Iir_Predefined_Boolean_Falling_Edge, + + -- Predefined operators for any enumeration type. + Iir_Predefined_Enum_Equality, + Iir_Predefined_Enum_Inequality, + Iir_Predefined_Enum_Less, + Iir_Predefined_Enum_Less_Equal, + Iir_Predefined_Enum_Greater, + Iir_Predefined_Enum_Greater_Equal, + + Iir_Predefined_Enum_Minimum, + Iir_Predefined_Enum_Maximum, + Iir_Predefined_Enum_To_String, + + -- Predefined operators for BIT type. + Iir_Predefined_Bit_And, + Iir_Predefined_Bit_Or, + Iir_Predefined_Bit_Nand, + Iir_Predefined_Bit_Nor, + Iir_Predefined_Bit_Xor, + Iir_Predefined_Bit_Xnor, + Iir_Predefined_Bit_Not, + + Iir_Predefined_Bit_Match_Equality, + Iir_Predefined_Bit_Match_Inequality, + Iir_Predefined_Bit_Match_Less, + Iir_Predefined_Bit_Match_Less_Equal, + Iir_Predefined_Bit_Match_Greater, + Iir_Predefined_Bit_Match_Greater_Equal, + + Iir_Predefined_Bit_Condition, + + Iir_Predefined_Bit_Rising_Edge, + Iir_Predefined_Bit_Falling_Edge, + + -- Predefined operators for any integer type. + Iir_Predefined_Integer_Equality, + Iir_Predefined_Integer_Inequality, + Iir_Predefined_Integer_Less, + Iir_Predefined_Integer_Less_Equal, + Iir_Predefined_Integer_Greater, + Iir_Predefined_Integer_Greater_Equal, + + Iir_Predefined_Integer_Identity, + Iir_Predefined_Integer_Negation, + Iir_Predefined_Integer_Absolute, + + Iir_Predefined_Integer_Plus, + Iir_Predefined_Integer_Minus, + Iir_Predefined_Integer_Mul, + Iir_Predefined_Integer_Div, + Iir_Predefined_Integer_Mod, + Iir_Predefined_Integer_Rem, + + Iir_Predefined_Integer_Exp, + + Iir_Predefined_Integer_Minimum, + Iir_Predefined_Integer_Maximum, + Iir_Predefined_Integer_To_String, + + -- Predefined operators for any floating type. + Iir_Predefined_Floating_Equality, + Iir_Predefined_Floating_Inequality, + Iir_Predefined_Floating_Less, + Iir_Predefined_Floating_Less_Equal, + Iir_Predefined_Floating_Greater, + Iir_Predefined_Floating_Greater_Equal, + + Iir_Predefined_Floating_Identity, + Iir_Predefined_Floating_Negation, + Iir_Predefined_Floating_Absolute, + + Iir_Predefined_Floating_Plus, + Iir_Predefined_Floating_Minus, + Iir_Predefined_Floating_Mul, + Iir_Predefined_Floating_Div, + + Iir_Predefined_Floating_Exp, + + Iir_Predefined_Floating_Minimum, + Iir_Predefined_Floating_Maximum, + Iir_Predefined_Floating_To_String, + + Iir_Predefined_Real_To_String_Digits, + Iir_Predefined_Real_To_String_Format, + + -- Predefined operator for universal types. + Iir_Predefined_Universal_R_I_Mul, + Iir_Predefined_Universal_I_R_Mul, + Iir_Predefined_Universal_R_I_Div, + + -- Predefined operators for physical types. + Iir_Predefined_Physical_Equality, + Iir_Predefined_Physical_Inequality, + Iir_Predefined_Physical_Less, + Iir_Predefined_Physical_Less_Equal, + Iir_Predefined_Physical_Greater, + Iir_Predefined_Physical_Greater_Equal, + + Iir_Predefined_Physical_Identity, + Iir_Predefined_Physical_Negation, + Iir_Predefined_Physical_Absolute, + + Iir_Predefined_Physical_Plus, + Iir_Predefined_Physical_Minus, + + Iir_Predefined_Physical_Integer_Mul, + Iir_Predefined_Physical_Real_Mul, + Iir_Predefined_Integer_Physical_Mul, + Iir_Predefined_Real_Physical_Mul, + Iir_Predefined_Physical_Integer_Div, + Iir_Predefined_Physical_Real_Div, + Iir_Predefined_Physical_Physical_Div, + + Iir_Predefined_Physical_Minimum, + Iir_Predefined_Physical_Maximum, + Iir_Predefined_Physical_To_String, + + Iir_Predefined_Time_To_String_Unit, + + -- Predefined operators for access. + Iir_Predefined_Access_Equality, + Iir_Predefined_Access_Inequality, + + -- Predefined operators for record. + Iir_Predefined_Record_Equality, + Iir_Predefined_Record_Inequality, + + -- Predefined operators for array. + Iir_Predefined_Array_Equality, + Iir_Predefined_Array_Inequality, + Iir_Predefined_Array_Less, + Iir_Predefined_Array_Less_Equal, + Iir_Predefined_Array_Greater, + Iir_Predefined_Array_Greater_Equal, + + Iir_Predefined_Array_Array_Concat, + Iir_Predefined_Array_Element_Concat, + Iir_Predefined_Element_Array_Concat, + Iir_Predefined_Element_Element_Concat, + + Iir_Predefined_Array_Minimum, + Iir_Predefined_Array_Maximum, + Iir_Predefined_Vector_Minimum, + Iir_Predefined_Vector_Maximum, + + -- Predefined shift operators. + Iir_Predefined_Array_Sll, + Iir_Predefined_Array_Srl, + Iir_Predefined_Array_Sla, + Iir_Predefined_Array_Sra, + Iir_Predefined_Array_Rol, + Iir_Predefined_Array_Ror, + + -- Predefined operators for one dimensional array. + -- For bit and boolean type, the operations are the same. For a neutral + -- noun, we use TF (for True/False) instead of Bit, Boolean or Logic. + Iir_Predefined_TF_Array_And, + Iir_Predefined_TF_Array_Or, + Iir_Predefined_TF_Array_Nand, + Iir_Predefined_TF_Array_Nor, + Iir_Predefined_TF_Array_Xor, + Iir_Predefined_TF_Array_Xnor, + Iir_Predefined_TF_Array_Not, + + Iir_Predefined_TF_Reduction_And, + Iir_Predefined_TF_Reduction_Or, + Iir_Predefined_TF_Reduction_Nand, + Iir_Predefined_TF_Reduction_Nor, + Iir_Predefined_TF_Reduction_Xor, + Iir_Predefined_TF_Reduction_Xnor, + Iir_Predefined_TF_Reduction_Not, + + Iir_Predefined_TF_Array_Element_And, + Iir_Predefined_TF_Element_Array_And, + Iir_Predefined_TF_Array_Element_Or, + Iir_Predefined_TF_Element_Array_Or, + Iir_Predefined_TF_Array_Element_Nand, + Iir_Predefined_TF_Element_Array_Nand, + Iir_Predefined_TF_Array_Element_Nor, + Iir_Predefined_TF_Element_Array_Nor, + Iir_Predefined_TF_Array_Element_Xor, + Iir_Predefined_TF_Element_Array_Xor, + Iir_Predefined_TF_Array_Element_Xnor, + Iir_Predefined_TF_Element_Array_Xnor, + + Iir_Predefined_Bit_Array_Match_Equality, + Iir_Predefined_Bit_Array_Match_Inequality, + + -- Predefined attribute functions. + Iir_Predefined_Attribute_Image, + Iir_Predefined_Attribute_Value, + Iir_Predefined_Attribute_Pos, + Iir_Predefined_Attribute_Val, + Iir_Predefined_Attribute_Succ, + Iir_Predefined_Attribute_Pred, + Iir_Predefined_Attribute_Leftof, + Iir_Predefined_Attribute_Rightof, + Iir_Predefined_Attribute_Left, + Iir_Predefined_Attribute_Right, + Iir_Predefined_Attribute_Event, + Iir_Predefined_Attribute_Active, + Iir_Predefined_Attribute_Last_Event, + Iir_Predefined_Attribute_Last_Active, + Iir_Predefined_Attribute_Last_Value, + Iir_Predefined_Attribute_Driving, + Iir_Predefined_Attribute_Driving_Value, + + -- Access procedure + Iir_Predefined_Deallocate, + + -- file function / procedures. + Iir_Predefined_File_Open, + Iir_Predefined_File_Open_Status, + 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_Char_To_String, + Iir_Predefined_Bit_Vector_To_Ostring, + Iir_Predefined_Bit_Vector_To_Hstring, + + -- IEEE.Std_Logic_1164.Std_Ulogic + Iir_Predefined_Std_Ulogic_Match_Equality, + Iir_Predefined_Std_Ulogic_Match_Inequality, + Iir_Predefined_Std_Ulogic_Match_Less, + Iir_Predefined_Std_Ulogic_Match_Less_Equal, + Iir_Predefined_Std_Ulogic_Match_Greater, + Iir_Predefined_Std_Ulogic_Match_Greater_Equal, + + Iir_Predefined_Std_Ulogic_Array_Match_Equality, + Iir_Predefined_Std_Ulogic_Array_Match_Inequality, + + -- Predefined function. + Iir_Predefined_Now_Function + ); + + -- Return TRUE iff FUNC is a short-cut predefined function. + function Iir_Predefined_Shortcut_P (Func : Iir_Predefined_Functions) + return Boolean; + + subtype Iir_Predefined_Pure_Functions is Iir_Predefined_Functions range + Iir_Predefined_Boolean_And .. Iir_Predefined_Attribute_Driving_Value; + + subtype Iir_Predefined_Dyadic_TF_Array_Functions + is Iir_Predefined_Functions range + Iir_Predefined_TF_Array_And .. + --Iir_Predefined_TF_Array_Or + --Iir_Predefined_TF_Array_Nand + --Iir_Predefined_TF_Array_Nor + --Iir_Predefined_TF_Array_Xor + Iir_Predefined_TF_Array_Xnor; + + subtype Iir_Predefined_Shift_Functions is Iir_Predefined_Functions range + Iir_Predefined_Array_Sll .. + --Iir_Predefined_Array_Srl + --Iir_Predefined_Array_Sla + --Iir_Predefined_Array_Sra + --Iir_Predefined_Array_Rol + Iir_Predefined_Array_Ror; + + subtype Iir_Predefined_Concat_Functions is Iir_Predefined_Functions range + Iir_Predefined_Array_Array_Concat .. + --Iir_Predefined_Array_Element_Concat + --Iir_Predefined_Element_Array_Concat + Iir_Predefined_Element_Element_Concat; + + subtype Iir_Predefined_Std_Ulogic_Match_Ordering_Functions is + Iir_Predefined_Functions range + Iir_Predefined_Std_Ulogic_Match_Less .. + --Iir_Predefined_Std_Ulogic_Match_Less_Equal + --Iir_Predefined_Std_Ulogic_Match_Greater + Iir_Predefined_Std_Ulogic_Match_Greater_Equal; + + -- Staticness as defined by LRM93 §6.1 and §7.4 + type Iir_Staticness is (Unknown, None, Globally, Locally); + + -- Staticness as defined by LRM93 §6.1 and §7.4 + function Min (L,R: Iir_Staticness) return Iir_Staticness renames + Iir_Staticness'Min; + + -- Purity state of a procedure. + -- PURE means the procedure is pure. + -- IMPURE means the procedure is impure: it references a file object or + -- a signal or a variable declared outside a subprogram, or it calls an + -- impure subprogram. + -- MAYBE_IMPURE means the procedure references a signal or a variable + -- declared in a subprogram. The relative position of a parent has to + -- be considered. The list of callees must not be checked. + -- UNKNOWN is like MAYBE_IMPURE, but the subprogram has a list of callees + -- whose purity is not yet known. As a consequence, a direct or + -- indirect call to such a procedure cannot be proved to be allowed + -- in a pure function. + -- Note: UNKNOWN is the default state. At any impure call, the state is + -- set to IMPURE. Only at the end of body analysis and only if the + -- callee list is empty, the state can be set either to MAYBE_IMPURE or + -- PURE. + type Iir_Pure_State is (Unknown, Pure, Maybe_Impure, Impure); + + -- State of subprograms for validity of use in all-sensitized process. + -- INVALID_SIGNAL means that the subprogram is in a package and + -- reads a signal or that the subprogram calls (indirectly) such + -- a subprogram. In this case, the subprogram cannot be called from + -- an all-sensitized process. + -- READ_SIGNAL means that the subprogram reads a signal and is defined + -- in an entity or an architecture or that the subprogram calls + -- (indirectly) such a subprogram. In this case, the subprogram can + -- be called from an all-sensitized process and the reference will be + -- part of the sensitivity list. + -- NO_SIGNAL means that the subprogram doesn't read any signal and don't + -- call such a subprogram. The subprogram can be called from an + -- all-sensitized process but there is no need to track this call. + -- UNKNOWN means that the state is not yet defined. + 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); + + -- The kind of an inteface list. + type Interface_Kind_Type is (Generic_Interface_List, + Port_Interface_List, + Procedure_Parameter_Interface_List, + Function_Parameter_Interface_List); + subtype Parameter_Interface_List is Interface_Kind_Type range + Procedure_Parameter_Interface_List .. + Function_Parameter_Interface_List; + + --------------- + -- subranges -- + --------------- + -- These subtypes are used for ranges, for `case' statments or for the `in' + -- operator. + + -- In order to be correctly parsed by check_iir, the declaration must + -- follow these rules: + -- * the first line must be "subtype Iir_Kinds_NAME is Iir_Kind_range" + -- * the second line must be the lowest bound of the range, followed by ".. + -- * comments line + -- * the last line must be the highest bound of the range, followed by ";" + +-- subtype Iir_Kinds_List is Iir_Kind range +-- Iir_Kind_List .. +-- Iir_Kind_Callees_List; + + subtype Iir_Kinds_Library_Unit_Declaration is Iir_Kind range + Iir_Kind_Package_Declaration .. + --Iir_Kind_Package_Instantiation_Declaration + --Iir_Kind_Package_Body + --Iir_Kind_Configuration_Declaration + --Iir_Kind_Entity_Declaration + Iir_Kind_Architecture_Body; + + subtype Iir_Kinds_Package_Declaration is Iir_Kind range + Iir_Kind_Package_Declaration .. + Iir_Kind_Package_Instantiation_Declaration; + + -- Note: does not include iir_kind_enumeration_literal since it is + -- considered as a declaration. + subtype Iir_Kinds_Literal is Iir_Kind range + Iir_Kind_Integer_Literal .. + --Iir_Kind_Floating_Point_Literal + --Iir_Kind_Null_Literal + --Iir_Kind_String_Literal + --Iir_Kind_Physical_Int_Literal + --Iir_Kind_Physical_Fp_Literal + Iir_Kind_Bit_String_Literal; + + subtype Iir_Kinds_Array_Type_Definition is Iir_Kind range + Iir_Kind_Array_Type_Definition .. + Iir_Kind_Array_Subtype_Definition; + + subtype Iir_Kinds_Type_And_Subtype_Definition is Iir_Kind range + Iir_Kind_Access_Type_Definition .. + --Iir_Kind_Incomplete_Type_Definition + --Iir_Kind_File_Type_Definition + --Iir_Kind_Protected_Type_Declaration + --Iir_Kind_Record_Type_Definition + --Iir_Kind_Array_Type_Definition + --Iir_Kind_Array_Subtype_Definition + --Iir_Kind_Record_Subtype_Definition + --Iir_Kind_Access_Subtype_Definition + --Iir_Kind_Physical_Subtype_Definition + --Iir_Kind_Floating_Subtype_Definition + --Iir_Kind_Integer_Subtype_Definition + --Iir_Kind_Enumeration_Subtype_Definition + --Iir_Kind_Enumeration_Type_Definition + --Iir_Kind_Integer_Type_Definition + --Iir_Kind_Floating_Type_Definition + Iir_Kind_Physical_Type_Definition; + + subtype Iir_Kinds_Subtype_Definition is Iir_Kind range + Iir_Kind_Array_Subtype_Definition .. + --Iir_Kind_Record_Subtype_Definition + --Iir_Kind_Access_Subtype_Definition + --Iir_Kind_Physical_Subtype_Definition + --Iir_Kind_Floating_Subtype_Definition + --Iir_Kind_Integer_Subtype_Definition + Iir_Kind_Enumeration_Subtype_Definition; + + subtype Iir_Kinds_Scalar_Subtype_Definition is Iir_Kind range + Iir_Kind_Physical_Subtype_Definition .. + --Iir_Kind_Floating_Subtype_Definition + --Iir_Kind_Integer_Subtype_Definition + Iir_Kind_Enumeration_Subtype_Definition; + + subtype Iir_Kinds_Scalar_Type_Definition is Iir_Kind range + Iir_Kind_Physical_Subtype_Definition .. + --Iir_Kind_Floating_Subtype_Definition + --Iir_Kind_Integer_Subtype_Definition + --Iir_Kind_Enumeration_Subtype_Definition + --Iir_Kind_Enumeration_Type_Definition + --Iir_Kind_Integer_Type_Definition + --Iir_Kind_Floating_Type_Definition + Iir_Kind_Physical_Type_Definition; + + subtype Iir_Kinds_Range_Type_Definition is Iir_Kind range + Iir_Kind_Physical_Subtype_Definition .. + --Iir_Kind_Floating_Subtype_Definition + --Iir_Kind_Integer_Subtype_Definition + --Iir_Kind_Enumeration_Subtype_Definition + Iir_Kind_Enumeration_Type_Definition; + + subtype Iir_Kinds_Discrete_Type_Definition is Iir_Kind range + Iir_Kind_Integer_Subtype_Definition .. + --Iir_Kind_Enumeration_Subtype_Definition + --Iir_Kind_Enumeration_Type_Definition + Iir_Kind_Integer_Type_Definition; + +-- subtype Iir_Kinds_Discrete_Subtype_Definition is Iir_Kind range +-- Iir_Kind_Integer_Subtype_Definition .. +-- Iir_Kind_Enumeration_Subtype_Definition; + + subtype Iir_Kinds_Composite_Type_Definition is Iir_Kind range + Iir_Kind_Record_Type_Definition .. + --Iir_Kind_Array_Type_Definition + --Iir_Kind_Array_Subtype_Definition + Iir_Kind_Record_Subtype_Definition; + + subtype Iir_Kinds_Type_Declaration is Iir_Kind range + Iir_Kind_Type_Declaration .. + --Iir_Kind_Anonymous_Type_Declaration + Iir_Kind_Subtype_Declaration; + + subtype Iir_Kinds_Nonoverloadable_Declaration is Iir_Kind range + Iir_Kind_Type_Declaration .. + Iir_Kind_Element_Declaration; + + subtype Iir_Kinds_Monadic_Operator is Iir_Kind range + Iir_Kind_Identity_Operator .. + --Iir_Kind_Negation_Operator + --Iir_Kind_Absolute_Operator + --Iir_Kind_Not_Operator + --Iir_Kind_Condition_Operator + --Iir_Kind_Reduction_And_Operator + --Iir_Kind_Reduction_Or_Operator + --Iir_Kind_Reduction_Nand_Operator + --Iir_Kind_Reduction_Nor_Operator + --Iir_Kind_Reduction_Xor_Operator + Iir_Kind_Reduction_Xnor_Operator; + + subtype Iir_Kinds_Dyadic_Operator is Iir_Kind range + Iir_Kind_And_Operator .. + --Iir_Kind_Or_Operator + --Iir_Kind_Nand_Operator + --Iir_Kind_Nor_Operator + --Iir_Kind_Xor_Operator + --Iir_Kind_Xnor_Operator + --Iir_Kind_Equality_Operator + --Iir_Kind_Inequality_Operator + --Iir_Kind_Less_Than_Operator + --Iir_Kind_Less_Than_Or_Equal_Operator + --Iir_Kind_Greater_Than_Operator + --Iir_Kind_Greater_Than_Or_Equal_Operator + --Iir_Kind_Match_Equality_Operator + --Iir_Kind_Match_Inequality_Operator + --Iir_Kind_Match_Less_Than_Operator + --Iir_Kind_Match_Less_Than_Or_Equal_Operator + --Iir_Kind_Match_Greater_Than_Operator + --Iir_Kind_Match_Greater_Than_Or_Equal_Operator + --Iir_Kind_Sll_Operator + --Iir_Kind_Sla_Operator + --Iir_Kind_Srl_Operator + --Iir_Kind_Sra_Operator + --Iir_Kind_Rol_Operator + --Iir_Kind_Ror_Operator + --Iir_Kind_Addition_Operator + --Iir_Kind_Substraction_Operator + --Iir_Kind_Concatenation_Operator + --Iir_Kind_Multiplication_Operator + --Iir_Kind_Division_Operator + --Iir_Kind_Modulus_Operator + --Iir_Kind_Remainder_Operator + Iir_Kind_Exponentiation_Operator; + + subtype Iir_Kinds_Function_Declaration is Iir_Kind range + Iir_Kind_Function_Declaration .. + Iir_Kind_Implicit_Function_Declaration; + + subtype Iir_Kinds_Functions_And_Literals is Iir_Kind range + Iir_Kind_Enumeration_Literal .. + --Iir_Kind_Function_Declaration + Iir_Kind_Implicit_Function_Declaration; + + subtype Iir_Kinds_Procedure_Declaration is Iir_Kind range + Iir_Kind_Implicit_Procedure_Declaration .. + Iir_Kind_Procedure_Declaration; + + subtype Iir_Kinds_Subprogram_Declaration is Iir_Kind range + Iir_Kind_Function_Declaration .. + --Iir_Kind_Implicit_Function_Declaration + --Iir_Kind_Implicit_Procedure_Declaration + Iir_Kind_Procedure_Declaration; + + subtype Iir_Kinds_Implicit_Subprogram_Declaration is Iir_Kind range + Iir_Kind_Implicit_Function_Declaration .. + Iir_Kind_Implicit_Procedure_Declaration; + + subtype Iir_Kinds_Process_Statement is Iir_Kind range + Iir_Kind_Sensitized_Process_Statement .. + Iir_Kind_Process_Statement; + + subtype Iir_Kinds_Interface_Object_Declaration is Iir_Kind range + Iir_Kind_Interface_Constant_Declaration .. + --Iir_Kind_Interface_Variable_Declaration + --Iir_Kind_Interface_Signal_Declaration + Iir_Kind_Interface_File_Declaration; + + subtype Iir_Kinds_Object_Declaration is Iir_Kind range + Iir_Kind_Object_Alias_Declaration .. + --Iir_Kind_File_Declaration + --Iir_Kind_Guard_Signal_Declaration + --Iir_Kind_Signal_Declaration + --Iir_Kind_Variable_Declaration + --Iir_Kind_Constant_Declaration + --Iir_Kind_Iterator_Declaration + --Iir_Kind_Interface_Constant_Declaration + --Iir_Kind_Interface_Variable_Declaration + --Iir_Kind_Interface_Signal_Declaration + Iir_Kind_Interface_File_Declaration; + + subtype Iir_Kinds_Branch_Quantity_Declaration is Iir_Kind range + Iir_Kind_Across_Quantity_Declaration .. + Iir_Kind_Through_Quantity_Declaration; + + subtype Iir_Kinds_Quantity_Declaration is Iir_Kind range + Iir_Kind_Free_Quantity_Declaration .. + --Iir_Kind_Across_Quantity_Declaration + Iir_Kind_Through_Quantity_Declaration; + + subtype Iir_Kinds_Non_Alias_Object_Declaration is Iir_Kind range + Iir_Kind_File_Declaration .. + --Iir_Kind_Guard_Signal_Declaration + --Iir_Kind_Signal_Declaration + --Iir_Kind_Variable_Declaration + --Iir_Kind_Constant_Declaration + --Iir_Kind_Iterator_Declaration + --Iir_Kind_Interface_Constant_Declaration + --Iir_Kind_Interface_Variable_Declaration + --Iir_Kind_Interface_Signal_Declaration + Iir_Kind_Interface_File_Declaration; + + subtype Iir_Kinds_Association_Element is Iir_Kind range + Iir_Kind_Association_Element_By_Expression .. + --Iir_Kind_Association_Element_By_Individual + Iir_Kind_Association_Element_Open; + + subtype Iir_Kinds_Choice is Iir_Kind range + Iir_Kind_Choice_By_Others .. + --Iir_Kind_Choice_By_Expression + --Iir_Kind_Choice_By_Range + --Iir_Kind_Choice_By_None + Iir_Kind_Choice_By_Name; + + subtype Iir_Kinds_Denoting_Name is Iir_Kind range + Iir_Kind_Character_Literal .. + --Iir_Kind_Simple_Name + --Iir_Kind_Selected_Name + Iir_Kind_Operator_Symbol; + + subtype Iir_Kinds_Name is Iir_Kind range + Iir_Kind_Character_Literal .. + --Iir_Kind_Simple_Name + --Iir_Kind_Selected_Name + --Iir_Kind_Operator_Symbol + --Iir_Kind_Selected_By_All_Name + Iir_Kind_Parenthesis_Name; + + subtype Iir_Kinds_Dereference is Iir_Kind range + Iir_Kind_Dereference .. + Iir_Kind_Implicit_Dereference; + + -- Any attribute that is an expression. + subtype Iir_Kinds_Expression_Attribute is Iir_Kind range + Iir_Kind_Left_Type_Attribute .. + --Iir_Kind_Right_Type_Attribute + --Iir_Kind_High_Type_Attribute + --Iir_Kind_Low_Type_Attribute + --Iir_Kind_Ascending_Type_Attribute + --Iir_Kind_Image_Attribute + --Iir_Kind_Value_Attribute + --Iir_Kind_Pos_Attribute + --Iir_Kind_Val_Attribute + --Iir_Kind_Succ_Attribute + --Iir_Kind_Pred_Attribute + --Iir_Kind_Leftof_Attribute + --Iir_Kind_Rightof_Attribute + --Iir_Kind_Delayed_Attribute + --Iir_Kind_Stable_Attribute + --Iir_Kind_Quiet_Attribute + --Iir_Kind_Transaction_Attribute + --Iir_Kind_Event_Attribute + --Iir_Kind_Active_Attribute + --Iir_Kind_Last_Event_Attribute + --Iir_Kind_Last_Active_Attribute + --Iir_Kind_Last_Value_Attribute + --Iir_Kind_Driving_Attribute + --Iir_Kind_Driving_Value_Attribute + --Iir_Kind_Behavior_Attribute + --Iir_Kind_Structure_Attribute + --Iir_Kind_Simple_Name_Attribute + --Iir_Kind_Instance_Name_Attribute + --Iir_Kind_Path_Name_Attribute + --Iir_Kind_Left_Array_Attribute + --Iir_Kind_Right_Array_Attribute + --Iir_Kind_High_Array_Attribute + --Iir_Kind_Low_Array_Attribute + --Iir_Kind_Length_Array_Attribute + Iir_Kind_Ascending_Array_Attribute; + + -- All the attributes. + subtype Iir_Kinds_Attribute is Iir_Kind range + Iir_Kind_Base_Attribute .. + Iir_Kind_Reverse_Range_Array_Attribute; + + subtype Iir_Kinds_Type_Attribute is Iir_Kind range + Iir_Kind_Left_Type_Attribute .. + --Iir_Kind_Right_Type_Attribute + --Iir_Kind_High_Type_Attribute + --Iir_Kind_Low_Type_Attribute + Iir_Kind_Ascending_Type_Attribute; + + subtype Iir_Kinds_Scalar_Type_Attribute is Iir_Kind range + Iir_Kind_Pos_Attribute .. + --Iir_Kind_Val_Attribute + --Iir_Kind_Succ_Attribute + --Iir_Kind_Pred_Attribute + --Iir_Kind_Leftof_Attribute + Iir_Kind_Rightof_Attribute; + + subtype Iir_Kinds_Array_Attribute is Iir_Kind range + Iir_Kind_Left_Array_Attribute .. + --Iir_Kind_Right_Array_Attribute + --Iir_Kind_High_Array_Attribute + --Iir_Kind_Low_Array_Attribute + --Iir_Kind_Length_Array_Attribute + --Iir_Kind_Ascending_Array_Attribute + --Iir_Kind_Range_Array_Attribute + Iir_Kind_Reverse_Range_Array_Attribute; + + subtype Iir_Kinds_Signal_Attribute is Iir_Kind range + Iir_Kind_Delayed_Attribute .. + --Iir_Kind_Stable_Attribute + --Iir_Kind_Quiet_Attribute + Iir_Kind_Transaction_Attribute; + + subtype Iir_Kinds_Signal_Value_Attribute is Iir_Kind range + Iir_Kind_Event_Attribute .. + --Iir_Kind_Active_Attribute + --Iir_Kind_Last_Event_Attribute + --Iir_Kind_Last_Active_Attribute + --Iir_Kind_Last_Value_Attribute + --Iir_Kind_Driving_Attribute + Iir_Kind_Driving_Value_Attribute; + + subtype Iir_Kinds_Name_Attribute is Iir_Kind range + Iir_Kind_Simple_Name_Attribute .. + --Iir_Kind_Instance_Name_Attribute + Iir_Kind_Path_Name_Attribute; + + subtype Iir_Kinds_Concurrent_Statement is Iir_Kind range + Iir_Kind_Sensitized_Process_Statement .. + --Iir_Kind_Process_Statement + --Iir_Kind_Concurrent_Conditional_Signal_Assignment + --Iir_Kind_Concurrent_Selected_Signal_Assignment + --Iir_Kind_Concurrent_Assertion_Statement + --Iir_Kind_Psl_Default_Clock + --Iir_Kind_Psl_Assert_Statement + --Iir_Kind_Psl_Cover_Statement + --Iir_Kind_Concurrent_Procedure_Call_Statement + --Iir_Kind_Block_Statement + --Iir_Kind_Generate_Statement + Iir_Kind_Component_Instantiation_Statement; + + subtype Iir_Kinds_Concurrent_Signal_Assignment is Iir_Kind range + Iir_Kind_Concurrent_Conditional_Signal_Assignment .. + Iir_Kind_Concurrent_Selected_Signal_Assignment; + + subtype Iir_Kinds_Sequential_Statement is Iir_Kind range + Iir_Kind_Signal_Assignment_Statement .. + --Iir_Kind_Null_Statement + --Iir_Kind_Assertion_Statement + --Iir_Kind_Report_Statement + --Iir_Kind_Wait_Statement + --Iir_Kind_Variable_Assignment_Statement + --Iir_Kind_Return_Statement + --Iir_Kind_For_Loop_Statement + --Iir_Kind_While_Loop_Statement + --Iir_Kind_Next_Statement + --Iir_Kind_Exit_Statement + --Iir_Kind_Case_Statement + --Iir_Kind_Procedure_Call_Statement + Iir_Kind_If_Statement; + + subtype Iir_Kinds_Allocator is Iir_Kind range + Iir_Kind_Allocator_By_Expression .. + Iir_Kind_Allocator_By_Subtype; + + subtype Iir_Kinds_Clause is Iir_Kind range + Iir_Kind_Library_Clause .. + Iir_Kind_Use_Clause; + + subtype Iir_Kinds_Specification is Iir_Kind range + Iir_Kind_Attribute_Specification .. + --Iir_Kind_Disconnection_Specification + Iir_Kind_Configuration_Specification; + + subtype Iir_Kinds_Declaration is Iir_Kind range + Iir_Kind_Type_Declaration .. + --Iir_Kind_Anonymous_Type_Declaration + --Iir_Kind_Subtype_Declaration + --Iir_Kind_Nature_Declaration + --Iir_Kind_Subnature_Declaration + --Iir_Kind_Package_Declaration + --Iir_Kind_Package_Instantiation_Declaration + --Iir_Kind_Package_Body + --Iir_Kind_Configuration_Declaration + --Iir_Kind_Entity_Declaration + --Iir_Kind_Architecture_Body + --Iir_Kind_Package_Header + --Iir_Kind_Unit_Declaration + --Iir_Kind_Library_Declaration + --Iir_Kind_Component_Declaration + --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_Psl_Declaration + --Iir_Kind_Terminal_Declaration + --Iir_Kind_Free_Quantity_Declaration + --Iir_Kind_Across_Quantity_Declaration + --Iir_Kind_Through_Quantity_Declaration + --Iir_Kind_Enumeration_Literal + --Iir_Kind_Function_Declaration + --Iir_Kind_Implicit_Function_Declaration + --Iir_Kind_Implicit_Procedure_Declaration + --Iir_Kind_Procedure_Declaration + --Iir_Kind_Function_Body + --Iir_Kind_Procedure_Body + --Iir_Kind_Object_Alias_Declaration + --Iir_Kind_File_Declaration + --Iir_Kind_Guard_Signal_Declaration + --Iir_Kind_Signal_Declaration + --Iir_Kind_Variable_Declaration + --Iir_Kind_Constant_Declaration + --Iir_Kind_Iterator_Declaration + --Iir_Kind_Interface_Constant_Declaration + --Iir_Kind_Interface_Variable_Declaration + --Iir_Kind_Interface_Signal_Declaration + Iir_Kind_Interface_File_Declaration; + + ------------------------------------- + -- Types and subtypes declarations -- + ------------------------------------- + + -- Level 1 base class. + subtype Iir is Nodes.Node_Type; + subtype Iir_List is Lists.List_Type; + Null_Iir_List : constant Iir_List := Lists.Null_List; + Iir_List_All : constant Iir_List := Lists.List_All; + Iir_List_Others : constant Iir_List := Lists.List_Others; + subtype Iir_Lists_All_Others is Iir_List + range Iir_List_Others .. Iir_List_All; + + Null_Iir : constant Iir := Nodes.Null_Node; + + function Is_Null (Node : Iir) return Boolean; + pragma Inline (Is_Null); + + function Is_Null_List (Node : Iir_List) return Boolean; + pragma Inline (Is_Null_List); + + function "=" (L, R : Iir) return Boolean renames Nodes."="; + + function Get_Last_Node return Iir renames Nodes.Get_Last_Node; + + function Create_Iir_List return Iir_List + renames Lists.Create_List; + function Get_Nth_Element (L : Iir_List; N : Natural) return Iir + renames Lists.Get_Nth_Element; + procedure Replace_Nth_Element (L : Iir_List; N : Natural; El : Iir) + renames Lists.Replace_Nth_Element; + procedure Append_Element (L : Iir_List; E : Iir) + renames Lists.Append_Element; + procedure Add_Element (L : Iir_List; E : Iir) + renames Lists.Add_Element; + procedure Destroy_Iir_List (L : in out Iir_List) + renames Lists.Destroy_List; + function Get_Nbr_Elements (L : Iir_List) return Natural + renames Lists.Get_Nbr_Elements; + procedure Set_Nbr_Elements (L : Iir_List; Nbr : Natural) + renames Lists.Set_Nbr_Elements; + function Get_First_Element (L : Iir_List) return Iir + renames Lists.Get_First_Element; + function Get_Last_Element (L : Iir_List) return Iir + renames Lists.Get_Last_Element; + function "=" (L, R : Iir_List) return Boolean renames Lists."="; + + -- This is used only for lists. + type Iir_Array is array (Natural range <>) of Iir; + type Iir_Array_Acc is access Iir_Array; + procedure Free is new Ada.Unchecked_Deallocation + (Object => Iir_Array, Name => Iir_Array_Acc); + + -- Date State. + -- This indicates the origin of the data information. + -- This also indicates the state of the unit (loaded or not). + type Date_State_Type is + ( + -- The unit is not yet in the library. + Date_Extern, + + -- The unit is not loaded (still on the disk). + -- All the informations come from the library file. + Date_Disk, + + -- The unit has been parsed, but not analyzed. + -- Only the date information come from the library. + Date_Parse, + + -- The unit has been analyzed. + Date_Analyze + ); + + -- A date is used for analysis order. All design units from a library + -- are ordered according to the date. + type Date_Type is new Nat32; + -- The unit is obseleted (ie replaced) by a more recently analyzed design + -- unit.another design unit. + -- If another design unit depends (directly or not) on an obseleted design + -- unit, it is also obselete, and cannot be defined. + Date_Obsolete : constant Date_Type := 0; + -- The unit was not analyzed. + Date_Not_Analyzed : constant Date_Type := 1; + -- The unit has been analyzed but it has bad dependences. + Date_Bad_Analyze : constant Date_Type := 2; + -- The unit has been parsed but not analyzed. + Date_Parsed : constant Date_Type := 4; + -- The unit is being analyzed. + Date_Analyzing : constant Date_Type := 5; + -- This unit has just been analyzed and should be marked at the last + -- analyzed unit. + Date_Analyzed : constant Date_Type := 6; + -- Used only for default configuration. + -- Such units are always up-to-date. + Date_Uptodate : constant Date_Type := 7; + subtype Date_Valid is Date_Type range 10 .. Date_Type'Last; + + -- Predefined depth values. + -- Depth of a subprogram not declared in another subprogram. + Iir_Depth_Top : constant Iir_Int32 := 0; + -- Purity depth of a pure subprogram. + Iir_Depth_Pure : constant Iir_Int32 := Iir_Int32'Last; + -- Purity depth of an impure subprogram. + Iir_Depth_Impure : constant Iir_Int32 := -1; + + type Base_Type is (Base_2, Base_8, Base_16); + + -- design file + subtype Iir_Design_File is Iir; + + subtype Iir_Design_Unit is Iir; + + subtype Iir_Library_Clause is Iir; + + -- Literals. + --subtype Iir_Text_Literal is Iir; + + subtype Iir_Character_Literal is Iir; + + subtype Iir_Integer_Literal is Iir; + + subtype Iir_Floating_Point_Literal is Iir; + + subtype Iir_String_Literal is Iir; + + subtype Iir_Bit_String_Literal is Iir; + + subtype Iir_Null_Literal is Iir; + + subtype Iir_Physical_Int_Literal is Iir; + + subtype Iir_Physical_Fp_Literal is Iir; + + subtype Iir_Enumeration_Literal is Iir; + + subtype Iir_Simple_Aggregate is Iir; + + subtype Iir_Enumeration_Type_Definition is Iir; + + subtype Iir_Enumeration_Subtype_Definition is Iir; + + subtype Iir_Range_Expression is Iir; + + subtype Iir_Integer_Subtype_Definition is Iir; + + subtype Iir_Integer_Type_Definition is Iir; + + subtype Iir_Floating_Subtype_Definition is Iir; + + subtype Iir_Floating_Type_Definition is Iir; + + subtype Iir_Array_Type_Definition is Iir; + + subtype Iir_Record_Type_Definition is Iir; + + subtype Iir_Protected_Type_Declaration is Iir; + + subtype Iir_Protected_Type_Body is Iir; + + subtype Iir_Subtype_Definition is Iir; + + subtype Iir_Array_Subtype_Definition is Iir; + + subtype Iir_Physical_Type_Definition is Iir; + + subtype Iir_Physical_Subtype_Definition is Iir; + + subtype Iir_Access_Type_Definition is Iir; + + subtype Iir_Access_Subtype_Definition is Iir; + + subtype Iir_File_Type_Definition is Iir; + + subtype Iir_Waveform_Element is Iir; + + subtype Iir_Conditional_Waveform is Iir; + + subtype Iir_Association_Element_By_Expression is Iir; + + subtype Iir_Association_Element_By_Individual is Iir; + + subtype Iir_Association_Element_Open is Iir; + + subtype Iir_Signature is Iir; + + subtype Iir_Unit_Declaration is Iir; + + subtype Iir_Entity_Aspect_Entity is Iir; + + subtype Iir_Entity_Aspect_Configuration is Iir; + + subtype Iir_Entity_Aspect_Open is Iir; + + subtype Iir_Block_Configuration is Iir; + + subtype Iir_Block_Header is Iir; + + subtype Iir_Component_Configuration is Iir; + + subtype Iir_Binding_Indication is Iir; + + subtype Iir_Entity_Class is Iir; + + subtype Iir_Attribute_Specification is Iir; + + subtype Iir_Attribute_Value is Iir; + + subtype Iir_Selected_Element is Iir; + + subtype Iir_Implicit_Dereference is Iir; + + subtype Iir_Aggregate_Info is Iir; + + subtype Iir_Procedure_Call is Iir; + + subtype Iir_Disconnection_Specification is Iir; + + -- Lists. + + subtype Iir_Index_List is Iir_List; + + subtype Iir_Design_Unit_List is Iir_List; + + subtype Iir_Enumeration_Literal_List is Iir_List; + + subtype Iir_Designator_List is Iir_List; + + subtype Iir_Attribute_Value_Chain is Iir_List; + + subtype Iir_Overload_List is Iir; + + subtype Iir_Group_Constituent_List is Iir_List; + + subtype Iir_Callees_List is Iir_List; + + -- Declaration and children. + subtype Iir_Entity_Declaration is Iir; + + subtype Iir_Architecture_Body is Iir; + + subtype Iir_Interface_Signal_Declaration is Iir; + + subtype Iir_Configuration_Declaration is Iir; + + subtype Iir_Type_Declaration is Iir; + + subtype Iir_Anonymous_Type_Declaration is Iir; + + subtype Iir_Subtype_Declaration is Iir; + + subtype Iir_Package_Declaration is Iir; + subtype Iir_Package_Body is Iir; + + subtype Iir_Library_Declaration is Iir; + + subtype Iir_Function_Declaration is Iir; + + subtype Iir_Function_Body is Iir; + + subtype Iir_Procedure_Declaration is Iir; + + subtype Iir_Procedure_Body is Iir; + + subtype Iir_Implicit_Function_Declaration is Iir; + + subtype Iir_Implicit_Procedure_Declaration is Iir; + + subtype Iir_Use_Clause is Iir; + + subtype Iir_Constant_Declaration is Iir; + + subtype Iir_Iterator_Declaration is Iir; + + subtype Iir_Interface_Constant_Declaration is Iir; + + subtype Iir_Interface_Variable_Declaration is Iir; + + subtype Iir_Interface_File_Declaration is Iir; + + subtype Iir_Guard_Signal_Declaration is Iir; + + subtype Iir_Signal_Declaration is Iir; + + subtype Iir_Variable_Declaration is Iir; + + subtype Iir_Component_Declaration is Iir; + + subtype Iir_Element_Declaration is Iir; + + subtype Iir_Object_Alias_Declaration is Iir; + + subtype Iir_Non_Object_Alias_Declaration is Iir; + + subtype Iir_Interface_Declaration is Iir; + + subtype Iir_Configuration_Specification is Iir; + + subtype Iir_File_Declaration is Iir; + + subtype Iir_Attribute_Declaration is Iir; + + subtype Iir_Group_Template_Declaration is Iir; + + subtype Iir_Group_Declaration is Iir; + + -- concurrent_statement and children. + subtype Iir_Concurrent_Statement is Iir; + + subtype Iir_Concurrent_Conditional_Signal_Assignment is Iir; + + subtype Iir_Sensitized_Process_Statement is Iir; + + subtype Iir_Process_Statement is Iir; + + subtype Iir_Component_Instantiation_Statement is Iir; + + subtype Iir_Block_Statement is Iir; + + subtype Iir_Generate_Statement is Iir; + + -- sequential statements. + subtype Iir_If_Statement is Iir; + + subtype Iir_Elsif is Iir; + + subtype Iir_For_Loop_Statement is Iir; + + subtype Iir_While_Loop_Statement is Iir; + + subtype Iir_Exit_Statement is Iir; + subtype Iir_Next_Statement is Iir; + + subtype Iir_Variable_Assignment_Statement is Iir; + + subtype Iir_Signal_Assignment_Statement is Iir; + + subtype Iir_Assertion_Statement is Iir; + + subtype Iir_Report_Statement is Iir; + + subtype Iir_Wait_Statement is Iir; + + subtype Iir_Return_Statement is Iir; + + subtype Iir_Case_Statement is Iir; + + subtype Iir_Procedure_Call_Statement is Iir; + + -- expression and children. + subtype Iir_Expression is Iir; + + subtype Iir_Function_Call is Iir; + + subtype Iir_Aggregate is Iir; + + subtype Iir_Qualified_Expression is Iir; + + subtype Iir_Type_Conversion is Iir; + + subtype Iir_Allocator_By_Expression is Iir; + + subtype Iir_Allocator_By_Subtype is Iir; + + -- names. + subtype Iir_Simple_Name is Iir; + + subtype Iir_Slice_Name is Iir; + + subtype Iir_Selected_Name is Iir; + + subtype Iir_Selected_By_All_Name is Iir; + + subtype Iir_Indexed_Name is Iir; + + subtype Iir_Parenthesis_Name is Iir; + + -- attributes. + subtype Iir_Attribute_Name is Iir; + + -- General methods. + + -- Get the kind of the iir. + function Get_Kind (An_Iir: Iir) return Iir_Kind; + pragma Inline (Get_Kind); + + -- Create a new IIR of kind NEW_KIND, and copy fields from SRC to this + -- iir. Src fields are cleaned. + --function Clone_Iir (Src: Iir; New_Kind : Iir_Kind) return Iir; + + procedure Set_Location (Target: Iir; Location: Location_Type) + renames Nodes.Set_Location; + function Get_Location (Target: Iir) return Location_Type + renames Nodes.Get_Location; + + procedure Location_Copy (Target: Iir; Src: Iir); + + function Create_Iir (Kind: Iir_Kind) return Iir; + function Create_Iir_Error return Iir; + procedure Free_Iir (Target: Iir) renames Nodes.Free_Node; + + -- Disp statistics about node usage. + procedure Disp_Stats; + + -- Design units contained in a design file. + -- Field: Field5 Chain + function Get_First_Design_Unit (Design : Iir) return Iir; + procedure Set_First_Design_Unit (Design : Iir; Chain : Iir); + + -- Field: Field6 Ref + function Get_Last_Design_Unit (Design : Iir) return Iir; + procedure Set_Last_Design_Unit (Design : Iir; Chain : Iir); + + -- Library declaration of a library clause. + -- Field: Field1 + function Get_Library_Declaration (Design : Iir) return Iir; + procedure Set_Library_Declaration (Design : Iir; Library : Iir); + + -- File time stamp is the system time of the file last modification. + -- Field: Field4 (uc) + function Get_File_Time_Stamp (Design : Iir) return Time_Stamp_Id; + procedure Set_File_Time_Stamp (Design : Iir; Stamp : Time_Stamp_Id); + + -- Time stamp of the last analysis system time. + -- Field: Field3 (uc) + function Get_Analysis_Time_Stamp (Design : Iir) return Time_Stamp_Id; + procedure Set_Analysis_Time_Stamp (Design : Iir; Stamp : Time_Stamp_Id); + + -- The library which FILE belongs to. + -- Field: Field0 Ref + function Get_Library (File : Iir_Design_File) return Iir; + procedure Set_Library (File : Iir_Design_File; Lib : Iir); + + -- List of files which this design file depends on. + -- Field: Field1 (uc) + function Get_File_Dependence_List (File : Iir_Design_File) return Iir_List; + procedure Set_File_Dependence_List (File : Iir_Design_File; Lst : Iir_List); + + -- Identifier for the design file file name. + -- Field: Field12 (pos) + function Get_Design_File_Filename (File : Iir_Design_File) return Name_Id; + procedure Set_Design_File_Filename (File : Iir_Design_File; Name : Name_Id); + + -- Directory of a design file. + -- Field: Field11 (pos) + function Get_Design_File_Directory (File : Iir_Design_File) return Name_Id; + procedure Set_Design_File_Directory (File : Iir_Design_File; Dir : Name_Id); + + -- The parent of a design unit is a design file. + -- Field: Field0 Ref + function Get_Design_File (Unit : Iir_Design_Unit) return Iir; + procedure Set_Design_File (Unit : Iir_Design_Unit; File : Iir); + + -- Design files of a library. + -- Field: Field1 Chain + function Get_Design_File_Chain (Library : Iir) return Iir; + procedure Set_Design_File_Chain (Library : Iir; Chain : Iir); + + -- System directory where the library is stored. + -- Field: Field11 (pos) + function Get_Library_Directory (Library : Iir) return Name_Id; + procedure Set_Library_Directory (Library : Iir; Dir : Name_Id); + + -- Symbolic date, used to order design units in a library. + -- Field: Field10 (pos) + function Get_Date (Target : Iir) return Date_Type; + procedure Set_Date (Target : Iir; Date : Date_Type); + + -- Chain of context clauses. + -- Field: Field1 Chain + function Get_Context_Items (Design_Unit : Iir) return Iir; + procedure Set_Context_Items (Design_Unit : Iir; Items_Chain : Iir); + + -- List of design units on which the design unit depends. There is an + -- exception: the architecture of an entity aspect (of a component + -- instantiation) may not have been analyzed. The Entity_Aspect_Entity + -- is added to this list (instead of the non-existing design unit). + -- Field: Field8 Of_Ref (uc) + function Get_Dependence_List (Unit : Iir) return Iir_List; + procedure Set_Dependence_List (Unit : Iir; List : Iir_List); + + -- List of functions or sensitized processes whose analysis checks are not + -- complete. + -- These elements have direct or indirect calls to procedure whose body is + -- not yet analyzed. Therefore, purity or wait checks are not complete. + -- Field: Field9 (uc) + function Get_Analysis_Checks_List (Unit : Iir) return Iir_List; + procedure Set_Analysis_Checks_List (Unit : Iir; List : Iir_List); + + -- Wether the unit is on disk, parsed or analyzed. + -- Field: State1 (pos) + function Get_Date_State (Unit : Iir_Design_Unit) return Date_State_Type; + procedure Set_Date_State (Unit : Iir_Design_Unit; State : Date_State_Type); + + -- If TRUE, the target of the signal assignment is guarded. + -- If FALSE, the target is not guarded. + -- This is determined during sem by examining the declaration(s) of the + -- target (there may be severals declarations in the case of a aggregate + -- target). + -- If UNKNOWN, this is not determined at compile time but at run-time. + -- This is the case for formal signal interfaces of subprograms. + -- Field: State3 (pos) + function Get_Guarded_Target_State (Stmt : Iir) return Tri_State_Type; + procedure Set_Guarded_Target_State (Stmt : Iir; State : Tri_State_Type); + + -- Library unit of a design unit. + -- Field: Field5 + function Get_Library_Unit (Design_Unit : Iir_Design_Unit) return Iir; + procedure Set_Library_Unit (Design_Unit : Iir_Design_Unit; Lib_Unit : Iir); + pragma Inline (Get_Library_Unit); + + -- Every design unit is put in an hash table to find quickly found by its + -- name. This field is a single chain for collisions. + -- Field: Field7 Ref + function Get_Hash_Chain (Design_Unit : Iir_Design_Unit) return Iir; + procedure Set_Hash_Chain (Design_Unit : Iir_Design_Unit; Chain : Iir); + + -- Set the line and the offset in the line, only for the library manager. + -- This is valid until the file is really loaded in memory. On loading, + -- location will contain all this informations. + -- Field: Field4 (uc) + function Get_Design_Unit_Source_Pos (Design_Unit : Iir) return Source_Ptr; + procedure Set_Design_Unit_Source_Pos (Design_Unit : Iir; Pos : Source_Ptr); + + -- Field: Field11 (uc) + function Get_Design_Unit_Source_Line (Design_Unit : Iir) return Int32; + procedure Set_Design_Unit_Source_Line (Design_Unit : Iir; Line : Int32); + + -- Field: Field12 (uc) + function Get_Design_Unit_Source_Col (Design_Unit : Iir) return Int32; + procedure Set_Design_Unit_Source_Col (Design_Unit : Iir; Line : Int32); + + -- literals. + + -- Value of an integer/physical literal. + -- Field: Int64 + function Get_Value (Lit : Iir) return Iir_Int64; + procedure Set_Value (Lit : Iir; Val : Iir_Int64); + + -- Position (same as lit_type'pos) of an enumeration literal. + -- Field: Field10 (pos) + function Get_Enum_Pos (Lit : Iir) return Iir_Int32; + procedure Set_Enum_Pos (Lit : Iir; Val : Iir_Int32); + + -- Field: Field6 + function Get_Physical_Literal (Unit : Iir) return Iir; + procedure Set_Physical_Literal (Unit : Iir; Lit : Iir); + + -- Value of a physical unit declaration. + -- Field: Field7 + function Get_Physical_Unit_Value (Unit : Iir) return Iir; + procedure Set_Physical_Unit_Value (Unit : Iir; Lit : Iir); + + -- Value of a floating point literal. + -- Field: Fp64 + function Get_Fp_Value (Lit : Iir) return Iir_Fp64; + procedure Set_Fp_Value (Lit : Iir; Val : Iir_Fp64); + + -- Declaration of the literal. + -- This is used to retrieve the genuine enumeration literal for literals + -- created from static expression. + -- Field: Field6 Ref + function Get_Enumeration_Decl (Target : Iir) return Iir; + procedure Set_Enumeration_Decl (Target : Iir; Lit : Iir); + + -- List of elements of a simple aggregate. + -- Field: Field3 (uc) + function Get_Simple_Aggregate_List (Target : Iir) return Iir_List; + procedure Set_Simple_Aggregate_List (Target : Iir; List : Iir_List); + + -- The logarithm of the base (1, 3 or 4) of a bit string. + -- Field: Field8 (pos) + function Get_Bit_String_Base (Lit : Iir) return Base_Type; + procedure Set_Bit_String_Base (Lit : Iir; Base : Base_Type); + + -- The enumeration literal which defines the '0' and '1' value. + -- Field: Field6 + function Get_Bit_String_0 (Lit : Iir) return Iir; + procedure Set_Bit_String_0 (Lit : Iir; El : Iir); + + -- Field: Field7 + function Get_Bit_String_1 (Lit : Iir) return Iir; + procedure Set_Bit_String_1 (Lit : Iir; El : Iir); + + -- The origin of a literal can be null_iir for a literal generated by the + -- parser, or a node which was statically evaluated to this literal. + -- Such nodes are created by eval_expr. + -- Field: Field2 + function Get_Literal_Origin (Lit : Iir) return Iir; + procedure Set_Literal_Origin (Lit : Iir; Orig : Iir); + + -- Field: Field4 + function Get_Range_Origin (Lit : Iir) return Iir; + procedure Set_Range_Origin (Lit : Iir; Orig : Iir); + + -- Same as Type, but not marked as Ref. This is when a literal has a + -- subtype (such as string or bit_string) created specially for the + -- literal. + -- Field: Field5 + function Get_Literal_Subtype (Lit : Iir) return Iir; + procedure Set_Literal_Subtype (Lit : Iir; Atype : Iir); + + -- Field: Field3 (uc) + function Get_Entity_Class (Target : Iir) return Token_Type; + procedure Set_Entity_Class (Target : Iir; Kind : Token_Type); + + -- Field: Field1 (uc) + function Get_Entity_Name_List (Target : Iir) return Iir_List; + procedure Set_Entity_Name_List (Target : Iir; Names : Iir_List); + + -- Field: Field6 + function Get_Attribute_Designator (Target : Iir) return Iir; + procedure Set_Attribute_Designator (Target : Iir; Designator : Iir); + + -- Chain of attribute specifications. This is used only during sem, to + -- check that no named entity of a given class appear after an attr. spec. + -- with the entity name list OTHERS or ALL. + -- Field: Field7 + function Get_Attribute_Specification_Chain (Target : Iir) return Iir; + procedure Set_Attribute_Specification_Chain (Target : Iir; Chain : Iir); + + -- Field: Field4 Ref + function Get_Attribute_Specification (Val : Iir) return Iir; + procedure Set_Attribute_Specification (Val : Iir; Attr : Iir); + + -- Field: Field3 (uc) + function Get_Signal_List (Target : Iir) return Iir_List; + procedure Set_Signal_List (Target : Iir; List : Iir_List); + + -- Field: Field3 Ref + function Get_Designated_Entity (Val : Iir_Attribute_Value) return Iir; + procedure Set_Designated_Entity (Val : Iir_Attribute_Value; Entity : Iir); + + -- Field: Field1 + function Get_Formal (Target : Iir) return Iir; + procedure Set_Formal (Target : Iir; Formal : Iir); + + -- Field: Field3 + function Get_Actual (Target : Iir) return Iir; + procedure Set_Actual (Target : Iir; Actual : Iir); + + -- Field: Field4 + function Get_In_Conversion (Target : Iir) return Iir; + procedure Set_In_Conversion (Target : Iir; Conv : Iir); + + -- Field: Field5 + function Get_Out_Conversion (Target : Iir) return Iir; + procedure Set_Out_Conversion (Target : Iir; Conv : Iir); + + -- This flag is set when the formal is associated in whole (ie, not + -- individually). + -- Field: Flag1 + function Get_Whole_Association_Flag (Target : Iir) return Boolean; + procedure Set_Whole_Association_Flag (Target : Iir; Flag : Boolean); + + -- This flag is set when the formal signal can be the actual signal. In + -- this case, the formal signal is not created, and the actual is shared. + -- This is the signal collapsing optimisation. + -- Field: Flag2 + function Get_Collapse_Signal_Flag (Target : Iir) return Boolean; + procedure Set_Collapse_Signal_Flag (Target : Iir; Flag : Boolean); + + -- Set when the node was artificially created, eg by canon. + -- Currently used only by association_element_open. + -- Field: Flag3 + function Get_Artificial_Flag (Target : Iir) return Boolean; + procedure Set_Artificial_Flag (Target : Iir; Flag : Boolean); + + -- This flag is set for a very short time during the check that no in + -- port is unconnected. + -- Field: Flag3 + function Get_Open_Flag (Target : Iir) return Boolean; + procedure Set_Open_Flag (Target : Iir; Flag : Boolean); + + -- This flag is set by trans_analyze if there is a projected waveform + -- assignment in the process. + -- Field: Flag5 + function Get_After_Drivers_Flag (Target : Iir) return Boolean; + procedure Set_After_Drivers_Flag (Target : Iir; Flag : Boolean); + + -- Field: Field1 + function Get_We_Value (We : Iir_Waveform_Element) return Iir; + procedure Set_We_Value (We : Iir_Waveform_Element; An_Iir : Iir); + + -- Field: Field3 + function Get_Time (We : Iir_Waveform_Element) return Iir; + procedure Set_Time (We : Iir_Waveform_Element; An_Iir : Iir); + + -- Node associated with a choice. + -- Field: Field3 + function Get_Associated_Expr (Target : Iir) return Iir; + procedure Set_Associated_Expr (Target : Iir; Associated : Iir); + + -- Chain associated with a choice. + -- Field: Field4 Chain + function Get_Associated_Chain (Target : Iir) return Iir; + procedure Set_Associated_Chain (Target : Iir; Associated : Iir); + + -- Field: Field5 + function Get_Choice_Name (Choice : Iir) return Iir; + procedure Set_Choice_Name (Choice : Iir; Name : Iir); + + -- Field: Field5 + function Get_Choice_Expression (Choice : Iir) return Iir; + procedure Set_Choice_Expression (Choice : Iir; Name : Iir); + + -- Field: Field5 + function Get_Choice_Range (Choice : Iir) return Iir; + procedure Set_Choice_Range (Choice : Iir; Name : Iir); + + -- Set when a choice belongs to the same alternative as the previous one. + -- Field: Flag1 + function Get_Same_Alternative_Flag (Target : Iir) return Boolean; + procedure Set_Same_Alternative_Flag (Target : Iir; Val : Boolean); + + -- Field: Field3 + function Get_Architecture (Target : Iir_Entity_Aspect_Entity) return Iir; + procedure Set_Architecture (Target : Iir_Entity_Aspect_Entity; Arch : Iir); + + -- Field: Field5 + function Get_Block_Specification (Target : Iir) return Iir; + procedure Set_Block_Specification (Target : Iir; Block : Iir); + + -- Return the link of the previous block_configuration of a + -- block_configuration. + -- This single linked list is used to list all the block_configuration that + -- configuration the same block (which can only be an iterative generate + -- statement). + -- All elements of this list must belong to the same block configuration. + -- The order is not important. + -- Field: Field4 Ref + function Get_Prev_Block_Configuration (Target : Iir) return Iir; + procedure Set_Prev_Block_Configuration (Target : Iir; Block : Iir); + + -- Field: Field3 Chain + function Get_Configuration_Item_Chain (Target : Iir) return Iir; + procedure Set_Configuration_Item_Chain (Target : Iir; Chain : Iir); + + -- Chain of attribute values for a named entity. + -- To be used with Get/Set_Chain. + -- There is no order, therefore, a new attribute value may be always + -- prepended. + -- Field: Field4 Chain + function Get_Attribute_Value_Chain (Target : Iir) return Iir; + procedure Set_Attribute_Value_Chain (Target : Iir; Chain : Iir); + + -- Next attribute value in the attribute specification chain (of attribute + -- value). + -- Field: Field0 + function Get_Spec_Chain (Target : Iir) return Iir; + procedure Set_Spec_Chain (Target : Iir; Chain : Iir); + + -- Chain of attribute values for attribute specification. + -- To be used with Get/Set_Spec_Chain. + -- Field: Field4 + function Get_Attribute_Value_Spec_Chain (Target : Iir) return Iir; + procedure Set_Attribute_Value_Spec_Chain (Target : Iir; Chain : Iir); + + -- The entity name for an architecture or a configuration. + -- Field: Field2 + function Get_Entity_Name (Arch : Iir) return Iir; + procedure Set_Entity_Name (Arch : Iir; Entity : Iir); + + -- The package declaration corresponding to the body. + -- Field: Field4 Ref + function Get_Package (Package_Body : Iir) return Iir; + procedure Set_Package (Package_Body : Iir; Decl : Iir); + + -- The package body corresponding to the package declaration. + -- Field: Field2 Ref + function Get_Package_Body (Pkg : Iir) return Iir; + procedure Set_Package_Body (Pkg : Iir; Decl : Iir); + + -- If true, the package need a body. + -- Field: Flag1 + function Get_Need_Body (Decl : Iir_Package_Declaration) return Boolean; + procedure Set_Need_Body (Decl : Iir_Package_Declaration; Flag : Boolean); + + -- Field: Field5 + function Get_Block_Configuration (Target : Iir) return Iir; + procedure Set_Block_Configuration (Target : Iir; Block : Iir); + + -- Field: Field5 Chain + function Get_Concurrent_Statement_Chain (Target : Iir) return Iir; + procedure Set_Concurrent_Statement_Chain (Target : Iir; First : Iir); + + -- Field: Field2 Chain_Next + function Get_Chain (Target : Iir) return Iir; + procedure Set_Chain (Target : Iir; Chain : Iir); + pragma Inline (Get_Chain); + + -- Field: Field7 Chain + function Get_Port_Chain (Target : Iir) return Iir; + procedure Set_Port_Chain (Target : Iir; Chain : Iir); + + -- Field: Field6 Chain + function Get_Generic_Chain (Target : Iir) return Iir; + procedure Set_Generic_Chain (Target : Iir; Generics : Iir); + + -- Field: Field1 Ref + function Get_Type (Target : Iir) return Iir; + procedure Set_Type (Target : Iir; Atype : Iir); + pragma Inline (Get_Type); + + -- The subtype indication of a declaration. Note that this node can be + -- shared between declarations if they are separated by comma, such as in: + -- variable a, b : integer := 5; + -- Field: Field5 Maybe_Ref + function Get_Subtype_Indication (Target : Iir) return Iir; + procedure Set_Subtype_Indication (Target : Iir; Atype : Iir); + + -- Field: Field6 + function Get_Discrete_Range (Target : Iir) return Iir; + procedure Set_Discrete_Range (Target : Iir; Rng : Iir); + + -- Field: Field1 + function Get_Type_Definition (Decl : Iir) return Iir; + procedure Set_Type_Definition (Decl : Iir; Atype : Iir); + + -- The subtype definition associated with the type declaration (if any). + -- Field: Field4 + function Get_Subtype_Definition (Target : Iir) return Iir; + procedure Set_Subtype_Definition (Target : Iir; Def : Iir); + + -- Field: Field1 + function Get_Nature (Target : Iir) return Iir; + procedure Set_Nature (Target : Iir; Nature : Iir); + + -- Mode of interfaces or file (v87). + -- Field: Odigit1 (pos) + function Get_Mode (Target : Iir) return Iir_Mode; + procedure Set_Mode (Target : Iir; Mode : Iir_Mode); + + -- Field: State3 (pos) + function Get_Signal_Kind (Target : Iir) return Iir_Signal_Kind; + procedure Set_Signal_Kind (Target : Iir; Signal_Kind : Iir_Signal_Kind); + + -- The base name of a name is the node at the origin of the name. + -- The base name is a declaration (signal, object, constant or interface), + -- a selected_by_all name, an implicit_dereference name. + -- Field: Field5 Ref + function Get_Base_Name (Target : Iir) return Iir; + procedure Set_Base_Name (Target : Iir; Name : Iir); + pragma Inline (Get_Base_Name); + + -- Field: Field5 Chain + function Get_Interface_Declaration_Chain (Target : Iir) return Iir; + procedure Set_Interface_Declaration_Chain (Target : Iir; Chain : Iir); + pragma Inline (Get_Interface_Declaration_Chain); + + -- Field: Field4 Ref + function Get_Subprogram_Specification (Target : Iir) return Iir; + procedure Set_Subprogram_Specification (Target : Iir; Spec : Iir); + + -- Field: Field5 Chain + function Get_Sequential_Statement_Chain (Target : Iir) return Iir; + procedure Set_Sequential_Statement_Chain (Target : Iir; Chain : Iir); + + -- Field: Field9 Ref + function Get_Subprogram_Body (Target : Iir) return Iir; + procedure Set_Subprogram_Body (Target : Iir; A_Body : Iir); + + -- Several subprograms in a declarative region may have the same + -- identifier. If the overload number is not 0, it is the rank of the + -- subprogram. If the overload number is 0, then the identifier is not + -- overloaded in the declarative region. + -- Field: Field12 (pos) + function Get_Overload_Number (Target : Iir) return Iir_Int32; + procedure Set_Overload_Number (Target : Iir; Val : Iir_Int32); + + -- Depth of a subprogram. + -- For a subprogram declared immediatly within an entity, architecture, + -- package, process, block, generate, the depth is 0. + -- For a subprogram declared immediatly within a subprogram of level N, + -- the depth is N + 1. + -- Depth is used with depth of impure objects to check purity rules. + -- Field: Field10 (pos) + function Get_Subprogram_Depth (Target : Iir) return Iir_Int32; + procedure Set_Subprogram_Depth (Target : Iir; Depth : Iir_Int32); + + -- Hash of a subprogram profile. + -- This is used to speed up subprogram profile comparaison, which is very + -- often used by overload. + -- Field: Field11 (pos) + function Get_Subprogram_Hash (Target : Iir) return Iir_Int32; + procedure Set_Subprogram_Hash (Target : Iir; Val : Iir_Int32); + pragma Inline (Get_Subprogram_Hash); + + -- Depth of the deepest impure object. + -- Field: Field3 (uc) + function Get_Impure_Depth (Target : Iir) return Iir_Int32; + procedure Set_Impure_Depth (Target : Iir; Depth : Iir_Int32); + + -- Field: Field1 Ref + function Get_Return_Type (Target : Iir) return Iir; + procedure Set_Return_Type (Target : Iir; Decl : Iir); + pragma Inline (Get_Return_Type); + + -- Code of an implicit subprogram definition. + -- Field: Field9 (pos) + function Get_Implicit_Definition (D : Iir) return Iir_Predefined_Functions; + procedure Set_Implicit_Definition (D : Iir; Def : Iir_Predefined_Functions); + + -- For an implicit subprogram, the type_reference is the type declaration + -- for which the implicit subprogram was defined. + -- Field: Field10 Ref + function Get_Type_Reference (Target : Iir) return Iir; + procedure Set_Type_Reference (Target : Iir; Decl : Iir); + + -- Get the default value of an object declaration. + -- Null_iir if no default value. + -- Note that this node can be shared between declarations if they are + -- separated by comma, such as in: + -- variable a, b : integer := 5; + -- Field: Field6 Maybe_Ref + function Get_Default_Value (Target : Iir) return Iir; + procedure Set_Default_Value (Target : Iir; Value : Iir); + + -- The deferred_declaration field points to the deferred constant + -- declaration for a full constant declaration, or is null_iir for a + -- usual or deferred constant declaration. + -- Set only during sem. + -- Field: Field7 + function Get_Deferred_Declaration (Target : Iir) return Iir; + procedure Set_Deferred_Declaration (Target : Iir; Decl : Iir); + + -- The deferred_declaration_flag must be set if the constant declaration is + -- a deferred_constant declaration. + -- Set only during sem. + -- Field: Flag1 + function Get_Deferred_Declaration_Flag (Target : Iir) return Boolean; + procedure Set_Deferred_Declaration_Flag (Target : Iir; Flag : Boolean); + + -- If true, the variable is declared shared. + -- Field: Flag2 + function Get_Shared_Flag (Target : Iir) return Boolean; + procedure Set_Shared_Flag (Target : Iir; Shared : Boolean); + + -- Get the design unit in which the target is declared. + -- For a library unit, this is to get the design unit node. + -- Field: Field0 + function Get_Design_Unit (Target : Iir) return Iir; + procedure Set_Design_Unit (Target : Iir; Unit : Iir); + + -- Field: Field7 + function Get_Block_Statement (Target : Iir) return Iir; + procedure Set_Block_Statement (Target : Iir; Block : Iir); + + -- For a non-resolved signal: null_iir if the signal has no driver, or + -- a process/concurrent_statement for which the signal should have a + -- driver. This is used to catch at analyse time unresolved signals with + -- several drivers. + -- Field: Field7 + function Get_Signal_Driver (Target : Iir_Signal_Declaration) return Iir; + procedure Set_Signal_Driver (Target : Iir_Signal_Declaration; Driver : Iir); + + -- Field: Field1 Chain + function Get_Declaration_Chain (Target : Iir) return Iir; + procedure Set_Declaration_Chain (Target : Iir; Decls : Iir); + + -- Field: Field6 + function Get_File_Logical_Name (Target : Iir_File_Declaration) return Iir; + procedure Set_File_Logical_Name (Target : Iir_File_Declaration; Name : Iir); + + -- Field: Field7 + function Get_File_Open_Kind (Target : Iir_File_Declaration) return Iir; + procedure Set_File_Open_Kind (Target : Iir_File_Declaration; Kind : Iir); + + -- Field: Field4 (pos) + function Get_Element_Position (Target : Iir) return Iir_Index32; + 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 Ref + function Get_Selected_Element (Target : Iir) return Iir; + procedure Set_Selected_Element (Target : Iir; El : Iir); + + -- Selected names of an use_clause are chained. + -- Field: Field3 + function Get_Use_Clause_Chain (Target : Iir) return Iir; + procedure Set_Use_Clause_Chain (Target : Iir; Chain : Iir); + + -- Selected name of an use_clause. + -- Field: Field1 + function Get_Selected_Name (Target : Iir_Use_Clause) return Iir; + procedure Set_Selected_Name (Target : Iir_Use_Clause; Name : Iir); + + -- The type declarator which declares the type definition DEF. + -- Field: Field3 Ref + function Get_Type_Declarator (Def : Iir) return Iir; + procedure Set_Type_Declarator (Def : Iir; Decl : Iir); + + -- Field: Field2 (uc) + function Get_Enumeration_Literal_List (Target : Iir) return Iir_List; + procedure Set_Enumeration_Literal_List (Target : Iir; List : Iir_List); + + -- Field: Field1 Chain + function Get_Entity_Class_Entry_Chain (Target : Iir) return Iir; + procedure Set_Entity_Class_Entry_Chain (Target : Iir; Chain : Iir); + + -- Field: Field1 (uc) + function Get_Group_Constituent_List (Group : Iir) return Iir_List; + procedure Set_Group_Constituent_List (Group : Iir; List : Iir_List); + + -- Chain of physical type units. + -- The first unit is the primary unit. If you really need the primary + -- unit (and not the chain), you'd better to use Get_Primary_Unit. + -- Field: Field1 Chain + function Get_Unit_Chain (Target : Iir) return Iir; + procedure Set_Unit_Chain (Target : Iir; Chain : Iir); + + -- Alias of Get_Unit_Chain. + -- Return the primary unit of a physical type. + -- Field: Field1 Ref + function Get_Primary_Unit (Target : Iir) return Iir; + procedure Set_Primary_Unit (Target : Iir; Unit : Iir); + + -- Get/Set the identifier of a declaration. + -- Can also be used instead of get/set_label. + -- Field: Field3 (uc) + function Get_Identifier (Target : Iir) return Name_Id; + procedure Set_Identifier (Target : Iir; Identifier : Name_Id); + pragma Inline (Get_Identifier); + + -- Field: Field3 (uc) + function Get_Label (Target : Iir) return Name_Id; + procedure Set_Label (Target : Iir; Label : Name_Id); + + -- Get/Set the visible flag of a declaration. + -- The visible flag is true to make invalid the use of the identifier + -- during its declaration. It is set to false when the identifier is added + -- to the name table, and set to true when the declaration is finished. + -- Field: Flag4 + function Get_Visible_Flag (Target : Iir) return Boolean; + procedure Set_Visible_Flag (Target : Iir; Flag : Boolean); + + -- Field: Field1 + function Get_Range_Constraint (Target : Iir) return Iir; + procedure Set_Range_Constraint (Target : Iir; Constraint : Iir); + + -- Field: State2 (pos) + function Get_Direction (Decl : Iir) return Iir_Direction; + procedure Set_Direction (Decl : Iir; Dir : Iir_Direction); + + -- Field: Field2 + function Get_Left_Limit (Decl : Iir_Range_Expression) return Iir; + procedure Set_Left_Limit (Decl : Iir_Range_Expression; Limit : Iir); + + -- Field: Field3 + function Get_Right_Limit (Decl : Iir_Range_Expression) return Iir; + procedure Set_Right_Limit (Decl : Iir_Range_Expression; Limit : Iir); + + -- Field: Field4 Ref + function Get_Base_Type (Decl : Iir) return Iir; + procedure Set_Base_Type (Decl : Iir; Base_Type : Iir); + pragma Inline (Get_Base_Type); + + -- Either a resolution function name, an array_element_resolution or a + -- record_resolution + -- Field: Field5 + function Get_Resolution_Indication (Decl : Iir) return Iir; + procedure Set_Resolution_Indication (Decl : Iir; Ind : Iir); + + -- Field: Field1 Chain + function Get_Record_Element_Resolution_Chain (Res : Iir) return Iir; + procedure Set_Record_Element_Resolution_Chain (Res : Iir; Chain : Iir); + + -- Field: Field7 + function Get_Tolerance (Def : Iir) return Iir; + procedure Set_Tolerance (Def : Iir; Tol : Iir); + + -- Field: Field8 + function Get_Plus_Terminal (Def : Iir) return Iir; + procedure Set_Plus_Terminal (Def : Iir; Terminal : Iir); + + -- Field: Field9 + function Get_Minus_Terminal (Def : Iir) return Iir; + procedure Set_Minus_Terminal (Def : Iir; Terminal : Iir); + + -- Field: Field5 + function Get_Simultaneous_Left (Def : Iir) return Iir; + procedure Set_Simultaneous_Left (Def : Iir; Expr : Iir); + + -- Field: Field6 + function Get_Simultaneous_Right (Def : Iir) return Iir; + procedure Set_Simultaneous_Right (Def : Iir; Expr : Iir); + + -- True if ATYPE defines std.textio.text file type. + -- Field: Flag4 + 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); + + -- Reference either index_subtype_definition_list of array_type_definition + -- or index_constraint_list of array_subtype_definition. + -- Field: Field9 Ref (uc) + function Get_Index_Subtype_List (Decl : Iir) return Iir_List; + procedure Set_Index_Subtype_List (Decl : Iir; List : Iir_List); + + -- List of type marks for indexes type of array types. + -- Field: Field6 (uc) + function Get_Index_Subtype_Definition_List (Def : Iir) return Iir_List; + procedure Set_Index_Subtype_Definition_List (Def : Iir; Idx : Iir_List); + + -- The subtype_indication as it appears in a array type declaration. + -- Field: Field2 + function Get_Element_Subtype_Indication (Decl : Iir) return Iir; + procedure Set_Element_Subtype_Indication (Decl : Iir; Sub_Type : Iir); + + -- Field: Field1 Ref + function Get_Element_Subtype (Decl : Iir) return Iir; + procedure Set_Element_Subtype (Decl : Iir; Sub_Type : Iir); + + -- Field: Field6 (uc) + function Get_Index_Constraint_List (Def : Iir) return Iir_List; + procedure Set_Index_Constraint_List (Def : Iir; List : Iir_List); + + -- Field: Field8 + function Get_Array_Element_Constraint (Def : Iir) return Iir; + procedure Set_Array_Element_Constraint (Def : Iir; El : Iir); + + -- Chains of elements of a record. + -- Field: Field1 (uc) + function Get_Elements_Declaration_List (Decl : Iir) return Iir_List; + procedure Set_Elements_Declaration_List (Decl : Iir; List : Iir_List); + + -- Field: Field1 Ref + function Get_Designated_Type (Target : Iir) return Iir; + procedure Set_Designated_Type (Target : Iir; Dtype : Iir); + + -- Field: Field5 + function Get_Designated_Subtype_Indication (Target : Iir) return Iir; + procedure Set_Designated_Subtype_Indication (Target : Iir; Dtype : Iir); + + -- List of indexes for indexed name. + -- Field: Field2 (uc) + function Get_Index_List (Decl : Iir) return Iir_List; + procedure Set_Index_List (Decl : Iir; List : Iir_List); + + -- The terminal declaration for the reference (ground) of a nature + -- Field: Field2 + function Get_Reference (Def : Iir) return Iir; + procedure Set_Reference (Def : Iir; Ref : Iir); + + -- Field: Field3 + function Get_Nature_Declarator (Def : Iir) return Iir; + procedure Set_Nature_Declarator (Def : Iir; Decl : Iir); + + -- Field: Field7 + function Get_Across_Type (Def : Iir) return Iir; + procedure Set_Across_Type (Def : Iir; Atype : Iir); + + -- Field: Field8 + function Get_Through_Type (Def : Iir) return Iir; + procedure Set_Through_Type (Def : Iir; Atype : Iir); + + -- Field: Field1 + function Get_Target (Target : Iir) return Iir; + procedure Set_Target (Target : Iir; Atarget : Iir); + + -- Field: Field5 Chain + function Get_Waveform_Chain (Target : Iir) return Iir; + procedure Set_Waveform_Chain (Target : Iir; Chain : Iir); + + -- Field: Field8 + function Get_Guard (Target : Iir) return Iir; + procedure Set_Guard (Target : Iir; Guard : Iir); + + -- Field: Field12 (pos) + function Get_Delay_Mechanism (Target : Iir) return Iir_Delay_Mechanism; + procedure Set_Delay_Mechanism (Target : Iir; Kind : Iir_Delay_Mechanism); + + -- Field: Field6 + function Get_Reject_Time_Expression (Target : Iir) return Iir; + procedure Set_Reject_Time_Expression (Target : Iir; Expr : Iir); + + -- Field: Field6 (uc) + function Get_Sensitivity_List (Wait : Iir) return Iir_List; + procedure Set_Sensitivity_List (Wait : Iir; List : Iir_List); + + -- Field: Field8 + function Get_Process_Origin (Proc : Iir) return Iir; + procedure Set_Process_Origin (Proc : Iir; Orig : Iir); + + -- Field: Field5 + function Get_Condition_Clause (Wait : Iir_Wait_Statement) return Iir; + procedure Set_Condition_Clause (Wait : Iir_Wait_Statement; Cond : Iir); + + -- Field: Field1 + function Get_Timeout_Clause (Wait : Iir_Wait_Statement) return Iir; + procedure Set_Timeout_Clause (Wait : Iir_Wait_Statement; Timeout : Iir); + + -- If set, the concurrent statement is postponed. + -- Field: Flag3 + function Get_Postponed_Flag (Target : Iir) return Boolean; + procedure Set_Postponed_Flag (Target : Iir; Value : Boolean); + + -- Returns the list of subprogram called in this subprogram or process. + -- Note: implicit function (such as implicit operators) are omitted + -- from this list, since the purpose of this list is to correctly set + -- flags for side effects (purity_state, wait_state). + -- Can return null_iir if there is no subprogram called. + -- Field: Field7 Of_Ref (uc) + function Get_Callees_List (Proc : Iir) return Iir_List; + procedure Set_Callees_List (Proc : Iir; List : Iir_List); + + -- Get/Set the passive flag of a process. + -- TRUE if the process must be passive. + -- FALSE if the process may be not passive. + -- For a procedure declaration, set if it is passive. + -- Field: Flag2 + function Get_Passive_Flag (Proc : Iir) return Boolean; + procedure Set_Passive_Flag (Proc : Iir; Flag : Boolean); + + -- True if the function is used as a resolution function. + -- Field: Flag7 + function Get_Resolution_Function_Flag (Func : Iir) return Boolean; + procedure Set_Resolution_Function_Flag (Func : Iir; Flag : Boolean); + + -- Get/Set the wait state of the current subprogram or process. + -- TRUE if it contains a wait statement, either directly or + -- indirectly. + -- FALSE if it doesn't contain a wait statement. + -- UNKNOWN if the wait status is not yet known. + -- Field: State1 (pos) + function Get_Wait_State (Proc : Iir) return Tri_State_Type; + procedure Set_Wait_State (Proc : Iir; State : Tri_State_Type); + + -- Get/Set wether the subprogram may be called by a sensitized process + -- whose sensitivity list is ALL. + -- FALSE if declared in a package unit and reads a signal that is not + -- one of its interface, or if it calls such a subprogram. + -- TRUE if it doesn't call a subprogram whose state is False and + -- either doesn't read a signal or declared within an entity or + -- architecture. + -- UNKNOWN if the status is not yet known. + -- Field: State3 (pos) + function Get_All_Sensitized_State (Proc : Iir) return Iir_All_Sensitized; + procedure Set_All_Sensitized_State (Proc : Iir; State : Iir_All_Sensitized); + + -- Get/Set the seen flag. + -- Used when the graph of callees is walked, to avoid infinite loops, since + -- the graph is not a DAG (there may be cycles). + -- Field: Flag1 + function Get_Seen_Flag (Proc : Iir) return Boolean; + procedure Set_Seen_Flag (Proc : Iir; Flag : Boolean); + + -- Get/Set the pure flag of a function. + -- TRUE if the function is declared pure. + -- FALSE if the function is declared impure. + -- Field: Flag2 + function Get_Pure_Flag (Func : Iir) return Boolean; + procedure Set_Pure_Flag (Func : Iir; Flag : Boolean); + + -- Get/Set the foreign flag of a declaration. + -- TRUE if the declaration was decored with the std.foreign attribute. + -- Field: Flag3 + function Get_Foreign_Flag (Decl : Iir) return Boolean; + procedure Set_Foreign_Flag (Decl : Iir; Flag : Boolean); + + -- Get/Set the resolved flag of a subtype definition. + -- A subtype definition may be resolved either because a + -- resolution_indication is present in the subtype_indication, or + -- because all elements type are resolved. + -- Field: Flag1 + function Get_Resolved_Flag (Atype : Iir) return Boolean; + procedure Set_Resolved_Flag (Atype : Iir; Flag : Boolean); + + -- Get/Set the signal_type flag of a type/subtype definition. + -- This flags indicates whether the type can be used as a signal type. + -- Access types, file types and composite types whose a sub-element is + -- an access type cannot be used as a signal type. + -- Field: Flag2 + function Get_Signal_Type_Flag (Atype : Iir) return Boolean; + procedure Set_Signal_Type_Flag (Atype : Iir; Flag : Boolean); + + -- True if ATYPE is used to declare a signal or to handle a signal + -- (such as slice or aliases). + -- Field: Flag3 + function Get_Has_Signal_Flag (Atype : Iir) return Boolean; + procedure Set_Has_Signal_Flag (Atype : Iir; Flag : Boolean); + + -- Get/Set the purity status of a subprogram. + -- Field: State2 (pos) + function Get_Purity_State (Proc : Iir) return Iir_Pure_State; + procedure Set_Purity_State (Proc : Iir; State : Iir_Pure_State); + + -- Set during binding when DESIGN is added in a list of file to bind. + -- Field: Flag3 + 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; + procedure Set_Assertion_Condition (Target : Iir; Cond : Iir); + + -- Report expression of an assertion or report statement. + -- Field: Field6 + function Get_Report_Expression (Target : Iir) return Iir; + procedure Set_Report_Expression (Target : Iir; Expr : Iir); + + -- Severity expression of an assertion or report statement. + -- Field: Field5 + function Get_Severity_Expression (Target : Iir) return Iir; + procedure Set_Severity_Expression (Target : Iir; Expr : Iir); + + -- Instantiated unit of a component instantiation statement. + -- Field: Field1 + function Get_Instantiated_Unit (Target : Iir) return Iir; + procedure Set_Instantiated_Unit (Target : Iir; Unit : Iir); + + -- Generic map aspect list. + -- Field: Field8 Chain + function Get_Generic_Map_Aspect_Chain (Target : Iir) return Iir; + procedure Set_Generic_Map_Aspect_Chain (Target : Iir; Generics : Iir); + + -- Port map aspect list. + -- Field: Field9 Chain + function Get_Port_Map_Aspect_Chain (Target : Iir) return Iir; + procedure Set_Port_Map_Aspect_Chain (Target : Iir; Port : Iir); + + -- Configuration of an entity_aspect_configuration. + -- Field: Field1 + function Get_Configuration_Name (Target : Iir) return Iir; + procedure Set_Configuration_Name (Target : Iir; Conf : Iir); + + -- Component configuration for a component_instantiation_statement. + -- Field: Field6 + function Get_Component_Configuration (Target : Iir) return Iir; + procedure Set_Component_Configuration (Target : Iir; Conf : Iir); + + -- Configuration specification for a component_instantiation_statement. + -- Field: Field7 + function Get_Configuration_Specification (Target : Iir) return Iir; + procedure Set_Configuration_Specification (Target : Iir; Conf : Iir); + + -- Set/Get the default binding indication of a configuration specification + -- or a component configuration. + -- Field: Field5 + function Get_Default_Binding_Indication (Target : Iir) return Iir; + procedure Set_Default_Binding_Indication (Target : Iir; Conf : Iir); + + -- Set/Get the default configuration of an architecture. + -- Field: Field6 + function Get_Default_Configuration_Declaration (Target : Iir) return Iir; + procedure Set_Default_Configuration_Declaration (Target : Iir; Conf : Iir); + + -- Expression for an various nodes. + -- Field: Field5 + function Get_Expression (Target : Iir) return Iir; + procedure Set_Expression (Target : Iir; Expr : Iir); + + -- Set to the designated type (either the type of the expression or the + -- subtype) when the expression is analyzed. + -- Field: Field2 Ref + function Get_Allocator_Designated_Type (Target : Iir) return Iir; + procedure Set_Allocator_Designated_Type (Target : Iir; A_Type : Iir); + + -- Field: Field7 Chain + function Get_Selected_Waveform_Chain (Target : Iir) return Iir; + procedure Set_Selected_Waveform_Chain (Target : Iir; Chain : Iir); + + -- Field: Field7 Chain + function Get_Conditional_Waveform_Chain (Target : Iir) return Iir; + procedure Set_Conditional_Waveform_Chain (Target : Iir; Chain : Iir); + + -- Expression defining the value of the implicit guard signal. + -- Field: Field2 + function Get_Guard_Expression (Target : Iir) return Iir; + procedure Set_Guard_Expression (Target : Iir; Expr : Iir); + + -- The declaration (if any) of the implicit guard signal of a block + -- statement. + -- Field: Field8 + function Get_Guard_Decl (Target : Iir_Block_Statement) return Iir; + procedure Set_Guard_Decl (Target : Iir_Block_Statement; Decl : Iir); + + -- Sensitivity list for the implicit guard signal. + -- Field: Field6 (uc) + function Get_Guard_Sensitivity_List (Guard : Iir) return Iir_List; + procedure Set_Guard_Sensitivity_List (Guard : Iir; List : Iir_List); + + -- Block_Configuration that applies to this block statement. + -- Field: Field6 + function Get_Block_Block_Configuration (Block : Iir) return Iir; + procedure Set_Block_Block_Configuration (Block : Iir; Conf : Iir); + + -- Field: Field5 + function Get_Package_Header (Pkg : Iir) return Iir; + procedure Set_Package_Header (Pkg : Iir; Header : Iir); + + -- Field: Field7 + function Get_Block_Header (Target : Iir) return Iir; + procedure Set_Block_Header (Target : Iir; Header : Iir); + + -- Field: Field5 + function Get_Uninstantiated_Package_Name (Inst : Iir) return Iir; + procedure Set_Uninstantiated_Package_Name (Inst : Iir; Name : Iir); + + -- Get/Set the block_configuration (there may be several + -- block_configuration through the use of prev_configuration singly linked + -- list) that apply to this generate statement. + -- Field: Field7 + function Get_Generate_Block_Configuration (Target : Iir) return Iir; + procedure Set_Generate_Block_Configuration (Target : Iir; Conf : Iir); + + -- Field: Field6 + function Get_Generation_Scheme (Target : Iir) return Iir; + procedure Set_Generation_Scheme (Target : Iir; Scheme : Iir); + + -- Condition of a conditionam_waveform, if_statement, elsif, + -- while_loop_statement, next_statement or exit_statement. + -- Field: Field1 + function Get_Condition (Target : Iir) return Iir; + procedure Set_Condition (Target : Iir; Condition : Iir); + + -- Field: Field6 + function Get_Else_Clause (Target : Iir) return Iir; + procedure Set_Else_Clause (Target : Iir; Clause : Iir); + + -- Iterator of a for_loop_statement. + -- Field: Field1 + function Get_Parameter_Specification (Target : Iir) return Iir; + procedure Set_Parameter_Specification (Target : Iir; Param : Iir); + + -- Get/Set the statement in which TARGET appears. This is used to check + -- if next/exit is in a loop. + -- Field: Field0 Ref + function Get_Parent (Target : Iir) return Iir; + procedure Set_Parent (Target : Iir; Parent : Iir); + + -- Loop label for an exit_statement or next_statement. + -- Field: Field5 + function Get_Loop_Label (Target : Iir) return Iir; + procedure Set_Loop_Label (Target : Iir; Stmt : Iir); + + -- Component name for a component_configuration or + -- a configuration_specification. + -- Field: Field4 + function Get_Component_Name (Target : Iir) return Iir; + procedure Set_Component_Name (Target : Iir; Name : Iir); + + -- Field: Field1 (uc) + function Get_Instantiation_List (Target : Iir) return Iir_List; + procedure Set_Instantiation_List (Target : Iir; List : Iir_List); + + -- Field: Field3 + function Get_Entity_Aspect (Target : Iir_Binding_Indication) return Iir; + procedure Set_Entity_Aspect (Target : Iir_Binding_Indication; Entity : Iir); + + -- Field: Field1 + function Get_Default_Entity_Aspect (Target : Iir) return Iir; + procedure Set_Default_Entity_Aspect (Target : Iir; Aspect : Iir); + + -- Field: Field6 Chain + function Get_Default_Generic_Map_Aspect_Chain (Target : Iir) return Iir; + procedure Set_Default_Generic_Map_Aspect_Chain (Target : Iir; Chain : Iir); + + -- Field: Field7 Chain + function Get_Default_Port_Map_Aspect_Chain (Target : Iir) return Iir; + procedure Set_Default_Port_Map_Aspect_Chain (Target : Iir; Chain : Iir); + + -- Field: Field3 + function Get_Binding_Indication (Target : Iir) return Iir; + procedure Set_Binding_Indication (Target : Iir; Binding : Iir); + + -- The named entity designated by a name. + -- Field: Field4 Ref + function Get_Named_Entity (Name : Iir) return Iir; + procedure Set_Named_Entity (Name : Iir; Val : Iir); + + -- If a name designate a non-object alias, the designated alias. + -- Named_Entity will designate the aliased entity. + -- Field: Field2 + function Get_Alias_Declaration (Name : Iir) return Iir; + procedure Set_Alias_Declaration (Name : Iir; Val : Iir); + + -- Expression staticness, defined by rules of LRM 7.4 + -- Field: State1 (pos) + function Get_Expr_Staticness (Target : Iir) return Iir_Staticness; + procedure Set_Expr_Staticness (Target : Iir; Static : Iir_Staticness); + + -- Node which couldn't be correctly analyzed. + -- Field: Field2 + function Get_Error_Origin (Target : Iir) return Iir; + procedure Set_Error_Origin (Target : Iir; Origin : Iir); + + -- Operand of a monadic operator. + -- Field: Field2 + function Get_Operand (Target : Iir) return Iir; + procedure Set_Operand (Target : Iir; An_Iir : Iir); + + -- Left operand of a dyadic operator. + -- Field: Field2 + function Get_Left (Target : Iir) return Iir; + procedure Set_Left (Target : Iir; An_Iir : Iir); + + -- Right operand of a dyadic operator. + -- Field: Field4 + function Get_Right (Target : Iir) return Iir; + procedure Set_Right (Target : Iir; An_Iir : Iir); + + -- Field: Field3 + function Get_Unit_Name (Target : Iir) return Iir; + procedure Set_Unit_Name (Target : Iir; Name : Iir); + + -- Field: Field4 + function Get_Name (Target : Iir) return Iir; + procedure Set_Name (Target : Iir; Name : Iir); + + -- Field: Field5 + function Get_Group_Template_Name (Target : Iir) return Iir; + procedure Set_Group_Template_Name (Target : Iir; Name : Iir); + + -- Staticness of a name, according to rules of LRM 6.1 + -- Field: State2 (pos) + function Get_Name_Staticness (Target : Iir) return Iir_Staticness; + procedure Set_Name_Staticness (Target : Iir; Static : Iir_Staticness); + + -- Prefix of a name. + -- Field: Field0 + function Get_Prefix (Target : Iir) return Iir; + procedure Set_Prefix (Target : Iir; Prefix : Iir); + + -- Prefix of a name signature + -- Field: Field1 Ref + function Get_Signature_Prefix (Sign : Iir) return Iir; + procedure Set_Signature_Prefix (Sign : Iir; Prefix : Iir); + + -- The subtype of a slice. Contrary to the Type field, this is not a + -- reference. + -- Field: Field3 + function Get_Slice_Subtype (Slice : Iir) return Iir; + procedure Set_Slice_Subtype (Slice : Iir; Atype : Iir); + + -- Suffix of a slice or attribute. + -- Field: Field2 + function Get_Suffix (Target : Iir) return Iir; + procedure Set_Suffix (Target : Iir; Suffix : Iir); + + -- Set the designated index subtype of an array attribute. + -- Field: Field2 + function Get_Index_Subtype (Attr : Iir) return Iir; + procedure Set_Index_Subtype (Attr : Iir; St : Iir); + + -- Parameter of an attribute. + -- Field: Field4 + function Get_Parameter (Target : Iir) return Iir; + procedure Set_Parameter (Target : Iir; Param : Iir); + + -- Type of the actual for an association by individual. + -- Unless the formal is an unconstrained array type, this is the same as + -- the formal type. + -- Field: Field3 + function Get_Actual_Type (Target : Iir) return Iir; + procedure Set_Actual_Type (Target : Iir; Atype : Iir); + + -- Interface for a package association. + -- Field: Field4 Ref + function Get_Associated_Interface (Assoc : Iir) return Iir; + procedure Set_Associated_Interface (Assoc : Iir; Inter : Iir); + + -- List of individual associations for association_element_by_individual. + -- Associations for parenthesis_name. + -- Field: Field2 Chain + function Get_Association_Chain (Target : Iir) return Iir; + procedure Set_Association_Chain (Target : Iir; Chain : Iir); + + -- List of individual associations for association_element_by_individual. + -- Field: Field4 Chain + function Get_Individual_Association_Chain (Target : Iir) return Iir; + procedure Set_Individual_Association_Chain (Target : Iir; Chain : Iir); + + -- Get/Set info for the aggregate. + -- There is one aggregate_info for for each dimension. + -- Field: Field2 + function Get_Aggregate_Info (Target : Iir) return Iir; + procedure Set_Aggregate_Info (Target : Iir; Info : Iir); + + -- Get/Set the info node for the next dimension. + -- Field: Field1 + function Get_Sub_Aggregate_Info (Target : Iir) return Iir; + procedure Set_Sub_Aggregate_Info (Target : Iir; Info : Iir); + + -- TRUE when the length of the aggregate is not locally static. + -- Field: Flag3 + function Get_Aggr_Dynamic_Flag (Target : Iir) return Boolean; + procedure Set_Aggr_Dynamic_Flag (Target : Iir; Val : Boolean); + + -- Get/Set the minimum number of elements for the lowest dimension of + -- the aggregate or for the current dimension of a sub-aggregate. + -- The real number of elements may be greater than this number if there + -- is an 'other' choice. + -- Field: Field4 (uc) + function Get_Aggr_Min_Length (Info : Iir_Aggregate_Info) return Iir_Int32; + procedure Set_Aggr_Min_Length (Info : Iir_Aggregate_Info; Nbr : Iir_Int32); + + -- Highest index choice, if any. + -- Field: Field2 + function Get_Aggr_Low_Limit (Target : Iir_Aggregate_Info) return Iir; + procedure Set_Aggr_Low_Limit (Target : Iir_Aggregate_Info; Limit : Iir); + + -- Highest index choice, if any. + -- Field: Field3 + function Get_Aggr_High_Limit (Target : Iir_Aggregate_Info) return Iir; + procedure Set_Aggr_High_Limit (Target : Iir_Aggregate_Info; Limit : Iir); + + -- True if the aggregate has an 'others' choice. + -- Field: Flag2 + function Get_Aggr_Others_Flag (Target : Iir_Aggregate_Info) return Boolean; + procedure Set_Aggr_Others_Flag (Target : Iir_Aggregate_Info; Val : Boolean); + + -- True if the aggregate have named associations. + -- Field: Flag4 + function Get_Aggr_Named_Flag (Target : Iir_Aggregate_Info) return Boolean; + procedure Set_Aggr_Named_Flag (Target : Iir_Aggregate_Info; Val : Boolean); + + -- Staticness of the expressions in an aggregate. + -- We can't use expr_staticness for this purpose, since the staticness + -- of an aggregate is at most globally. + -- Field: State2 (pos) + function Get_Value_Staticness (Target : Iir) return Iir_Staticness; + procedure Set_Value_Staticness (Target : Iir; Staticness : Iir_Staticness); + + -- Chain of choices. + -- Field: Field4 Chain + function Get_Association_Choices_Chain (Target : Iir) return Iir; + procedure Set_Association_Choices_Chain (Target : Iir; Chain : Iir); + + -- Chain of choices. + -- Field: Field1 Chain + function Get_Case_Statement_Alternative_Chain (Target : Iir) return Iir; + procedure Set_Case_Statement_Alternative_Chain (Target : Iir; Chain : Iir); + + -- Staticness of the choice. + -- Field: State2 (pos) + function Get_Choice_Staticness (Target : Iir) return Iir_Staticness; + procedure Set_Choice_Staticness (Target : Iir; Staticness : Iir_Staticness); + + -- Field: Field1 + function Get_Procedure_Call (Stmt : Iir) return Iir; + procedure Set_Procedure_Call (Stmt : Iir; Call : Iir); + + -- Subprogram to be called by a procedure, function call or operator. This + -- is the declaration of the subprogram (or a list of during analysis). + -- Field: Field3 Ref + function Get_Implementation (Target : Iir) return Iir; + procedure Set_Implementation (Target : Iir; Decl : Iir); + + -- Paramater associations for procedure and function call. + -- Field: Field2 Chain + function Get_Parameter_Association_Chain (Target : Iir) return Iir; + procedure Set_Parameter_Association_Chain (Target : Iir; Chain : Iir); + + -- Object of a method call. NULL_IIR if the subprogram is not a method. + -- Field: Field4 + function Get_Method_Object (Target : Iir) return Iir; + procedure Set_Method_Object (Target : Iir; Object : Iir); + + -- The type_mark that appeared in the subtype indication. This is a name. + -- May be null_iir if there is no type mark (as in an iterator). + -- Field: Field2 + function Get_Subtype_Type_Mark (Target : Iir) return Iir; + procedure Set_Subtype_Type_Mark (Target : Iir; Mark : Iir); + + -- Field: Field3 + function Get_Type_Conversion_Subtype (Target : Iir) return Iir; + procedure Set_Type_Conversion_Subtype (Target : Iir; Atype : Iir); + + -- The type_mark that appeared in qualified expressions or type + -- conversions. + -- Field: Field4 + function Get_Type_Mark (Target : Iir) return Iir; + procedure Set_Type_Mark (Target : Iir; Mark : Iir); + + -- The type of values for a type file. + -- Field: Field2 + function Get_File_Type_Mark (Target : Iir) return Iir; + procedure Set_File_Type_Mark (Target : Iir; Mark : Iir); + + -- Field: Field8 + function Get_Return_Type_Mark (Target : Iir) return Iir; + procedure Set_Return_Type_Mark (Target : Iir; Mark : Iir); + + -- Get/set the lexical layout of an interface. + -- Field: Odigit2 (pos) + function Get_Lexical_Layout (Decl : Iir) return Iir_Lexical_Layout_Type; + procedure Set_Lexical_Layout (Decl : Iir; Lay : Iir_Lexical_Layout_Type); + + -- List of use (designated type of access types) of an incomplete type + -- definition. The purpose is to complete the uses with the full type + -- definition. + -- Field: Field2 (uc) + function Get_Incomplete_Type_List (Target : Iir) return Iir_List; + procedure Set_Incomplete_Type_List (Target : Iir; List : Iir_List); + + -- This flag is set on a signal_declaration, when a disconnection + -- specification applies to the signal (or a subelement of it). + -- This is used to check 'others' and 'all' designators. + -- Field: Flag1 + function Get_Has_Disconnect_Flag (Target : Iir) return Boolean; + procedure Set_Has_Disconnect_Flag (Target : Iir; Val : Boolean); + + -- This flag is set on a signal when its activity is read by the user. + -- Some signals handling can be optimized when this flag is set. + -- Field: Flag2 + function Get_Has_Active_Flag (Target : Iir) return Boolean; + procedure Set_Has_Active_Flag (Target : Iir; Val : Boolean); + + -- This flag is set is code being analyzed is textually within TARGET. + -- This is used for selected by name rule. + -- Field: Flag5 + function Get_Is_Within_Flag (Target : Iir) return Boolean; + procedure Set_Is_Within_Flag (Target : Iir; Val : Boolean); + + -- List of type_mark for an Iir_Kind_Signature + -- Field: Field2 (uc) + function Get_Type_Marks_List (Target : Iir) return Iir_List; + procedure Set_Type_Marks_List (Target : Iir; List : Iir_List); + + -- Field: Flag1 + function Get_Implicit_Alias_Flag (Decl : Iir) return Boolean; + procedure Set_Implicit_Alias_Flag (Decl : Iir; Flag : Boolean); + + -- Field: Field5 + function Get_Alias_Signature (Alias : Iir) return Iir; + procedure Set_Alias_Signature (Alias : Iir; Signature : Iir); + + -- Field: Field2 + function Get_Attribute_Signature (Attr : Iir) return Iir; + procedure Set_Attribute_Signature (Attr : Iir; Signature : Iir); + + -- Field: Field1 Of_Ref (uc) + function Get_Overload_List (Target : Iir) return Iir_List; + procedure Set_Overload_List (Target : Iir; List : Iir_List); + + -- Identifier of the simple_name attribute. + -- Field: Field3 (uc) + function Get_Simple_Name_Identifier (Target : Iir) return Name_Id; + procedure Set_Simple_Name_Identifier (Target : Iir; Ident : Name_Id); + + -- Subtype for Simple_Name attribute. + -- Field: Field4 + function Get_Simple_Name_Subtype (Target : Iir) return Iir; + procedure Set_Simple_Name_Subtype (Target : Iir; Atype : Iir); + + -- Body of a protected type declaration. + -- Field: Field2 + function Get_Protected_Type_Body (Target : Iir) return Iir; + procedure Set_Protected_Type_Body (Target : Iir; Bod : Iir); + + -- Corresponsing protected type declaration of a protected type body. + -- Field: Field4 + function Get_Protected_Type_Declaration (Target : Iir) return Iir; + procedure Set_Protected_Type_Declaration (Target : Iir; Decl : Iir); + + -- Location of the 'end' token. + -- Field: Field6 (uc) + function Get_End_Location (Target : Iir) return Location_Type; + procedure Set_End_Location (Target : Iir; Loc : Location_Type); + + -- For a string literal: the string identifier. + -- Field: Field3 (uc) + function Get_String_Id (Lit : Iir) return String_Id; + procedure Set_String_Id (Lit : Iir; Id : String_Id); + + -- For a string literal: the string length. + -- Field: Field4 (uc) + function Get_String_Length (Lit : Iir) return Int32; + procedure Set_String_Length (Lit : Iir; Len : Int32); + + -- For a declaration: true if the declaration is used somewhere. + -- Field: Flag6 + function Get_Use_Flag (Decl : Iir) return Boolean; + procedure Set_Use_Flag (Decl : Iir; Val : Boolean); + + -- Layout flag: true if 'end' is followed by the reserved identifier. + -- Field: Flag8 + function Get_End_Has_Reserved_Id (Decl : Iir) return Boolean; + procedure Set_End_Has_Reserved_Id (Decl : Iir; Flag : Boolean); + + -- Layout flag: true if 'end' is followed by the identifier. + -- Field: Flag9 + function Get_End_Has_Identifier (Decl : Iir) return Boolean; + procedure Set_End_Has_Identifier (Decl : Iir; Flag : Boolean); + + -- Layout flag: true if 'end' is followed by 'postponed'. + -- Field: Flag10 + function Get_End_Has_Postponed (Decl : Iir) return Boolean; + procedure Set_End_Has_Postponed (Decl : Iir; Flag : Boolean); + + -- Layout flag: true if 'begin' is present. + -- Field: Flag10 + function Get_Has_Begin (Decl : Iir) return Boolean; + procedure Set_Has_Begin (Decl : Iir; Flag : Boolean); + + -- Layout flag: true if 'is' is present. + -- Field: Flag7 + function Get_Has_Is (Decl : Iir) return Boolean; + procedure Set_Has_Is (Decl : Iir; Flag : Boolean); + + -- Layout flag: true if 'pure' or 'impure' is present. + -- Field: Flag8 + function Get_Has_Pure (Decl : Iir) return Boolean; + procedure Set_Has_Pure (Decl : Iir; Flag : Boolean); + + -- Layout flag: true if body appears just after the specification. + -- Field: Flag9 + function Get_Has_Body (Decl : Iir) return Boolean; + procedure Set_Has_Body (Decl : Iir; Flag : Boolean); + + -- Layout flag for object declaration. If True, the identifier of this + -- declaration is followed by an identifier (and separated by a comma). + -- This flag is set on all but the last declarations. + -- Eg: on 'signal A, B, C : Bit', the flag is set on A and B (but not C). + -- Field: Flag3 + function Get_Has_Identifier_List (Decl : Iir) return Boolean; + procedure Set_Has_Identifier_List (Decl : Iir; Flag : Boolean); + + -- Layout flag for object declaration. If True, the mode is present. + -- Field: Flag8 + function Get_Has_Mode (Decl : Iir) return Boolean; + procedure Set_Has_Mode (Decl : Iir; Flag : Boolean); + + -- Set to True if Maybe_Ref fields are references. This cannot be shared + -- with Has_Identifier_List as: Is_Ref is set to True on all items but + -- the first, while Has_Identifier_List is set to True on all items but + -- the last. Furthermore Is_Ref appears in nodes where Has_Identifier_List + -- is not present. + -- Field: Flag7 + function Get_Is_Ref (N : Iir) return Boolean; + procedure Set_Is_Ref (N : Iir; Ref : Boolean); + + -- Field: Field1 (uc) + function Get_Psl_Property (Decl : Iir) return PSL_Node; + procedure Set_Psl_Property (Decl : Iir; Prop : PSL_Node); + + -- Field: Field1 (uc) + function Get_Psl_Declaration (Decl : Iir) return PSL_Node; + procedure Set_Psl_Declaration (Decl : Iir; Prop : PSL_Node); + + -- Field: Field3 (uc) + function Get_Psl_Expression (Decl : Iir) return PSL_Node; + procedure Set_Psl_Expression (Decl : Iir; Prop : PSL_Node); + + -- Field: Field1 (uc) + function Get_Psl_Boolean (N : Iir) return PSL_Node; + procedure Set_Psl_Boolean (N : Iir; Bool : PSL_Node); + + -- Field: Field7 (uc) + function Get_PSL_Clock (N : Iir) return PSL_Node; + procedure Set_PSL_Clock (N : Iir; Clock : PSL_Node); + + -- Field: Field8 (uc) + function Get_PSL_NFA (N : Iir) return PSL_NFA; + procedure Set_PSL_NFA (N : Iir; Fa : PSL_NFA); +end Iirs; diff --git a/src/vhdl/iirs_utils.adb b/src/vhdl/iirs_utils.adb new file mode 100644 index 000000000..52c1ee8bb --- /dev/null +++ b/src/vhdl/iirs_utils.adb @@ -0,0 +1,1131 @@ +-- Common operations on nodes. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Scanner; use Scanner; +with Tokens; use Tokens; +with Errorout; use Errorout; +with Name_Table; +with Str_Table; +with Std_Names; use Std_Names; +with Flags; use Flags; +with PSL.Nodes; +with Sem_Inst; + +package body Iirs_Utils is + -- Transform the current token into an iir literal. + -- The current token must be either a character or an identifier. + function Current_Text return Iir is + Res: Iir; + begin + case Current_Token is + when Tok_Identifier => + Res := Create_Iir (Iir_Kind_Simple_Name); + when Tok_Character => + Res := Create_Iir (Iir_Kind_Character_Literal); + when others => + raise Internal_Error; + end case; + Set_Identifier (Res, Current_Identifier); + Invalidate_Current_Identifier; + Invalidate_Current_Token; + Set_Location (Res, Get_Token_Location); + return Res; + end Current_Text; + + function Is_Error (N : Iir) return Boolean is + begin + return Get_Kind (N) = Iir_Kind_Error; + end Is_Error; + + function Get_Operator_Name (Op : Iir) return Name_Id is + begin + case Get_Kind (Op) is + when Iir_Kind_And_Operator + | Iir_Kind_Reduction_And_Operator => + return Name_And; + when Iir_Kind_Or_Operator + | Iir_Kind_Reduction_Or_Operator => + return Name_Or; + when Iir_Kind_Nand_Operator + | Iir_Kind_Reduction_Nand_Operator => + return Name_Nand; + when Iir_Kind_Nor_Operator + | Iir_Kind_Reduction_Nor_Operator => + return Name_Nor; + when Iir_Kind_Xor_Operator + | Iir_Kind_Reduction_Xor_Operator => + return Name_Xor; + when Iir_Kind_Xnor_Operator + | Iir_Kind_Reduction_Xnor_Operator => + return Name_Xnor; + + when Iir_Kind_Equality_Operator => + return Name_Op_Equality; + when Iir_Kind_Inequality_Operator => + return Name_Op_Inequality; + when Iir_Kind_Less_Than_Operator => + return Name_Op_Less; + when Iir_Kind_Less_Than_Or_Equal_Operator => + return Name_Op_Less_Equal; + when Iir_Kind_Greater_Than_Operator => + return Name_Op_Greater; + when Iir_Kind_Greater_Than_Or_Equal_Operator => + return Name_Op_Greater_Equal; + + when Iir_Kind_Match_Equality_Operator => + return Name_Op_Match_Equality; + when Iir_Kind_Match_Inequality_Operator => + return Name_Op_Match_Inequality; + when Iir_Kind_Match_Less_Than_Operator => + return Name_Op_Match_Less; + when Iir_Kind_Match_Less_Than_Or_Equal_Operator => + return Name_Op_Match_Less_Equal; + when Iir_Kind_Match_Greater_Than_Operator => + return Name_Op_Match_Greater; + when Iir_Kind_Match_Greater_Than_Or_Equal_Operator => + return Name_Op_Match_Greater_Equal; + + when Iir_Kind_Sll_Operator => + return Name_Sll; + when Iir_Kind_Sla_Operator => + return Name_Sla; + when Iir_Kind_Srl_Operator => + return Name_Srl; + when Iir_Kind_Sra_Operator => + return Name_Sra; + when Iir_Kind_Rol_Operator => + return Name_Rol; + when Iir_Kind_Ror_Operator => + return Name_Ror; + when Iir_Kind_Addition_Operator => + return Name_Op_Plus; + when Iir_Kind_Substraction_Operator => + return Name_Op_Minus; + when Iir_Kind_Concatenation_Operator => + return Name_Op_Concatenation; + when Iir_Kind_Multiplication_Operator => + return Name_Op_Mul; + when Iir_Kind_Division_Operator => + return Name_Op_Div; + when Iir_Kind_Modulus_Operator => + return Name_Mod; + when Iir_Kind_Remainder_Operator => + return Name_Rem; + when Iir_Kind_Exponentiation_Operator => + return Name_Op_Exp; + when Iir_Kind_Not_Operator => + return Name_Not; + when Iir_Kind_Negation_Operator => + return Name_Op_Minus; + when Iir_Kind_Identity_Operator => + return Name_Op_Plus; + when Iir_Kind_Absolute_Operator => + return Name_Abs; + when Iir_Kind_Condition_Operator => + return Name_Op_Condition; + when others => + raise Internal_Error; + end case; + end Get_Operator_Name; + + function Get_Longuest_Static_Prefix (Expr: Iir) return Iir is + Adecl: Iir; + begin + Adecl := Expr; + loop + case Get_Kind (Adecl) is + when Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration => + return Adecl; + when Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration => + return Adecl; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + return Adecl; + when Iir_Kind_Object_Alias_Declaration => + -- LRM 4.3.3.1 Object Aliases + -- 2. The name must be a static name [...] + return Adecl; + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element => + if Get_Name_Staticness (Adecl) >= Globally then + return Adecl; + else + Adecl := Get_Prefix (Adecl); + end if; + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Adecl := Get_Named_Entity (Adecl); + when Iir_Kind_Type_Conversion => + return Null_Iir; + when others => + Error_Kind ("get_longuest_static_prefix", Adecl); + end case; + end loop; + end Get_Longuest_Static_Prefix; + + function Get_Object_Prefix (Name: Iir; With_Alias : Boolean := True) + return Iir + is + Adecl : Iir; + begin + Adecl := Name; + loop + case Get_Kind (Adecl) is + when Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Iterator_Declaration => + return Adecl; + when Iir_Kind_Object_Alias_Declaration => + if With_Alias then + Adecl := Get_Name (Adecl); + else + return Adecl; + end if; + when Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Selected_By_All_Name => + Adecl := Get_Base_Name (Adecl); + when Iir_Kinds_Literal + | Iir_Kind_Enumeration_Literal + | Iir_Kinds_Monadic_Operator + | Iir_Kinds_Dyadic_Operator + | Iir_Kind_Function_Call + | Iir_Kind_Qualified_Expression + | Iir_Kind_Type_Conversion + | Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype + | Iir_Kinds_Attribute + | Iir_Kind_Attribute_Value + | Iir_Kind_Aggregate + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Unit_Declaration + | Iir_Kinds_Concurrent_Statement => + return Adecl; + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Adecl := Get_Named_Entity (Adecl); + when Iir_Kind_Attribute_Name => + return Get_Named_Entity (Adecl); + when others => + Error_Kind ("get_object_prefix", Adecl); + end case; + end loop; + end Get_Object_Prefix; + + function Get_Association_Interface (Assoc : Iir) return Iir + is + Formal : Iir; + begin + Formal := Get_Formal (Assoc); + loop + case Get_Kind (Formal) is + when Iir_Kind_Simple_Name => + return Get_Named_Entity (Formal); + when Iir_Kinds_Interface_Object_Declaration => + return Formal; + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element => + Formal := Get_Prefix (Formal); + when others => + Error_Kind ("get_association_interface", Formal); + end case; + end loop; + end Get_Association_Interface; + + function Find_Name_In_List (List: Iir_List; Lit: Name_Id) return Iir is + El: Iir; + Ident: Name_Id; + begin + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Ident := Get_Identifier (El); + if Ident = Lit then + return El; + end if; + end loop; + return Null_Iir; + end Find_Name_In_List; + + function Find_Name_In_Chain (Chain: Iir; Lit: Name_Id) return Iir + is + El: Iir := Chain; + begin + while El /= Null_Iir loop + if Get_Identifier (El) = Lit then + return El; + end if; + El := Get_Chain (El); + end loop; + return Null_Iir; + end Find_Name_In_Chain; + + function Is_In_Chain (Chain : Iir; El : Iir) return Boolean + is + Chain_El : Iir; + begin + Chain_El := Chain; + while Chain_El /= Null_Iir loop + if Chain_El = El then + return True; + end if; + Chain_El := Get_Chain (Chain_El); + end loop; + return False; + end Is_In_Chain; + + procedure Add_Dependence (Target: Iir_Design_Unit; Unit: Iir) is + begin + -- Do not add self-dependency + if Unit = Target then + return; + end if; + + case Get_Kind (Unit) is + when Iir_Kind_Design_Unit + | Iir_Kind_Entity_Aspect_Entity => + null; + when others => + Error_Kind ("add_dependence", Unit); + end case; + + Add_Element (Get_Dependence_List (Target), Unit); + end Add_Dependence; + + procedure Clear_Instantiation_Configuration_Vhdl87 + (Parent : Iir; In_Generate : Boolean; Full : Boolean) + is + El : Iir; + Prev : Iir; + begin + El := Get_Concurrent_Statement_Chain (Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Instantiation_Statement => + if In_Generate and not Full then + Prev := Get_Component_Configuration (El); + if Prev /= Null_Iir then + case Get_Kind (Prev) is + when Iir_Kind_Configuration_Specification => + -- Keep it. + null; + when Iir_Kind_Component_Configuration => + Set_Component_Configuration (El, Null_Iir); + when others => + Error_Kind + ("clear_instantiation_configuration_vhdl87", + Prev); + end case; + end if; + else + Set_Component_Configuration (El, Null_Iir); + end if; + when Iir_Kind_Generate_Statement => + Set_Generate_Block_Configuration (El, Null_Iir); + -- Clear inside a generate statement. + Clear_Instantiation_Configuration_Vhdl87 (El, True, Full); + when Iir_Kind_Block_Statement => + Set_Block_Block_Configuration (El, Null_Iir); + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end Clear_Instantiation_Configuration_Vhdl87; + + procedure Clear_Instantiation_Configuration (Parent : Iir; Full : Boolean) + is + El : Iir; + begin + if False and then Flags.Vhdl_Std = Vhdl_87 then + Clear_Instantiation_Configuration_Vhdl87 + (Parent, Get_Kind (Parent) = Iir_Kind_Generate_Statement, Full); + else + El := Get_Concurrent_Statement_Chain (Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Instantiation_Statement => + Set_Component_Configuration (El, Null_Iir); + when Iir_Kind_Generate_Statement => + Set_Generate_Block_Configuration (El, Null_Iir); + when Iir_Kind_Block_Statement => + Set_Block_Block_Configuration (El, Null_Iir); + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end if; + end Clear_Instantiation_Configuration; + + function Get_String_Fat_Acc (Str : Iir) return String_Fat_Acc is + begin + return Str_Table.Get_String_Fat_Acc (Get_String_Id (Str)); + end Get_String_Fat_Acc; + + -- Get identifier of NODE as a string. + function Image_Identifier (Node : Iir) return String is + begin + return Name_Table.Image (Iirs.Get_Identifier (Node)); + end Image_Identifier; + + function Image_String_Lit (Str : Iir) return String + is + Ptr : String_Fat_Acc; + Len : Nat32; + begin + Ptr := Get_String_Fat_Acc (Str); + Len := Get_String_Length (Str); + return String (Ptr (1 .. Len)); + end Image_String_Lit; + + function Copy_Enumeration_Literal (Lit : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Enumeration_Literal); + Set_Identifier (Res, Get_Identifier (Lit)); + Location_Copy (Res, Lit); + Set_Parent (Res, Get_Parent (Lit)); + Set_Type (Res, Get_Type (Lit)); + Set_Enum_Pos (Res, Get_Enum_Pos (Lit)); + Set_Expr_Staticness (Res, Locally); + Set_Enumeration_Decl (Res, Lit); + return Res; + end Copy_Enumeration_Literal; + + procedure Create_Range_Constraint_For_Enumeration_Type + (Def : Iir_Enumeration_Type_Definition) + is + Range_Expr : Iir_Range_Expression; + Literal_List : constant Iir_List := Get_Enumeration_Literal_List (Def); + begin + -- Create a constraint. + Range_Expr := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Range_Expr, Def); + Set_Type (Range_Expr, Def); + Set_Direction (Range_Expr, Iir_To); + Set_Left_Limit + (Range_Expr, + Copy_Enumeration_Literal (Get_First_Element (Literal_List))); + Set_Right_Limit + (Range_Expr, + Copy_Enumeration_Literal (Get_Last_Element (Literal_List))); + Set_Expr_Staticness (Range_Expr, Locally); + Set_Range_Constraint (Def, Range_Expr); + end Create_Range_Constraint_For_Enumeration_Type; + + procedure Free_Name (Node : Iir) + is + N : Iir; + N1 : Iir; + begin + if Node = Null_Iir then + return; + end if; + N := Node; + case Get_Kind (N) is + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_String_Literal + | Iir_Kind_Subtype_Definition => + Free_Iir (N); + when Iir_Kind_Selected_Name + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Selected_By_All_Name => + N1 := Get_Prefix (N); + Free_Iir (N); + Free_Name (N1); + when Iir_Kind_Library_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Design_Unit + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement => + return; + when others => + Error_Kind ("free_name", Node); + --Free_Iir (N); + end case; + end Free_Name; + + procedure Free_Recursive_List (List : Iir_List) + is + El : Iir; + begin + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Free_Recursive (El); + end loop; + end Free_Recursive_List; + + procedure Free_Recursive (Node : Iir; Free_List : Boolean := False) + is + N : Iir; + begin + if Node = Null_Iir then + return; + end if; + N := Node; + case Get_Kind (N) is + when Iir_Kind_Library_Declaration => + return; + when Iir_Kind_Simple_Name + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Character_Literal => + null; + when Iir_Kind_Enumeration_Literal => + return; + when Iir_Kind_Selected_Name => + Free_Recursive (Get_Prefix (N)); + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Free_Recursive (Get_Type (N)); + Free_Recursive (Get_Default_Value (N)); + when Iir_Kind_Range_Expression => + Free_Recursive (Get_Left_Limit (N)); + Free_Recursive (Get_Right_Limit (N)); + when Iir_Kind_Subtype_Definition => + Free_Recursive (Get_Base_Type (N)); + when Iir_Kind_Integer_Literal => + null; + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration => + null; + when Iir_Kind_File_Type_Definition + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + return; + when Iir_Kind_Architecture_Body => + Free_Recursive (Get_Entity_Name (N)); + when Iir_Kind_Overload_List => + Free_Recursive_List (Get_Overload_List (N)); + if not Free_List then + return; + end if; + when Iir_Kind_Array_Subtype_Definition => + Free_Recursive_List (Get_Index_List (N)); + Free_Recursive (Get_Base_Type (N)); + when Iir_Kind_Entity_Aspect_Entity => + Free_Recursive (Get_Entity (N)); + Free_Recursive (Get_Architecture (N)); + when others => + Error_Kind ("free_recursive", Node); + end case; + Free_Iir (N); + end Free_Recursive; + + function Get_Predefined_Function_Name (Func : Iir_Predefined_Functions) + return String + is + begin + return Iir_Predefined_Functions'Image (Func); + end Get_Predefined_Function_Name; + + procedure Mark_Subprogram_Used (Subprg : Iir) + is + N : Iir; + begin + N := Subprg; + loop + exit when Get_Use_Flag (N); + Set_Use_Flag (N, True); + N := Sem_Inst.Get_Origin (N); + -- The origin may also be an instance. + exit when N = Null_Iir; + end loop; + end Mark_Subprogram_Used; + + function Get_Callees_List_Holder (Subprg : Iir) return Iir is + begin + case Get_Kind (Subprg) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + return Get_Subprogram_Body (Subprg); + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + return Subprg; + when others => + Error_Kind ("get_callees_list_holder", Subprg); + end case; + end Get_Callees_List_Holder; + + procedure Clear_Seen_Flag (Top : Iir) + is + Callees_List : Iir_Callees_List; + El: Iir; + begin + if Get_Seen_Flag (Top) then + Set_Seen_Flag (Top, False); + Callees_List := Get_Callees_List (Get_Callees_List_Holder (Top)); + if Callees_List /= Null_Iir_List then + for I in Natural loop + El := Get_Nth_Element (Callees_List, I); + exit when El = Null_Iir; + if Get_Seen_Flag (El) = False then + Clear_Seen_Flag (El); + end if; + end loop; + end if; + end if; + end Clear_Seen_Flag; + + function Is_Anonymous_Type_Definition (Def : Iir) return Boolean is + begin + return Get_Type_Declarator (Def) = Null_Iir; + end Is_Anonymous_Type_Definition; + + function Is_Fully_Constrained_Type (Def : Iir) return Boolean is + begin + 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 Strip_Denoting_Name (Name : Iir) return Iir is + begin + if Get_Kind (Name) in Iir_Kinds_Denoting_Name then + return Get_Named_Entity (Name); + else + return Name; + end if; + end Strip_Denoting_Name; + + function Build_Simple_Name (Ref : Iir; Loc : Location_Type) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Simple_Name); + Set_Location (Res, Loc); + Set_Identifier (Res, Get_Identifier (Ref)); + Set_Named_Entity (Res, Ref); + Set_Base_Name (Res, Res); + -- FIXME: set type and expr staticness ? + return Res; + end Build_Simple_Name; + + function Build_Simple_Name (Ref : Iir; Loc : Iir) return Iir is + begin + return Build_Simple_Name (Ref, Get_Location (Loc)); + end Build_Simple_Name; + + function Has_Resolution_Function (Subtyp : Iir) return Iir + is + Ind : constant Iir := Get_Resolution_Indication (Subtyp); + begin + if Ind /= Null_Iir + and then Get_Kind (Ind) in Iir_Kinds_Denoting_Name + then + return Get_Named_Entity (Ind); + else + return Null_Iir; + end if; + end Has_Resolution_Function; + + function Get_Primary_Unit_Name (Physical_Def : Iir) return Iir + is + Unit : constant Iir := Get_Primary_Unit (Physical_Def); + begin + return Get_Unit_Name (Get_Physical_Unit_Value (Unit)); + end Get_Primary_Unit_Name; + + function Is_Type_Name (Name : Iir) return Iir + is + Ent : Iir; + begin + if Get_Kind (Name) in Iir_Kinds_Denoting_Name then + Ent := Get_Named_Entity (Name); + case Get_Kind (Ent) is + when Iir_Kind_Type_Declaration => + return Get_Type_Definition (Ent); + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Base_Attribute => + return Get_Type (Ent); + when others => + return Null_Iir; + end case; + else + return Null_Iir; + end if; + end Is_Type_Name; + + function Get_Type_Of_Subtype_Indication (Ind : Iir) return Iir is + begin + case Get_Kind (Ind) is + when Iir_Kinds_Denoting_Name => + return Get_Type (Ind); + when Iir_Kinds_Subtype_Definition => + return Ind; + when others => + Error_Kind ("get_type_of_subtype_indication", Ind); + end case; + end Get_Type_Of_Subtype_Indication; + + function Get_Index_Type (Indexes : Iir_List; Idx : Natural) return Iir + is + Index : constant Iir := Get_Nth_Element (Indexes, Idx); + begin + if Index = Null_Iir then + return Null_Iir; + else + return Get_Index_Type (Index); + end if; + end Get_Index_Type; + + function Get_Index_Type (Array_Type : Iir; Idx : Natural) return Iir is + begin + return Get_Index_Type (Get_Index_Subtype_List (Array_Type), Idx); + end Get_Index_Type; + + function Get_Denoted_Type_Mark (Subtyp : Iir) return Iir + is + Type_Mark_Name : constant Iir := Get_Subtype_Type_Mark (Subtyp); + begin + if Type_Mark_Name = Null_Iir then + -- No type_mark (for array subtype created by constrained array + -- definition. + return Null_Iir; + else + return Get_Type (Get_Named_Entity (Type_Mark_Name)); + end if; + end Get_Denoted_Type_Mark; + + function Is_Second_Subprogram_Specification (Spec : Iir) return Boolean + is + Bod : constant Iir := Get_Subprogram_Body (Spec); + begin + return Bod /= Null_Iir + and then Get_Subprogram_Specification (Bod) /= Spec; + end Is_Second_Subprogram_Specification; + + function Is_Same_Profile (L, R: Iir) return Boolean + is + L1, R1 : Iir; + L_Kind, R_Kind : Iir_Kind; + El_L, El_R : Iir; + begin + L_Kind := Get_Kind (L); + if L_Kind = Iir_Kind_Non_Object_Alias_Declaration then + L1 := Get_Named_Entity (Get_Name (L)); + L_Kind := Get_Kind (L1); + else + L1 := L; + end if; + R_Kind := Get_Kind (R); + if R_Kind = Iir_Kind_Non_Object_Alias_Declaration then + R1 := Get_Named_Entity (Get_Name (R)); + R_Kind := Get_Kind (R1); + else + R1 := R; + end if; + + -- Check L and R are both of the same 'kind'. + -- Also the return profile for functions. + if L_Kind in Iir_Kinds_Function_Declaration + and then R_Kind in Iir_Kinds_Function_Declaration + then + if Get_Base_Type (Get_Return_Type (L1)) /= + Get_Base_Type (Get_Return_Type (R1)) + then + return False; + end if; + elsif L_Kind in Iir_Kinds_Procedure_Declaration + and then R_Kind in Iir_Kinds_Procedure_Declaration + then + null; + elsif L_Kind = Iir_Kind_Enumeration_Literal + and then R_Kind = Iir_Kind_Enumeration_Literal + then + return Get_Type (L1) = Get_Type (R1); + else + -- Kind mismatch. + return False; + end if; + + -- Check parameters profile. + El_L := Get_Interface_Declaration_Chain (L1); + El_R := Get_Interface_Declaration_Chain (R1); + loop + exit when El_L = Null_Iir and El_R = Null_Iir; + if El_L = Null_Iir or El_R = Null_Iir then + return False; + end if; + if Get_Base_Type (Get_Type (El_L)) /= Get_Base_Type (Get_Type (El_R)) + then + return False; + end if; + El_L := Get_Chain (El_L); + El_R := Get_Chain (El_R); + end loop; + + return True; + end Is_Same_Profile; + + -- From a block_specification, returns the block. + function Get_Block_From_Block_Specification (Block_Spec : Iir) + return Iir + is + Res : Iir; + begin + case Get_Kind (Block_Spec) is + when Iir_Kind_Design_Unit => + Res := Get_Library_Unit (Block_Spec); + if Get_Kind (Res) /= Iir_Kind_Architecture_Body then + raise Internal_Error; + end if; + return Res; + when Iir_Kind_Block_Statement + | Iir_Kind_Architecture_Body + | Iir_Kind_Generate_Statement => + return Block_Spec; + when Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Slice_Name => + return Get_Named_Entity (Get_Prefix (Block_Spec)); + when Iir_Kind_Simple_Name => + return Get_Named_Entity (Block_Spec); + when others => + Error_Kind ("get_block_from_block_specification", Block_Spec); + return Null_Iir; + end case; + end Get_Block_From_Block_Specification; + + function Get_Entity (Decl : Iir) return Iir + is + Name : constant Iir := Get_Entity_Name (Decl); + Res : constant Iir := Get_Named_Entity (Name); + begin + pragma Assert (Res = Null_Iir + or else Get_Kind (Res) = Iir_Kind_Entity_Declaration); + return Res; + end Get_Entity; + + function Get_Configuration (Aspect : Iir) return Iir + is + Name : constant Iir := Get_Configuration_Name (Aspect); + Res : constant Iir := Get_Named_Entity (Name); + begin + pragma Assert (Get_Kind (Res) = Iir_Kind_Configuration_Declaration); + return Res; + end Get_Configuration; + + function Get_Entity_Identifier_Of_Architecture (Arch : Iir) return Name_Id + is + Name : constant Iir := Get_Entity_Name (Arch); + begin + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Get_Identifier (Name); + when others => + Error_Kind ("get_entity_identifier_of_architecture", Name); + end case; + end Get_Entity_Identifier_Of_Architecture; + + function Is_Component_Instantiation + (Inst : Iir_Component_Instantiation_Statement) + return Boolean is + begin + case Get_Kind (Get_Instantiated_Unit (Inst)) is + when Iir_Kinds_Denoting_Name => + return True; + when Iir_Kind_Entity_Aspect_Entity + | Iir_Kind_Entity_Aspect_Configuration => + return False; + when others => + Error_Kind ("is_component_instantiation", Inst); + end case; + end Is_Component_Instantiation; + + function Is_Entity_Instantiation + (Inst : Iir_Component_Instantiation_Statement) + return Boolean is + begin + case Get_Kind (Get_Instantiated_Unit (Inst)) is + when Iir_Kinds_Denoting_Name => + return False; + when Iir_Kind_Entity_Aspect_Entity + | Iir_Kind_Entity_Aspect_Configuration => + return True; + when others => + Error_Kind ("is_entity_instantiation", Inst); + end case; + end Is_Entity_Instantiation; + + function Get_String_Type_Bound_Type (Sub_Type : Iir) return Iir is + begin + if Get_Kind (Sub_Type) /= Iir_Kind_Array_Subtype_Definition then + Error_Kind ("get_string_type_bound_type", Sub_Type); + end if; + return Get_First_Element (Get_Index_Subtype_List (Sub_Type)); + end Get_String_Type_Bound_Type; + + procedure Get_Low_High_Limit (Arange : Iir_Range_Expression; + Low, High : out Iir) + is + begin + case Get_Direction (Arange) is + when Iir_To => + Low := Get_Left_Limit (Arange); + High := Get_Right_Limit (Arange); + when Iir_Downto => + High := Get_Left_Limit (Arange); + Low := Get_Right_Limit (Arange); + end case; + end Get_Low_High_Limit; + + function Get_Low_Limit (Arange : Iir_Range_Expression) return Iir is + begin + case Get_Direction (Arange) is + when Iir_To => + return Get_Left_Limit (Arange); + when Iir_Downto => + return Get_Right_Limit (Arange); + end case; + end Get_Low_Limit; + + function Get_High_Limit (Arange : Iir_Range_Expression) return Iir is + begin + case Get_Direction (Arange) is + when Iir_To => + return Get_Right_Limit (Arange); + when Iir_Downto => + return Get_Left_Limit (Arange); + end case; + end Get_High_Limit; + + function Is_One_Dimensional_Array_Type (A_Type : Iir) return Boolean + is + Base_Type : constant Iir := Get_Base_Type (A_Type); + begin + if Get_Kind (Base_Type) = Iir_Kind_Array_Type_Definition + and then Get_Nbr_Elements (Get_Index_Subtype_List (Base_Type)) = 1 + then + return True; + else + return False; + end if; + end Is_One_Dimensional_Array_Type; + + function Is_Range_Attribute_Name (Expr : Iir) return Boolean + is + Attr : Iir; + Id : Name_Id; + begin + if Get_Kind (Expr) = Iir_Kind_Parenthesis_Name then + Attr := Get_Prefix (Expr); + else + Attr := Expr; + end if; + if Get_Kind (Attr) /= Iir_Kind_Attribute_Name then + return False; + end if; + Id := Get_Identifier (Attr); + return Id = Name_Range or Id = Name_Reverse_Range; + end Is_Range_Attribute_Name; + + function Create_Array_Subtype (Arr_Type : Iir; Loc : Location_Type) + return Iir_Array_Subtype_Definition + is + Res : Iir_Array_Subtype_Definition; + Base_Type : Iir; + List : Iir_List; + begin + Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Location (Res, Loc); + Base_Type := Get_Base_Type (Arr_Type); + Set_Base_Type (Res, Base_Type); + Set_Element_Subtype (Res, Get_Element_Subtype (Base_Type)); + if Get_Kind (Arr_Type) = Iir_Kind_Array_Subtype_Definition then + Set_Resolution_Indication (Res, Get_Resolution_Indication (Arr_Type)); + end if; + Set_Resolved_Flag (Res, Get_Resolved_Flag (Arr_Type)); + Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Arr_Type)); + Set_Type_Staticness (Res, Get_Type_Staticness (Base_Type)); + List := Create_Iir_List; + Set_Index_Subtype_List (Res, List); + Set_Index_Constraint_List (Res, List); + return Res; + end Create_Array_Subtype; + + function Is_Subprogram_Method (Spec : Iir) return Boolean is + begin + case Get_Kind (Get_Parent (Spec)) is + when Iir_Kind_Protected_Type_Declaration + | Iir_Kind_Protected_Type_Body => + return True; + when others => + return False; + end case; + end Is_Subprogram_Method; + + function Get_Method_Type (Spec : Iir) return Iir + is + Parent : Iir; + begin + Parent := Get_Parent (Spec); + case Get_Kind (Parent) is + when Iir_Kind_Protected_Type_Declaration => + return Parent; + when Iir_Kind_Protected_Type_Body => + return Get_Protected_Type_Declaration (Parent); + when others => + return Null_Iir; + end case; + end Get_Method_Type; + + function Create_Error_Expr (Orig : Iir; Atype : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Error); + Set_Expr_Staticness (Res, None); + Set_Type (Res, Atype); + Set_Error_Origin (Res, Orig); + Location_Copy (Res, Orig); + return Res; + end Create_Error_Expr; + + function Create_Error_Type (Orig : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Error); + --Set_Expr_Staticness (Res, Locally); + Set_Base_Type (Res, Res); + Set_Error_Origin (Res, Orig); + Location_Copy (Res, Orig); + Set_Type_Declarator (Res, Null_Iir); + Set_Resolved_Flag (Res, True); + Set_Signal_Type_Flag (Res, True); + return Res; + end Create_Error_Type; + + -- Extract the entity from ASPECT. + -- Note: if ASPECT is a component declaration, returns ASPECT. + function Get_Entity_From_Entity_Aspect (Aspect : Iir) return Iir + is + Inst : Iir; + begin + case Get_Kind (Aspect) is + when Iir_Kinds_Denoting_Name => + -- A component declaration. + Inst := Get_Named_Entity (Aspect); + pragma Assert (Get_Kind (Inst) = Iir_Kind_Component_Declaration); + return Inst; + when Iir_Kind_Component_Declaration => + return Aspect; + when Iir_Kind_Entity_Aspect_Entity => + return Get_Entity (Aspect); + when Iir_Kind_Entity_Aspect_Configuration => + Inst := Get_Configuration (Aspect); + return Get_Entity (Inst); + when Iir_Kind_Entity_Aspect_Open => + return Null_Iir; + when others => + Error_Kind ("get_entity_from_entity_aspect", Aspect); + end case; + end Get_Entity_From_Entity_Aspect; + + function Is_Signal_Object (Name : Iir) return Boolean + is + Adecl: Iir; + begin + Adecl := Get_Object_Prefix (Name, True); + case Get_Kind (Adecl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kinds_Signal_Attribute => + return True; + when Iir_Kind_Object_Alias_Declaration => + raise Internal_Error; + when others => + return False; + end case; + end Is_Signal_Object; + + -- LRM08 4.7 Package declarations + -- If the package header is empty, the package declared by a package + -- declaration is called a simple package. + function Is_Simple_Package (Pkg : Iir) return Boolean is + begin + return Get_Package_Header (Pkg) = Null_Iir; + end Is_Simple_Package; + + -- LRM08 4.7 Package declarations + -- If the package header contains a generic clause and no generic map + -- aspect, the package is called an uninstantiated package. + function Is_Uninstantiated_Package (Pkg : Iir) return Boolean + is + Header : constant Iir := Get_Package_Header (Pkg); + begin + return Header /= Null_Iir + and then Get_Generic_Map_Aspect_Chain (Header) = Null_Iir; + end Is_Uninstantiated_Package; + + -- LRM08 4.7 Package declarations + -- If the package header contains both a generic clause and a generic + -- map aspect, the package is declared a generic-mapped package. + function Is_Generic_Mapped_Package (Pkg : Iir) return Boolean + is + Header : constant Iir := Get_Package_Header (Pkg); + begin + return Header /= Null_Iir + and then Get_Generic_Map_Aspect_Chain (Header) /= Null_Iir; + end Is_Generic_Mapped_Package; + + function Kind_In (N : Iir; K1, K2 : Iir_Kind) return Boolean + is + K : constant Iir_Kind := Get_Kind (N); + begin + return K = K1 or K = K2; + end Kind_In; + + function Get_HDL_Node (N : PSL_Node) return Iir is + begin + return Iir (PSL.Nodes.Get_HDL_Node (N)); + end Get_HDL_Node; + + procedure Set_HDL_Node (N : PSL_Node; Expr : Iir) is + begin + PSL.Nodes.Set_HDL_Node (N, PSL.Nodes.HDL_Node (Expr)); + end Set_HDL_Node; +end Iirs_Utils; diff --git a/src/vhdl/iirs_utils.ads b/src/vhdl/iirs_utils.ads new file mode 100644 index 000000000..a588ab870 --- /dev/null +++ b/src/vhdl/iirs_utils.ads @@ -0,0 +1,250 @@ +-- Common operations on nodes. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Iirs; use Iirs; + +package Iirs_Utils is + -- Transform the current token into an iir literal. + -- The current token must be either a character, a string or an identifier. + function Current_Text return Iir; + + -- Get identifier of NODE as a string. + function Image_Identifier (Node : Iir) return String; + function Image_String_Lit (Str : Iir) return String; + + -- Easier function for string literals. + function Get_String_Fat_Acc (Str : Iir) return String_Fat_Acc; + pragma Inline (Get_String_Fat_Acc); + + -- Return True iff N is an error node. + function Is_Error (N : Iir) return Boolean; + pragma Inline (Is_Error); + + -- Find LIT in the list of identifiers or characters LIST. + -- Return the literal (whose name is LIT) or null_iir if not found. + function Find_Name_In_Chain (Chain: Iir; Lit: Name_Id) return Iir; + function Find_Name_In_List (List : Iir_List; Lit: Name_Id) return Iir; + + -- Return TRUE if EL in an element of chain CHAIN. + function Is_In_Chain (Chain : Iir; El : Iir) return Boolean; + + -- Convert an operator node to a name. + function Get_Operator_Name (Op : Iir) return Name_Id; + + -- Get the longuest static prefix of EXPR. + -- See LRM §8.1 + function Get_Longuest_Static_Prefix (Expr: Iir) return Iir; + + -- Get the prefix of NAME, ie the declaration at the base of NAME. + -- Return NAME itself if NAME is not an object or a subelement of + -- an object. If WITH_ALIAS is true, continue with the alias name when an + -- alias is found, else return the alias. + -- FIXME: clarify when NAME is returned. + function Get_Object_Prefix (Name: Iir; With_Alias : Boolean := True) + return Iir; + + + -- Get the interface associated by the association ASSOC. This is always + -- an interface, even if the formal is a name. + function Get_Association_Interface (Assoc : Iir) return Iir; + + -- Duplicate enumeration literal LIT. + function Copy_Enumeration_Literal (Lit : Iir) return Iir; + + -- Make TARGETS depends on UNIT. + -- UNIT must be either a design unit or a entity_aspect_entity. + procedure Add_Dependence (Target: Iir_Design_Unit; Unit: Iir); + + -- Clear configuration field of all component instantiation of + -- the concurrent statements of PARENT. + procedure Clear_Instantiation_Configuration (Parent : Iir; Full : Boolean); + + -- Free Node and its prefixes, if any. + procedure Free_Name (Node : Iir); + + -- Free NODE and its sub-nodes. + procedure Free_Recursive (Node : Iir; Free_List : Boolean := False); + + -- Name of FUNC. + function Get_Predefined_Function_Name (Func : Iir_Predefined_Functions) + return String; + + -- Mark SUBPRG as used. If SUBPRG is an instance, its generic is also + -- marked. + procedure Mark_Subprogram_Used (Subprg : Iir); + + -- Create the range_constraint node for an enumeration type. + procedure Create_Range_Constraint_For_Enumeration_Type + (Def : Iir_Enumeration_Type_Definition); + + -- Return the node containing the Callees_List (ie the subprogram body if + -- SUBPRG is a subprogram spec, SUBPRG if SUBPRG is a process). + function Get_Callees_List_Holder (Subprg : Iir) return Iir; + + -- Clear flag of TOP and all of its callees. + procedure Clear_Seen_Flag (Top : Iir); + + -- Return TRUE iff DEF is an anonymous type (or subtype) definition. + -- Note: DEF is required to be a type (or subtype) definition. + -- Note: type (and not subtype) are never anonymous. + function Is_Anonymous_Type_Definition (Def : Iir) return Boolean; + pragma Inline (Is_Anonymous_Type_Definition); + + -- Return TRUE iff DEF is a fully constrained type (or subtype) definition. + function Is_Fully_Constrained_Type (Def : Iir) return Boolean; + + -- Return the type definition/subtype indication of NAME if NAME denotes + -- a type or subtype name. Otherwise, return Null_Iir; + function Is_Type_Name (Name : Iir) return Iir; + + -- Return TRUE iff SPEC is the subprogram specification of a subprogram + -- body which was previously declared. In that case, the only use of SPEC + -- is to match the body with its declaration. + function Is_Second_Subprogram_Specification (Spec : Iir) return Boolean; + + -- If NAME is a simple or an expanded name, return the denoted declaration. + -- Otherwise, return NAME. + function Strip_Denoting_Name (Name : Iir) return Iir; + + -- Build a simple name node whose named entity is REF and location LOC. + function Build_Simple_Name (Ref : Iir; Loc : Location_Type) return Iir; + function Build_Simple_Name (Ref : Iir; Loc : Iir) return Iir; + + -- If SUBTYP has a resolution indication that is a function name, returns + -- the function declaration (not the name). + function Has_Resolution_Function (Subtyp : Iir) return Iir; + + -- Return a simple name for the primary unit of physical type PHYSICAL_DEF. + -- This is the artificial unit name for the value of the primary unit, thus + -- its location is the location of the primary unit. Used mainly to build + -- evaluated literals. + function Get_Primary_Unit_Name (Physical_Def : Iir) return Iir; + + -- Get the type of any node representing a subtype indication. This simply + -- skip over denoting names. + function Get_Type_Of_Subtype_Indication (Ind : Iir) return Iir; + + -- Get the type of an index_subtype_definition or of a discrete_range from + -- an index_constraint. + function Get_Index_Type (Index_Type : Iir) return Iir + renames Get_Type_Of_Subtype_Indication; + + -- Return the IDX-th index type for index subtype definition list or + -- index_constraint INDEXES. Return Null_Iir if IDX is out of dimension + -- bounds, so that this function can be used to iterator over indexes of + -- a type (or subtype). Note that IDX starts at 0. + function Get_Index_Type (Indexes : Iir_List; Idx : Natural) return Iir; + + -- Likewise but for array type or subtype ARRAY_TYPE. + function Get_Index_Type (Array_Type : Iir; Idx : Natural) return Iir; + + -- Return the type or subtype definition of the SUBTYP type mark. + function Get_Denoted_Type_Mark (Subtyp : Iir) return Iir; + + -- Return true iff L and R have the same profile. + -- L and R must be subprograms specification (or spec_body). + function Is_Same_Profile (L, R: Iir) return Boolean; + + -- From a block_specification, returns the block. + -- Roughly speaking, this get prefix of indexed and sliced name. + function Get_Block_From_Block_Specification (Block_Spec : Iir) + return Iir; + + -- Wrapper around Get_Entity_Name: return the entity declaration of the + -- entity name of DECL. + function Get_Entity (Decl : Iir) return Iir; + + -- Wrapper around get_Configuration_Name: return the configuration + -- declaration of ASPECT. + function Get_Configuration (Aspect : Iir) return Iir; + + -- Return the identifier of the entity for architecture ARCH. + function Get_Entity_Identifier_Of_Architecture (Arch : Iir) return Name_Id; + + -- Return True is component instantiation statement INST instantiate a + -- component. + function Is_Component_Instantiation + (Inst : Iir_Component_Instantiation_Statement) + return Boolean; + + -- Return True is component instantiation statement INST instantiate a + -- design entity. + function Is_Entity_Instantiation + (Inst : Iir_Component_Instantiation_Statement) + return Boolean; + + -- Return the bound type of a string type, ie the type of the (first) + -- dimension of a one-dimensional array type. + function Get_String_Type_Bound_Type (Sub_Type : Iir) return Iir; + + -- Return left or right limit according to the direction. + procedure Get_Low_High_Limit (Arange : Iir_Range_Expression; + Low, High : out Iir); + function Get_Low_Limit (Arange : Iir_Range_Expression) return Iir; + function Get_High_Limit (Arange : Iir_Range_Expression) return Iir; + + -- Return TRUE iff type/subtype definition A_TYPE is an undim array. + function Is_One_Dimensional_Array_Type (A_Type : Iir) return Boolean; + + -- Return TRUE iff unsemantized EXPR is a range attribute. + function Is_Range_Attribute_Name (Expr : Iir) return Boolean; + + -- Create an array subtype from array_type or array_subtype ARR_TYPE. + -- All fields of the returned node are filled, except the index_list. + -- The type_staticness is set with the type staticness of the element + -- subtype and therefore must be updated. + -- The type_declarator field is set to null_iir. + function Create_Array_Subtype (Arr_Type : Iir; Loc : Location_Type) + return Iir_Array_Subtype_Definition; + + -- Return TRUE iff SPEC is declared inside a protected type or a protected + -- body. + function Is_Subprogram_Method (Spec : Iir) return Boolean; + + -- Return the protected type for method SPEC. + function Get_Method_Type (Spec : Iir) return Iir; + + -- Create an error node for node ORIG, and set its type to ATYPE. + -- Set its staticness to locally. + function Create_Error_Expr (Orig : Iir; Atype : Iir) return Iir; + + -- Create an error node for node ORIG, which is supposed to be a type. + function Create_Error_Type (Orig : Iir) return Iir; + + -- Extract the entity from ASPECT. + -- Note: if ASPECT is a component declaration, returns ASPECT. + -- if ASPECT is open, return Null_Iir; + function Get_Entity_From_Entity_Aspect (Aspect : Iir) return Iir; + + -- Definitions from LRM08 4.7 Package declarations. + -- PKG must denote a package declaration. + function Is_Simple_Package (Pkg : Iir) return Boolean; + function Is_Uninstantiated_Package (Pkg : Iir) return Boolean; + function Is_Generic_Mapped_Package (Pkg : Iir) return Boolean; + + -- Return TRUE if the base name of NAME is a signal object. + function Is_Signal_Object (Name: Iir) return Boolean; + + -- Return True IFF kind of N is K1 or K2. + function Kind_In (N : Iir; K1, K2 : Iir_Kind) return Boolean; + pragma Inline (Kind_In); + + -- IIR wrapper around Get_HDL_Node/Set_HDL_Node. + function Get_HDL_Node (N : PSL_Node) return Iir; + procedure Set_HDL_Node (N : PSL_Node; Expr : Iir); +end Iirs_Utils; diff --git a/src/vhdl/iirs_walk.adb b/src/vhdl/iirs_walk.adb new file mode 100644 index 000000000..399832907 --- /dev/null +++ b/src/vhdl/iirs_walk.adb @@ -0,0 +1,115 @@ +-- Walk in iirs nodes. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package body Iirs_Walk is + function Walk_Chain (Chain : Iir; Cb : Walk_Cb) return Walk_Status + is + El : Iir; + Status : Walk_Status := Walk_Continue; + begin + El := Chain; + while El /= Null_Iir loop + Status := Cb.all (El); + exit when Status /= Walk_Continue; + El := Get_Chain (El); + end loop; + return Status; + end Walk_Chain; + + function Walk_Sequential_Stmt (Stmt : Iir; Cb : Walk_Cb) return Walk_Status; + + + function Walk_Sequential_Stmt_Chain (Chain : Iir; Cb : Walk_Cb) + return Walk_Status + is + El : Iir; + Status : Walk_Status := Walk_Continue; + begin + El := Chain; + while El /= Null_Iir loop + Status := Cb.all (El); + exit when Status /= Walk_Continue; + Status := Walk_Sequential_Stmt (El, Cb); + exit when Status /= Walk_Continue; + El := Get_Chain (El); + end loop; + return Status; + end Walk_Sequential_Stmt_Chain; + + function Walk_Sequential_Stmt (Stmt : Iir; Cb : Walk_Cb) return Walk_Status + is + Status : Walk_Status := Walk_Continue; + Chain : Iir; + begin + case Iir_Kinds_Sequential_Statement (Get_Kind (Stmt)) is + when Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Null_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement + | Iir_Kind_Wait_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_Variable_Assignment_Statement => + null; + when Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement => + Status := Walk_Sequential_Stmt_Chain + (Get_Sequential_Statement_Chain (Stmt), Cb); + when Iir_Kind_Case_Statement => + Chain := Get_Case_Statement_Alternative_Chain (Stmt); + while Chain /= Null_Iir loop + Status := Walk_Sequential_Stmt_Chain + (Get_Associated_Chain (Chain), Cb); + exit when Status /= Walk_Continue; + Chain := Get_Chain (Chain); + end loop; + when Iir_Kind_If_Statement => + Chain := Stmt; + while Chain /= Null_Iir loop + Status := Walk_Sequential_Stmt_Chain + (Get_Sequential_Statement_Chain (Chain), Cb); + exit when Status /= Walk_Continue; + Chain := Get_Else_Clause (Chain); + end loop; + end case; + return Status; + end Walk_Sequential_Stmt; + + function Walk_Assignment_Target (Target : Iir; Cb : Walk_Cb) + return Walk_Status + is + Chain : Iir; + Status : Walk_Status := Walk_Continue; + begin + case Get_Kind (Target) is + when Iir_Kind_Aggregate => + Chain := Get_Association_Choices_Chain (Target); + while Chain /= Null_Iir loop + Status := + Walk_Assignment_Target (Get_Associated_Expr (Chain), Cb); + exit when Status /= Walk_Continue; + Chain := Get_Chain (Chain); + end loop; + when others => + Status := Cb.all (Target); + end case; + return Status; + end Walk_Assignment_Target; +end Iirs_Walk; diff --git a/src/vhdl/iirs_walk.ads b/src/vhdl/iirs_walk.ads new file mode 100644 index 000000000..4c098f7d5 --- /dev/null +++ b/src/vhdl/iirs_walk.ads @@ -0,0 +1,45 @@ +-- Walk in iirs nodes. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Iirs; use Iirs; + +package Iirs_Walk is + type Walk_Status is + ( + -- Continue to walk. + Walk_Continue, + + -- Stop walking in the subtree, continue in the parent tree. + Walk_Up, + + -- Abort the walk. + Walk_Abort); + + type Walk_Cb is access function (El : Iir) return Walk_Status; + + -- Walk on all elements of CHAIN. + function Walk_Chain (Chain : Iir; Cb : Walk_Cb) return Walk_Status; + + + function Walk_Assignment_Target (Target : Iir; Cb : Walk_Cb) + return Walk_Status; + + -- Walk on all stmts and sub-stmts of CHAIN. + function Walk_Sequential_Stmt_Chain (Chain : Iir; Cb : Walk_Cb) + return Walk_Status; +end Iirs_Walk; diff --git a/src/vhdl/nodes.adb b/src/vhdl/nodes.adb new file mode 100644 index 000000000..2dc7736ce --- /dev/null +++ b/src/vhdl/nodes.adb @@ -0,0 +1,467 @@ +-- Internal node type and operations. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with GNAT.Table; + +package body Nodes is + -- Suppress the access check of the table base. This is really safe to + -- suppress this check because the table base cannot be null. + pragma Suppress (Access_Check); + + -- Suppress the index check on the table. + -- Could be done during non-debug, since this may catch errors (reading + -- Null_Node or Error_Node). + --pragma Suppress (Index_Check); + + -- Suppress discriminant checks on the table. Relatively safe, since + -- iirs do their own checks. + pragma Suppress (Discriminant_Check); + + package Nodet is new GNAT.Table + (Table_Component_Type => Node_Record, + Table_Index_Type => Node_Type, + Table_Low_Bound => 2, + Table_Initial => 1024, + Table_Increment => 100); + + function Get_Last_Node return Node_Type is + begin + return Nodet.Last; + end Get_Last_Node; + + Free_Chain : Node_Type := Null_Node; + + -- Just to have the default value. + pragma Warnings (Off); + Init_Short : Node_Record (Format_Short); + Init_Medium : Node_Record (Format_Medium); + Init_Fp : Node_Record (Format_Fp); + Init_Int : Node_Record (Format_Int); + pragma Warnings (On); + + function Create_Node (Format : Format_Type) return Node_Type + is + Res : Node_Type; + begin + if Format = Format_Medium then + -- Allocate a first node. + Nodet.Increment_Last; + Res := Nodet.Last; + -- Check alignment. + if Res mod 2 = 1 then + Set_Field1 (Res, Free_Chain); + Free_Chain := Res; + Nodet.Increment_Last; + Res := Nodet.Last; + end if; + -- Allocate the second node. + Nodet.Increment_Last; + Nodet.Table (Res) := Init_Medium; + Nodet.Table (Res + 1) := Init_Medium; + else + -- Check from free pool + if Free_Chain = Null_Node then + Nodet.Increment_Last; + Res := Nodet.Last; + else + Res := Free_Chain; + Free_Chain := Get_Field1 (Res); + end if; + case Format is + when Format_Short => + Nodet.Table (Res) := Init_Short; + when Format_Medium => + raise Program_Error; + when Format_Fp => + Nodet.Table (Res) := Init_Fp; + when Format_Int => + Nodet.Table (Res) := Init_Int; + end case; + end if; + return Res; + end Create_Node; + + procedure Free_Node (N : Node_Type) + is + begin + if N /= Null_Node then + Set_Nkind (N, 0); + Set_Field1 (N, Free_Chain); + Free_Chain := N; + if Nodet.Table (N).Format = Format_Medium then + Set_Field1 (N + 1, Free_Chain); + Free_Chain := N + 1; + end if; + end if; + end Free_Node; + + function Next_Node (N : Node_Type) return Node_Type is + begin + case Nodet.Table (N).Format is + when Format_Medium => + return N + 2; + when Format_Short + | Format_Int + | Format_Fp => + return N + 1; + end case; + end Next_Node; + + function Get_Nkind (N : Node_Type) return Kind_Type is + begin + return Nodet.Table (N).Kind; + end Get_Nkind; + + procedure Set_Nkind (N : Node_Type; Kind : Kind_Type) is + begin + Nodet.Table (N).Kind := Kind; + end Set_Nkind; + + + procedure Set_Location (N : Node_Type; Location: Location_Type) is + begin + Nodet.Table (N).Location := Location; + end Set_Location; + + function Get_Location (N: Node_Type) return Location_Type is + begin + return Nodet.Table (N).Location; + end Get_Location; + + + procedure Set_Field0 (N : Node_Type; V : Node_Type) is + begin + Nodet.Table (N).Field0 := V; + end Set_Field0; + + function Get_Field0 (N : Node_Type) return Node_Type is + begin + return Nodet.Table (N).Field0; + end Get_Field0; + + + function Get_Field1 (N : Node_Type) return Node_Type is + begin + return Nodet.Table (N).Field1; + end Get_Field1; + + procedure Set_Field1 (N : Node_Type; V : Node_Type) is + begin + Nodet.Table (N).Field1 := V; + end Set_Field1; + + function Get_Field2 (N : Node_Type) return Node_Type is + begin + return Nodet.Table (N).Field2; + end Get_Field2; + + procedure Set_Field2 (N : Node_Type; V : Node_Type) is + begin + Nodet.Table (N).Field2 := V; + end Set_Field2; + + function Get_Field3 (N : Node_Type) return Node_Type is + begin + return Nodet.Table (N).Field3; + end Get_Field3; + + procedure Set_Field3 (N : Node_Type; V : Node_Type) is + begin + Nodet.Table (N).Field3 := V; + end Set_Field3; + + function Get_Field4 (N : Node_Type) return Node_Type is + begin + return Nodet.Table (N).Field4; + end Get_Field4; + + procedure Set_Field4 (N : Node_Type; V : Node_Type) is + begin + Nodet.Table (N).Field4 := V; + end Set_Field4; + + function Get_Field5 (N : Node_Type) return Node_Type is + begin + return Nodet.Table (N).Field5; + end Get_Field5; + + procedure Set_Field5 (N : Node_Type; V : Node_Type) is + begin + Nodet.Table (N).Field5 := V; + end Set_Field5; + + function Get_Field6 (N: Node_Type) return Node_Type is + begin + return Node_Type (Nodet.Table (N + 1).Location); + end Get_Field6; + + procedure Set_Field6 (N: Node_Type; Val: Node_Type) is + begin + Nodet.Table (N + 1).Location := Location_Type (Val); + end Set_Field6; + + function Get_Field7 (N: Node_Type) return Node_Type is + begin + return Nodet.Table (N + 1).Field0; + end Get_Field7; + + procedure Set_Field7 (N: Node_Type; Val: Node_Type) is + begin + Nodet.Table (N + 1).Field0 := Val; + end Set_Field7; + + function Get_Field8 (N: Node_Type) return Node_Type is + begin + return Nodet.Table (N + 1).Field1; + end Get_Field8; + + procedure Set_Field8 (N: Node_Type; Val: Node_Type) is + begin + Nodet.Table (N + 1).Field1 := Val; + end Set_Field8; + + function Get_Field9 (N: Node_Type) return Node_Type is + begin + return Nodet.Table (N + 1).Field2; + end Get_Field9; + + procedure Set_Field9 (N: Node_Type; Val: Node_Type) is + begin + Nodet.Table (N + 1).Field2 := Val; + end Set_Field9; + + function Get_Field10 (N: Node_Type) return Node_Type is + begin + return Nodet.Table (N + 1).Field3; + end Get_Field10; + + procedure Set_Field10 (N: Node_Type; Val: Node_Type) is + begin + Nodet.Table (N + 1).Field3 := Val; + end Set_Field10; + + function Get_Field11 (N: Node_Type) return Node_Type is + begin + return Nodet.Table (N + 1).Field4; + end Get_Field11; + + procedure Set_Field11 (N: Node_Type; Val: Node_Type) is + begin + Nodet.Table (N + 1).Field4 := Val; + end Set_Field11; + + function Get_Field12 (N: Node_Type) return Node_Type is + begin + return Nodet.Table (N + 1).Field5; + end Get_Field12; + + procedure Set_Field12 (N: Node_Type; Val: Node_Type) is + begin + Nodet.Table (N + 1).Field5 := Val; + end Set_Field12; + + + function Get_Flag1 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag1; + end Get_Flag1; + + procedure Set_Flag1 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag1 := V; + end Set_Flag1; + + function Get_Flag2 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag2; + end Get_Flag2; + + procedure Set_Flag2 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag2 := V; + end Set_Flag2; + + function Get_Flag3 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag3; + end Get_Flag3; + + procedure Set_Flag3 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag3 := V; + end Set_Flag3; + + function Get_Flag4 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag4; + end Get_Flag4; + + procedure Set_Flag4 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag4 := V; + end Set_Flag4; + + function Get_Flag5 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag5; + end Get_Flag5; + + procedure Set_Flag5 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag5 := V; + end Set_Flag5; + + function Get_Flag6 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag6; + end Get_Flag6; + + procedure Set_Flag6 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag6 := V; + end Set_Flag6; + + function Get_Flag7 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag7; + end Get_Flag7; + + procedure Set_Flag7 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag7 := V; + end Set_Flag7; + + function Get_Flag8 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag8; + end Get_Flag8; + + procedure Set_Flag8 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag8 := V; + end Set_Flag8; + + function Get_Flag9 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag9; + end Get_Flag9; + + procedure Set_Flag9 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag9 := V; + end Set_Flag9; + + function Get_Flag10 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag10; + end Get_Flag10; + + procedure Set_Flag10 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag10 := V; + end Set_Flag10; + + + function Get_State1 (N : Node_Type) return Bit2_Type is + begin + return Nodet.Table (N).State1; + end Get_State1; + + procedure Set_State1 (N : Node_Type; V : Bit2_Type) is + begin + Nodet.Table (N).State1 := V; + end Set_State1; + + function Get_State2 (N : Node_Type) return Bit2_Type is + begin + return Nodet.Table (N).State2; + end Get_State2; + + procedure Set_State2 (N : Node_Type; V : Bit2_Type) is + begin + Nodet.Table (N).State2 := V; + end Set_State2; + + function Get_State3 (N : Node_Type) return Bit2_Type is + begin + return Nodet.Table (N + 1).State1; + end Get_State3; + + procedure Set_State3 (N : Node_Type; V : Bit2_Type) is + begin + Nodet.Table (N + 1).State1 := V; + end Set_State3; + + function Get_State4 (N : Node_Type) return Bit2_Type is + begin + return Nodet.Table (N + 1).State2; + end Get_State4; + + procedure Set_State4 (N : Node_Type; V : Bit2_Type) is + begin + Nodet.Table (N + 1).State2 := V; + end Set_State4; + + + function Get_Odigit1 (N : Node_Type) return Bit3_Type is + begin + return Nodet.Table (N).Odigit1; + end Get_Odigit1; + + procedure Set_Odigit1 (N : Node_Type; V : Bit3_Type) is + begin + Nodet.Table (N).Odigit1 := V; + end Set_Odigit1; + + function Get_Odigit2 (N : Node_Type) return Bit3_Type is + begin + return Nodet.Table (N + 1).Odigit1; + end Get_Odigit2; + + procedure Set_Odigit2 (N : Node_Type; V : Bit3_Type) is + begin + Nodet.Table (N + 1).Odigit1 := V; + end Set_Odigit2; + + + function Get_Fp64 (N : Node_Type) return Iir_Fp64 is + begin + return Nodet.Table (N).Fp64; + end Get_Fp64; + + procedure Set_Fp64 (N : Node_Type; V : Iir_Fp64) is + begin + Nodet.Table (N).Fp64 := V; + end Set_Fp64; + + + function Get_Int64 (N : Node_Type) return Iir_Int64 is + begin + return Nodet.Table (N).Int64; + end Get_Int64; + + procedure Set_Int64 (N : Node_Type; V : Iir_Int64) is + begin + Nodet.Table (N).Int64 := V; + end Set_Int64; + + procedure Initialize is + begin + Nodet.Free; + Nodet.Init; + end Initialize; +end Nodes; diff --git a/src/vhdl/nodes.ads b/src/vhdl/nodes.ads new file mode 100644 index 000000000..adf6a5ee8 --- /dev/null +++ b/src/vhdl/nodes.ads @@ -0,0 +1,335 @@ +-- Internal node type and operations. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; + +package Nodes is + type Node_Type is new Int32; + for Node_Type'Size use 32; + + Null_Node : constant Node_Type := 0; + Error_Node : constant Node_Type := 1; + + -- A simple type that needs only 2 bits. + type Bit2_Type is range 0 .. 2 ** 2 - 1; + type Bit3_Type is range 0 .. 2 ** 3 - 1; + + type Kind_Type is range 0 .. 255; + + -- Format of a node. + type Format_Type is + ( + Format_Short, + Format_Medium, + Format_Fp, + Format_Int + ); + + -- Future layout: (rem) + -- Format: 0 bits 32 + -- Nkind: 16 bits 16 + -- Flags: 8*1 bits 8 + -- State: 2*2 bits 4 + -- Odigit is to be removed. + + -- Future layout (2):(rem) + -- Format: 2 bits 30 + -- Nkind: 8 bits 22 (vhdl: 216 nodes) + -- Flags: 8*1 bits 14 + -- State: 2*2 bits 10 + -- Lang: 2 bits 8 + -- Odigit: 1*3 bits 5 + + -- Common fields are: + -- Flag1 : Boolean + -- Flag2 : Boolean + -- Flag3 : Boolean + -- Flag4 : Boolean + -- Flag5 : Boolean + -- Flag6 : Boolean + -- Flag7 : Boolean + -- Flag8 : Boolean + -- Flag9 : Boolean + -- Flag10 : Boolean + -- Nkind : Kind_Type + -- State1 : Bit2_Type + -- State2 : Bit2_Type + -- Location : Location_Type + -- Field0 : Iir + -- Field1 : Iir + -- Field2 : Iir + -- Field3 : Iir + + -- Fields of Format_Fp: + -- Fp64 : Iir_Fp64 + + -- Fields of Format_Int: + -- Int64 : Iir_Int64 + + -- Fields of Format_Short: + -- Field4 : Iir + -- Field5 : Iir + + -- Fields of Format_Medium: + -- Odigit1 : Bit3_Type + -- Odigit2 : Bit3_Type (odigit1) + -- State3 : Bit2_Type + -- State4 : Bit2_Type + -- Field4 : Iir + -- Field5 : Iir + -- Field6 : Iir (location) + -- Field7 : Iir (field0) + -- Field8 : Iir (field1) + -- Field9 : Iir (field2) + -- Field10 : Iir (field3) + -- Field11 : Iir (field4) + -- Field12 : Iir (field5) + + function Create_Node (Format : Format_Type) return Node_Type; + procedure Free_Node (N : Node_Type); + function Next_Node (N : Node_Type) return Node_Type; + + function Get_Nkind (N : Node_Type) return Kind_Type; + pragma Inline (Get_Nkind); + procedure Set_Nkind (N : Node_Type; Kind : Kind_Type); + pragma Inline (Set_Nkind); + + function Get_Location (N: Node_Type) return Location_Type; + pragma Inline (Get_Location); + procedure Set_Location (N : Node_Type; Location: Location_Type); + pragma Inline (Set_Location); + + function Get_Field0 (N : Node_Type) return Node_Type; + pragma Inline (Get_Field0); + procedure Set_Field0 (N : Node_Type; V : Node_Type); + pragma Inline (Set_Field0); + + function Get_Field1 (N : Node_Type) return Node_Type; + pragma Inline (Get_Field1); + procedure Set_Field1 (N : Node_Type; V : Node_Type); + pragma Inline (Set_Field1); + + function Get_Field2 (N : Node_Type) return Node_Type; + pragma Inline (Get_Field2); + procedure Set_Field2 (N : Node_Type; V : Node_Type); + pragma Inline (Set_Field2); + + function Get_Field3 (N : Node_Type) return Node_Type; + pragma Inline (Get_Field3); + procedure Set_Field3 (N : Node_Type; V : Node_Type); + pragma Inline (Set_Field3); + + function Get_Field4 (N : Node_Type) return Node_Type; + pragma Inline (Get_Field4); + procedure Set_Field4 (N : Node_Type; V : Node_Type); + pragma Inline (Set_Field4); + + + function Get_Field5 (N : Node_Type) return Node_Type; + pragma Inline (Get_Field5); + procedure Set_Field5 (N : Node_Type; V : Node_Type); + pragma Inline (Set_Field5); + + function Get_Field6 (N: Node_Type) return Node_Type; + pragma Inline (Get_Field6); + procedure Set_Field6 (N: Node_Type; Val: Node_Type); + pragma Inline (Set_Field6); + + function Get_Field7 (N: Node_Type) return Node_Type; + pragma Inline (Get_Field7); + procedure Set_Field7 (N: Node_Type; Val: Node_Type); + pragma Inline (Set_Field7); + + function Get_Field8 (N: Node_Type) return Node_Type; + pragma Inline (Get_Field8); + procedure Set_Field8 (N: Node_Type; Val: Node_Type); + pragma Inline (Set_Field8); + + function Get_Field9 (N: Node_Type) return Node_Type; + pragma Inline (Get_Field9); + procedure Set_Field9 (N: Node_Type; Val: Node_Type); + pragma Inline (Set_Field9); + + function Get_Field10 (N: Node_Type) return Node_Type; + pragma Inline (Get_Field10); + procedure Set_Field10 (N: Node_Type; Val: Node_Type); + pragma Inline (Set_Field10); + + function Get_Field11 (N: Node_Type) return Node_Type; + pragma Inline (Get_Field11); + procedure Set_Field11 (N: Node_Type; Val: Node_Type); + pragma Inline (Set_Field11); + + function Get_Field12 (N: Node_Type) return Node_Type; + pragma Inline (Get_Field12); + procedure Set_Field12 (N: Node_Type; Val: Node_Type); + pragma Inline (Set_Field12); + + + function Get_Flag1 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag1); + procedure Set_Flag1 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag1); + + function Get_Flag2 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag2); + procedure Set_Flag2 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag2); + + function Get_Flag3 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag3); + procedure Set_Flag3 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag3); + + function Get_Flag4 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag4); + procedure Set_Flag4 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag4); + + function Get_Flag5 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag5); + procedure Set_Flag5 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag5); + + function Get_Flag6 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag6); + procedure Set_Flag6 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag6); + + function Get_Flag7 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag7); + procedure Set_Flag7 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag7); + + function Get_Flag8 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag8); + procedure Set_Flag8 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag8); + + function Get_Flag9 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag9); + procedure Set_Flag9 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag9); + + function Get_Flag10 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag10); + procedure Set_Flag10 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag10); + + + function Get_State1 (N : Node_Type) return Bit2_Type; + pragma Inline (Get_State1); + procedure Set_State1 (N : Node_Type; V : Bit2_Type); + pragma Inline (Set_State1); + + function Get_State2 (N : Node_Type) return Bit2_Type; + pragma Inline (Get_State2); + procedure Set_State2 (N : Node_Type; V : Bit2_Type); + pragma Inline (Set_State2); + + function Get_State3 (N : Node_Type) return Bit2_Type; + pragma Inline (Get_State3); + procedure Set_State3 (N : Node_Type; V : Bit2_Type); + pragma Inline (Set_State3); + + function Get_State4 (N : Node_Type) return Bit2_Type; + pragma Inline (Get_State4); + procedure Set_State4 (N : Node_Type; V : Bit2_Type); + pragma Inline (Set_State4); + + + function Get_Odigit1 (N : Node_Type) return Bit3_Type; + pragma Inline (Get_Odigit1); + procedure Set_Odigit1 (N : Node_Type; V : Bit3_Type); + pragma Inline (Set_Odigit1); + + function Get_Odigit2 (N : Node_Type) return Bit3_Type; + pragma Inline (Get_Odigit2); + procedure Set_Odigit2 (N : Node_Type; V : Bit3_Type); + pragma Inline (Set_Odigit2); + + + function Get_Fp64 (N : Node_Type) return Iir_Fp64; + pragma Inline (Get_Fp64); + procedure Set_Fp64 (N : Node_Type; V : Iir_Fp64); + pragma Inline (Set_Fp64); + + function Get_Int64 (N : Node_Type) return Iir_Int64; + pragma Inline (Get_Int64); + procedure Set_Int64 (N : Node_Type; V : Iir_Int64); + pragma Inline (Set_Int64); + + -- Get the last node allocated. + function Get_Last_Node return Node_Type; + pragma Inline (Get_Last_Node); + + -- Free all and reinit. + procedure Initialize; +private + type Node_Record (Format : Format_Type := Format_Short) is record + Flag1 : Boolean := False; + Flag2 : Boolean := False; + Flag3 : Boolean := False; + Flag4 : Boolean := False; + Flag5 : Boolean := False; + Flag6 : Boolean := False; + + -- Kind field use 8 bits. + -- So, on 32 bits systems, there are 24 bits left. + -- + 8 (8 * 1) + -- + 10 (5 * 2) + -- + 6 (2 * 3) + -- = 24 + + Kind : Kind_Type; + + State1 : Bit2_Type := 0; + State2 : Bit2_Type := 0; + Flag7 : Boolean := False; + Flag8 : Boolean := False; + Flag9 : Boolean := False; + Flag10 : Boolean := False; + + Flag11 : Boolean := False; + Flag12 : Boolean := False; + Odigit1 : Bit3_Type := 0; + Unused_Odigit2 : Bit3_Type := 0; + + -- Location. + Location: Location_Type := Location_Nil; + + Field0 : Node_Type := Null_Node; + Field1: Node_Type := Null_Node; + Field2: Node_Type := Null_Node; + Field3: Node_Type := Null_Node; + + case Format is + when Format_Short + | Format_Medium => + Field4: Node_Type := Null_Node; + Field5: Node_Type := Null_Node; + when Format_Fp => + Fp64 : Iir_Fp64; + when Format_Int => + Int64 : Iir_Int64; + end case; + end record; + + pragma Pack (Node_Record); + for Node_Record'Size use 8*32; + for Node_Record'Alignment use 4; +end Nodes; diff --git a/src/vhdl/nodes_gc.adb b/src/vhdl/nodes_gc.adb new file mode 100644 index 000000000..38966f27c --- /dev/null +++ b/src/vhdl/nodes_gc.adb @@ -0,0 +1,206 @@ +-- Node garbage collector (for debugging). +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Text_IO; +with Types; use Types; +with Nodes; +with Nodes_Meta; +with Iirs; use Iirs; +with Libraries; +with Disp_Tree; +with Std_Package; + +package body Nodes_GC is + + type Marker_Array is array (Iir range <>) of Boolean; + type Marker_Array_Acc is access Marker_Array; + + Markers : Marker_Array_Acc; + + procedure Mark_Iir (N : Iir); + + procedure Mark_Iir_List (N : Iir_List) + is + El : Iir; + begin + case N is + when Null_Iir_List + | Iir_List_All + | Iir_List_Others => + null; + when others => + for I in Natural loop + El := Get_Nth_Element (N, I); + exit when El = Null_Iir; + Mark_Iir (El); + end loop; + end case; + end Mark_Iir_List; + + procedure Mark_PSL_Node (N : PSL_Node) is + begin + null; + end Mark_PSL_Node; + + procedure Mark_PSL_NFA (N : PSL_NFA) is + begin + null; + end Mark_PSL_NFA; + + procedure Report_Already_Marked (N : Iir) + is + use Ada.Text_IO; + begin + Disp_Tree.Disp_Tree (N, True); + return; + end Report_Already_Marked; + + procedure Already_Marked (N : Iir) is + begin + -- An unused node mustn't be referenced. + if Get_Kind (N) = Iir_Kind_Unused then + raise Internal_Error; + end if; + + if not Flag_Disp_Multiref then + return; + end if; + + case Get_Kind (N) is + when Iir_Kind_Interface_Constant_Declaration => + if Get_Identifier (N) = Null_Identifier then + -- Anonymous interfaces are shared by predefined functions. + return; + end if; + when Iir_Kind_Enumeration_Literal => + if Get_Enum_Pos (N) = 0 + or else N = Get_Right_Limit (Get_Range_Constraint + (Get_Type (N))) + then + return; + end if; + when others => + null; + end case; + + Report_Already_Marked (N); + end Already_Marked; + + procedure Mark_Chain (Head : Iir) + is + El : Iir; + begin + El := Head; + while El /= Null_Iir loop + Mark_Iir (El); + El := Get_Chain (El); + end loop; + end Mark_Chain; + + procedure Report_Unreferenced_Node (N : Iir) is + begin + Disp_Tree.Disp_Tree (N, True); + end Report_Unreferenced_Node; + + procedure Mark_Iir (N : Iir) is + begin + if N = Null_Iir then + return; + elsif Markers (N) then + Already_Marked (N); + return; + else + Markers (N) := True; + end if; + + declare + use Nodes_Meta; + Fields : constant Fields_Array := Get_Fields (Get_Kind (N)); + F : Fields_Enum; + begin + for I in Fields'Range loop + F := Fields (I); + case Get_Field_Attribute (F) is + when Attr_Ref + | Attr_Chain_Next => + null; + when Attr_Maybe_Ref => + if not Get_Is_Ref (N) then + Mark_Iir (Get_Iir (N, F)); + end if; + when Attr_Chain => + Mark_Chain (Get_Iir (N, F)); + when Attr_None => + case Get_Field_Type (F) is + when Type_Iir => + Mark_Iir (Get_Iir (N, F)); + when Type_Iir_List => + Mark_Iir_List (Get_Iir_List (N, F)); + when Type_PSL_Node => + Mark_PSL_Node (Get_PSL_Node (N, F)); + when Type_PSL_NFA => + Mark_PSL_NFA (Get_PSL_NFA (N, F)); + when others => + null; + end case; + when Attr_Of_Ref => + raise Internal_Error; + end case; + end loop; + end; + end Mark_Iir; + + procedure Report_Unreferenced + is + use Ada.Text_IO; + use Std_Package; + El : Iir; + Nbr_Unreferenced : Natural; + begin + Markers := new Marker_Array'(Null_Iir .. Iirs.Get_Last_Node => False); + + if Flag_Disp_Multiref then + Put_Line ("** nodes already marked:"); + end if; + + Mark_Chain (Libraries.Get_Libraries_Chain); + Mark_Chain (Libraries.Obsoleted_Design_Units); + Mark_Iir (Convertible_Integer_Type_Declaration); + Mark_Iir (Convertible_Integer_Subtype_Declaration); + Mark_Iir (Convertible_Real_Type_Declaration); + Mark_Iir (Universal_Integer_One); + Mark_Iir (Error_Mark); + + El := Error_Mark; + Nbr_Unreferenced := 0; + while El in Markers'Range loop + if not Markers (El) and then Get_Kind (El) /= Iir_Kind_Unused then + if Nbr_Unreferenced = 0 then + Put_Line ("** unreferenced nodes:"); + end if; + Nbr_Unreferenced := Nbr_Unreferenced + 1; + Report_Unreferenced_Node (El); + end if; + El := Iir (Nodes.Next_Node (Nodes.Node_Type (El))); + end loop; + + if Nbr_Unreferenced /= 0 then + raise Internal_Error; + end if; + end Report_Unreferenced; +end Nodes_GC; diff --git a/src/vhdl/nodes_gc.adb.in b/src/vhdl/nodes_gc.adb.in new file mode 100644 index 000000000..7c4303bc5 --- /dev/null +++ b/src/vhdl/nodes_gc.adb.in @@ -0,0 +1,159 @@ +-- Node garbage collector (for debugging). +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Text_IO; +with Types; use Types; +with Nodes; +with Iirs; use Iirs; +with Libraries; +with Disp_Tree; +with Std_Package; + +package body Nodes_GC is + + type Marker_Array is array (Iir range <>) of Boolean; + type Marker_Array_Acc is access Marker_Array; + + Markers : Marker_Array_Acc; + + procedure Mark_Iir (N : Iir); + + procedure Mark_Iir_List (N : Iir_List) + is + El : Iir; + begin + case N is + when Null_Iir_List + | Iir_List_All + | Iir_List_Others => + null; + when others => + for I in Natural loop + El := Get_Nth_Element (N, I); + exit when El = Null_Iir; + Mark_Iir (El); + end loop; + end case; + end Mark_Iir_List; + + procedure Mark_PSL_Node (N : PSL_Node) is + begin + null; + end Mark_PSL_Node; + + procedure Mark_PSL_NFA (N : PSL_NFA) is + begin + null; + end Mark_PSL_NFA; + + procedure Report_Already_Marked (N : Iir) + is + use Ada.Text_IO; + begin + Disp_Tree.Disp_Tree (N, True); + return; + end Report_Already_Marked; + + procedure Already_Marked (N : Iir) is + begin + -- An unused node mustn't be referenced. + if Get_Kind (N) = Iir_Kind_Unused then + raise Internal_Error; + end if; + + if not Flag_Disp_Multiref then + return; + end if; + + case Get_Kind (N) is + when Iir_Kind_Constant_Interface_Declaration => + if Get_Identifier (N) = Null_Identifier then + -- Anonymous interfaces are shared by predefined functions. + return; + end if; + when Iir_Kind_Enumeration_Literal => + if Get_Enum_Pos (N) = 0 + or else N = Get_Right_Limit (Get_Range_Constraint + (Get_Type (N))) + then + return; + end if; + when others => + null; + end case; + + Report_Already_Marked (N); + end Already_Marked; + + procedure Mark_Chain (Head : Iir) + is + El : Iir; + begin + El := Head; + while El /= Null_Iir loop + Mark_Iir (El); + El := Get_Chain (El); + end loop; + end Mark_Chain; + + procedure Report_Unreferenced_Node (N : Iir) is + begin + Disp_Tree.Disp_Tree (N, True); + end Report_Unreferenced_Node; + + -- Subprograms + + procedure Report_Unreferenced + is + use Ada.Text_IO; + use Std_Package; + El : Iir; + Nbr_Unreferenced : Natural; + begin + Markers := new Marker_Array'(Null_Iir .. Iirs.Get_Last_Node => False); + + if Flag_Disp_Multiref then + Put_Line ("** nodes already marked:"); + end if; + + Mark_Chain (Libraries.Get_Libraries_Chain); + Mark_Chain (Libraries.Obsoleted_Design_Units); + Mark_Iir (Convertible_Integer_Type_Declaration); + Mark_Iir (Convertible_Integer_Subtype_Declaration); + Mark_Iir (Convertible_Real_Type_Declaration); + Mark_Iir (Universal_Integer_One); + Mark_Iir (Error_Mark); + + El := Error_Mark; + Nbr_Unreferenced := 0; + while El in Markers'Range loop + if not Markers (El) and then Get_Kind (El) /= Iir_Kind_Unused then + if Nbr_Unreferenced = 0 then + Put_Line ("** unreferenced nodes:"); + end if; + Nbr_Unreferenced := Nbr_Unreferenced + 1; + Report_Unreferenced_Node (El); + end if; + El := Iir (Nodes.Next_Node (Nodes.Node_Type (El))); + end loop; + + if Nbr_Unreferenced /= 0 then + raise Internal_Error; + end if; + end Report_Unreferenced; +end Nodes_GC; diff --git a/src/vhdl/nodes_gc.ads b/src/vhdl/nodes_gc.ads new file mode 100644 index 000000000..ef8e647c3 --- /dev/null +++ b/src/vhdl/nodes_gc.ads @@ -0,0 +1,24 @@ +-- Node garbage collector (for debugging). +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package Nodes_GC is + Flag_Disp_Multiref : Boolean := False; + + procedure Report_Unreferenced; + -- Display nodes that aren't referenced. +end Nodes_GC; diff --git a/src/vhdl/nodes_meta.adb b/src/vhdl/nodes_meta.adb new file mode 100644 index 000000000..3e038f549 --- /dev/null +++ b/src/vhdl/nodes_meta.adb @@ -0,0 +1,9409 @@ +-- Meta description of nodes. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package body Nodes_Meta is + Fields_Type : constant array (Fields_Enum) of Types_Enum := + ( + Field_First_Design_Unit => Type_Iir, + Field_Last_Design_Unit => Type_Iir, + Field_Library_Declaration => Type_Iir, + Field_File_Time_Stamp => Type_Time_Stamp_Id, + Field_Analysis_Time_Stamp => Type_Time_Stamp_Id, + Field_Library => Type_Iir, + Field_File_Dependence_List => Type_Iir_List, + Field_Design_File_Filename => Type_Name_Id, + Field_Design_File_Directory => Type_Name_Id, + Field_Design_File => Type_Iir, + Field_Design_File_Chain => Type_Iir, + Field_Library_Directory => Type_Name_Id, + Field_Date => Type_Date_Type, + Field_Context_Items => Type_Iir, + Field_Dependence_List => Type_Iir_List, + Field_Analysis_Checks_List => Type_Iir_List, + Field_Date_State => Type_Date_State_Type, + Field_Guarded_Target_State => Type_Tri_State_Type, + Field_Library_Unit => Type_Iir, + Field_Hash_Chain => Type_Iir, + Field_Design_Unit_Source_Pos => Type_Source_Ptr, + Field_Design_Unit_Source_Line => Type_Int32, + Field_Design_Unit_Source_Col => Type_Int32, + Field_Value => Type_Iir_Int64, + Field_Enum_Pos => Type_Iir_Int32, + Field_Physical_Literal => Type_Iir, + Field_Physical_Unit_Value => Type_Iir, + Field_Fp_Value => Type_Iir_Fp64, + Field_Enumeration_Decl => Type_Iir, + Field_Simple_Aggregate_List => Type_Iir_List, + Field_Bit_String_Base => Type_Base_Type, + Field_Bit_String_0 => Type_Iir, + Field_Bit_String_1 => Type_Iir, + Field_Literal_Origin => Type_Iir, + Field_Range_Origin => Type_Iir, + Field_Literal_Subtype => Type_Iir, + Field_Entity_Class => Type_Token_Type, + Field_Entity_Name_List => Type_Iir_List, + Field_Attribute_Designator => Type_Iir, + Field_Attribute_Specification_Chain => Type_Iir, + Field_Attribute_Specification => Type_Iir, + Field_Signal_List => Type_Iir_List, + Field_Designated_Entity => Type_Iir, + Field_Formal => Type_Iir, + Field_Actual => Type_Iir, + Field_In_Conversion => Type_Iir, + Field_Out_Conversion => Type_Iir, + Field_Whole_Association_Flag => Type_Boolean, + Field_Collapse_Signal_Flag => Type_Boolean, + Field_Artificial_Flag => Type_Boolean, + Field_Open_Flag => Type_Boolean, + Field_After_Drivers_Flag => Type_Boolean, + Field_We_Value => Type_Iir, + Field_Time => Type_Iir, + Field_Associated_Expr => Type_Iir, + Field_Associated_Chain => Type_Iir, + Field_Choice_Name => Type_Iir, + Field_Choice_Expression => Type_Iir, + Field_Choice_Range => Type_Iir, + Field_Same_Alternative_Flag => Type_Boolean, + Field_Architecture => Type_Iir, + Field_Block_Specification => Type_Iir, + Field_Prev_Block_Configuration => Type_Iir, + Field_Configuration_Item_Chain => Type_Iir, + Field_Attribute_Value_Chain => Type_Iir, + Field_Spec_Chain => Type_Iir, + Field_Attribute_Value_Spec_Chain => Type_Iir, + Field_Entity_Name => Type_Iir, + Field_Package => Type_Iir, + Field_Package_Body => Type_Iir, + Field_Need_Body => Type_Boolean, + Field_Block_Configuration => Type_Iir, + Field_Concurrent_Statement_Chain => Type_Iir, + Field_Chain => Type_Iir, + Field_Port_Chain => Type_Iir, + Field_Generic_Chain => Type_Iir, + Field_Type => Type_Iir, + Field_Subtype_Indication => Type_Iir, + Field_Discrete_Range => Type_Iir, + Field_Type_Definition => Type_Iir, + Field_Subtype_Definition => Type_Iir, + Field_Nature => Type_Iir, + Field_Mode => Type_Iir_Mode, + Field_Signal_Kind => Type_Iir_Signal_Kind, + Field_Base_Name => Type_Iir, + Field_Interface_Declaration_Chain => Type_Iir, + Field_Subprogram_Specification => Type_Iir, + Field_Sequential_Statement_Chain => Type_Iir, + Field_Subprogram_Body => Type_Iir, + Field_Overload_Number => Type_Iir_Int32, + Field_Subprogram_Depth => Type_Iir_Int32, + Field_Subprogram_Hash => Type_Iir_Int32, + Field_Impure_Depth => Type_Iir_Int32, + Field_Return_Type => Type_Iir, + Field_Implicit_Definition => Type_Iir_Predefined_Functions, + Field_Type_Reference => Type_Iir, + Field_Default_Value => Type_Iir, + Field_Deferred_Declaration => Type_Iir, + Field_Deferred_Declaration_Flag => Type_Boolean, + Field_Shared_Flag => Type_Boolean, + Field_Design_Unit => Type_Iir, + Field_Block_Statement => Type_Iir, + Field_Signal_Driver => Type_Iir, + Field_Declaration_Chain => Type_Iir, + Field_File_Logical_Name => Type_Iir, + Field_File_Open_Kind => Type_Iir, + Field_Element_Position => Type_Iir_Index32, + Field_Element_Declaration => Type_Iir, + Field_Selected_Element => Type_Iir, + Field_Use_Clause_Chain => Type_Iir, + Field_Selected_Name => Type_Iir, + Field_Type_Declarator => Type_Iir, + Field_Enumeration_Literal_List => Type_Iir_List, + Field_Entity_Class_Entry_Chain => Type_Iir, + Field_Group_Constituent_List => Type_Iir_List, + Field_Unit_Chain => Type_Iir, + Field_Primary_Unit => Type_Iir, + Field_Identifier => Type_Name_Id, + Field_Label => Type_Name_Id, + Field_Visible_Flag => Type_Boolean, + Field_Range_Constraint => Type_Iir, + Field_Direction => Type_Iir_Direction, + Field_Left_Limit => Type_Iir, + Field_Right_Limit => Type_Iir, + Field_Base_Type => Type_Iir, + Field_Resolution_Indication => Type_Iir, + Field_Record_Element_Resolution_Chain => Type_Iir, + Field_Tolerance => Type_Iir, + Field_Plus_Terminal => Type_Iir, + Field_Minus_Terminal => Type_Iir, + Field_Simultaneous_Left => Type_Iir, + Field_Simultaneous_Right => Type_Iir, + Field_Text_File_Flag => Type_Boolean, + Field_Only_Characters_Flag => Type_Boolean, + Field_Type_Staticness => Type_Iir_Staticness, + Field_Constraint_State => Type_Iir_Constraint, + Field_Index_Subtype_List => Type_Iir_List, + Field_Index_Subtype_Definition_List => Type_Iir_List, + Field_Element_Subtype_Indication => Type_Iir, + Field_Element_Subtype => Type_Iir, + Field_Index_Constraint_List => Type_Iir_List, + Field_Array_Element_Constraint => Type_Iir, + Field_Elements_Declaration_List => Type_Iir_List, + Field_Designated_Type => Type_Iir, + Field_Designated_Subtype_Indication => Type_Iir, + Field_Index_List => Type_Iir_List, + Field_Reference => Type_Iir, + Field_Nature_Declarator => Type_Iir, + Field_Across_Type => Type_Iir, + Field_Through_Type => Type_Iir, + Field_Target => Type_Iir, + Field_Waveform_Chain => Type_Iir, + Field_Guard => Type_Iir, + Field_Delay_Mechanism => Type_Iir_Delay_Mechanism, + Field_Reject_Time_Expression => Type_Iir, + Field_Sensitivity_List => Type_Iir_List, + Field_Process_Origin => Type_Iir, + Field_Condition_Clause => Type_Iir, + Field_Timeout_Clause => Type_Iir, + Field_Postponed_Flag => Type_Boolean, + Field_Callees_List => Type_Iir_List, + Field_Passive_Flag => Type_Boolean, + Field_Resolution_Function_Flag => Type_Boolean, + Field_Wait_State => Type_Tri_State_Type, + Field_All_Sensitized_State => Type_Iir_All_Sensitized, + Field_Seen_Flag => Type_Boolean, + Field_Pure_Flag => Type_Boolean, + Field_Foreign_Flag => Type_Boolean, + Field_Resolved_Flag => Type_Boolean, + Field_Signal_Type_Flag => Type_Boolean, + Field_Has_Signal_Flag => Type_Boolean, + Field_Purity_State => Type_Iir_Pure_State, + Field_Elab_Flag => Type_Boolean, + Field_Index_Constraint_Flag => Type_Boolean, + Field_Assertion_Condition => Type_Iir, + Field_Report_Expression => Type_Iir, + Field_Severity_Expression => Type_Iir, + Field_Instantiated_Unit => Type_Iir, + Field_Generic_Map_Aspect_Chain => Type_Iir, + Field_Port_Map_Aspect_Chain => Type_Iir, + Field_Configuration_Name => Type_Iir, + Field_Component_Configuration => Type_Iir, + Field_Configuration_Specification => Type_Iir, + Field_Default_Binding_Indication => Type_Iir, + Field_Default_Configuration_Declaration => Type_Iir, + Field_Expression => Type_Iir, + Field_Allocator_Designated_Type => Type_Iir, + Field_Selected_Waveform_Chain => Type_Iir, + Field_Conditional_Waveform_Chain => Type_Iir, + Field_Guard_Expression => Type_Iir, + Field_Guard_Decl => Type_Iir, + Field_Guard_Sensitivity_List => Type_Iir_List, + Field_Block_Block_Configuration => Type_Iir, + Field_Package_Header => Type_Iir, + Field_Block_Header => Type_Iir, + Field_Uninstantiated_Package_Name => Type_Iir, + Field_Generate_Block_Configuration => Type_Iir, + Field_Generation_Scheme => Type_Iir, + Field_Condition => Type_Iir, + Field_Else_Clause => Type_Iir, + Field_Parameter_Specification => Type_Iir, + Field_Parent => Type_Iir, + Field_Loop_Label => Type_Iir, + Field_Component_Name => Type_Iir, + Field_Instantiation_List => Type_Iir_List, + Field_Entity_Aspect => Type_Iir, + Field_Default_Entity_Aspect => Type_Iir, + Field_Default_Generic_Map_Aspect_Chain => Type_Iir, + Field_Default_Port_Map_Aspect_Chain => Type_Iir, + Field_Binding_Indication => Type_Iir, + Field_Named_Entity => Type_Iir, + Field_Alias_Declaration => Type_Iir, + Field_Expr_Staticness => Type_Iir_Staticness, + Field_Error_Origin => Type_Iir, + Field_Operand => Type_Iir, + Field_Left => Type_Iir, + Field_Right => Type_Iir, + Field_Unit_Name => Type_Iir, + Field_Name => Type_Iir, + Field_Group_Template_Name => Type_Iir, + Field_Name_Staticness => Type_Iir_Staticness, + Field_Prefix => Type_Iir, + Field_Signature_Prefix => Type_Iir, + Field_Slice_Subtype => Type_Iir, + Field_Suffix => Type_Iir, + Field_Index_Subtype => Type_Iir, + Field_Parameter => Type_Iir, + Field_Actual_Type => Type_Iir, + Field_Associated_Interface => Type_Iir, + Field_Association_Chain => Type_Iir, + Field_Individual_Association_Chain => Type_Iir, + Field_Aggregate_Info => Type_Iir, + Field_Sub_Aggregate_Info => Type_Iir, + Field_Aggr_Dynamic_Flag => Type_Boolean, + Field_Aggr_Min_Length => Type_Iir_Int32, + Field_Aggr_Low_Limit => Type_Iir, + Field_Aggr_High_Limit => Type_Iir, + Field_Aggr_Others_Flag => Type_Boolean, + Field_Aggr_Named_Flag => Type_Boolean, + Field_Value_Staticness => Type_Iir_Staticness, + Field_Association_Choices_Chain => Type_Iir, + Field_Case_Statement_Alternative_Chain => Type_Iir, + Field_Choice_Staticness => Type_Iir_Staticness, + Field_Procedure_Call => Type_Iir, + Field_Implementation => Type_Iir, + Field_Parameter_Association_Chain => Type_Iir, + Field_Method_Object => Type_Iir, + Field_Subtype_Type_Mark => Type_Iir, + Field_Type_Conversion_Subtype => Type_Iir, + Field_Type_Mark => Type_Iir, + Field_File_Type_Mark => Type_Iir, + Field_Return_Type_Mark => Type_Iir, + Field_Lexical_Layout => Type_Iir_Lexical_Layout_Type, + Field_Incomplete_Type_List => Type_Iir_List, + Field_Has_Disconnect_Flag => Type_Boolean, + Field_Has_Active_Flag => Type_Boolean, + Field_Is_Within_Flag => Type_Boolean, + Field_Type_Marks_List => Type_Iir_List, + Field_Implicit_Alias_Flag => Type_Boolean, + Field_Alias_Signature => Type_Iir, + Field_Attribute_Signature => Type_Iir, + Field_Overload_List => Type_Iir_List, + Field_Simple_Name_Identifier => Type_Name_Id, + Field_Simple_Name_Subtype => Type_Iir, + Field_Protected_Type_Body => Type_Iir, + Field_Protected_Type_Declaration => Type_Iir, + Field_End_Location => Type_Location_Type, + Field_String_Id => Type_String_Id, + Field_String_Length => Type_Int32, + Field_Use_Flag => Type_Boolean, + Field_End_Has_Reserved_Id => Type_Boolean, + Field_End_Has_Identifier => Type_Boolean, + Field_End_Has_Postponed => Type_Boolean, + Field_Has_Begin => Type_Boolean, + Field_Has_Is => Type_Boolean, + Field_Has_Pure => Type_Boolean, + Field_Has_Body => Type_Boolean, + Field_Has_Identifier_List => Type_Boolean, + Field_Has_Mode => Type_Boolean, + Field_Is_Ref => Type_Boolean, + Field_Psl_Property => Type_PSL_Node, + Field_Psl_Declaration => Type_PSL_Node, + Field_Psl_Expression => Type_PSL_Node, + Field_Psl_Boolean => Type_PSL_Node, + Field_PSL_Clock => Type_PSL_Node, + Field_PSL_NFA => Type_PSL_NFA + ); + + function Get_Field_Type (F : Fields_Enum) return Types_Enum is + begin + return Fields_Type (F); + end Get_Field_Type; + + function Get_Field_Image (F : Fields_Enum) return String is + begin + case F is + when Field_First_Design_Unit => + return "first_design_unit"; + when Field_Last_Design_Unit => + return "last_design_unit"; + when Field_Library_Declaration => + return "library_declaration"; + when Field_File_Time_Stamp => + return "file_time_stamp"; + when Field_Analysis_Time_Stamp => + return "analysis_time_stamp"; + when Field_Library => + return "library"; + when Field_File_Dependence_List => + return "file_dependence_list"; + when Field_Design_File_Filename => + return "design_file_filename"; + when Field_Design_File_Directory => + return "design_file_directory"; + when Field_Design_File => + return "design_file"; + when Field_Design_File_Chain => + return "design_file_chain"; + when Field_Library_Directory => + return "library_directory"; + when Field_Date => + return "date"; + when Field_Context_Items => + return "context_items"; + when Field_Dependence_List => + return "dependence_list"; + when Field_Analysis_Checks_List => + return "analysis_checks_list"; + when Field_Date_State => + return "date_state"; + when Field_Guarded_Target_State => + return "guarded_target_state"; + when Field_Library_Unit => + return "library_unit"; + when Field_Hash_Chain => + return "hash_chain"; + when Field_Design_Unit_Source_Pos => + return "design_unit_source_pos"; + when Field_Design_Unit_Source_Line => + return "design_unit_source_line"; + when Field_Design_Unit_Source_Col => + return "design_unit_source_col"; + when Field_Value => + return "value"; + when Field_Enum_Pos => + return "enum_pos"; + when Field_Physical_Literal => + return "physical_literal"; + when Field_Physical_Unit_Value => + return "physical_unit_value"; + when Field_Fp_Value => + return "fp_value"; + when Field_Enumeration_Decl => + return "enumeration_decl"; + when Field_Simple_Aggregate_List => + return "simple_aggregate_list"; + when Field_Bit_String_Base => + return "bit_string_base"; + when Field_Bit_String_0 => + return "bit_string_0"; + when Field_Bit_String_1 => + return "bit_string_1"; + when Field_Literal_Origin => + return "literal_origin"; + when Field_Range_Origin => + return "range_origin"; + when Field_Literal_Subtype => + return "literal_subtype"; + when Field_Entity_Class => + return "entity_class"; + when Field_Entity_Name_List => + return "entity_name_list"; + when Field_Attribute_Designator => + return "attribute_designator"; + when Field_Attribute_Specification_Chain => + return "attribute_specification_chain"; + when Field_Attribute_Specification => + return "attribute_specification"; + when Field_Signal_List => + return "signal_list"; + when Field_Designated_Entity => + return "designated_entity"; + when Field_Formal => + return "formal"; + when Field_Actual => + return "actual"; + when Field_In_Conversion => + return "in_conversion"; + when Field_Out_Conversion => + return "out_conversion"; + when Field_Whole_Association_Flag => + return "whole_association_flag"; + when Field_Collapse_Signal_Flag => + return "collapse_signal_flag"; + when Field_Artificial_Flag => + return "artificial_flag"; + when Field_Open_Flag => + return "open_flag"; + when Field_After_Drivers_Flag => + return "after_drivers_flag"; + when Field_We_Value => + return "we_value"; + when Field_Time => + return "time"; + when Field_Associated_Expr => + return "associated_expr"; + when Field_Associated_Chain => + return "associated_chain"; + when Field_Choice_Name => + return "choice_name"; + when Field_Choice_Expression => + return "choice_expression"; + when Field_Choice_Range => + return "choice_range"; + when Field_Same_Alternative_Flag => + return "same_alternative_flag"; + when Field_Architecture => + return "architecture"; + when Field_Block_Specification => + return "block_specification"; + when Field_Prev_Block_Configuration => + return "prev_block_configuration"; + when Field_Configuration_Item_Chain => + return "configuration_item_chain"; + when Field_Attribute_Value_Chain => + return "attribute_value_chain"; + when Field_Spec_Chain => + return "spec_chain"; + when Field_Attribute_Value_Spec_Chain => + return "attribute_value_spec_chain"; + when Field_Entity_Name => + return "entity_name"; + when Field_Package => + return "package"; + when Field_Package_Body => + return "package_body"; + when Field_Need_Body => + return "need_body"; + when Field_Block_Configuration => + return "block_configuration"; + when Field_Concurrent_Statement_Chain => + return "concurrent_statement_chain"; + when Field_Chain => + return "chain"; + when Field_Port_Chain => + return "port_chain"; + when Field_Generic_Chain => + return "generic_chain"; + when Field_Type => + return "type"; + when Field_Subtype_Indication => + return "subtype_indication"; + when Field_Discrete_Range => + return "discrete_range"; + when Field_Type_Definition => + return "type_definition"; + when Field_Subtype_Definition => + return "subtype_definition"; + when Field_Nature => + return "nature"; + when Field_Mode => + return "mode"; + when Field_Signal_Kind => + return "signal_kind"; + when Field_Base_Name => + return "base_name"; + when Field_Interface_Declaration_Chain => + return "interface_declaration_chain"; + when Field_Subprogram_Specification => + return "subprogram_specification"; + when Field_Sequential_Statement_Chain => + return "sequential_statement_chain"; + when Field_Subprogram_Body => + return "subprogram_body"; + when Field_Overload_Number => + return "overload_number"; + when Field_Subprogram_Depth => + return "subprogram_depth"; + when Field_Subprogram_Hash => + return "subprogram_hash"; + when Field_Impure_Depth => + return "impure_depth"; + when Field_Return_Type => + return "return_type"; + when Field_Implicit_Definition => + return "implicit_definition"; + when Field_Type_Reference => + return "type_reference"; + when Field_Default_Value => + return "default_value"; + when Field_Deferred_Declaration => + return "deferred_declaration"; + when Field_Deferred_Declaration_Flag => + return "deferred_declaration_flag"; + when Field_Shared_Flag => + return "shared_flag"; + when Field_Design_Unit => + return "design_unit"; + when Field_Block_Statement => + return "block_statement"; + when Field_Signal_Driver => + return "signal_driver"; + when Field_Declaration_Chain => + return "declaration_chain"; + when Field_File_Logical_Name => + return "file_logical_name"; + when Field_File_Open_Kind => + return "file_open_kind"; + when Field_Element_Position => + return "element_position"; + when Field_Element_Declaration => + return "element_declaration"; + when Field_Selected_Element => + return "selected_element"; + when Field_Use_Clause_Chain => + return "use_clause_chain"; + when Field_Selected_Name => + return "selected_name"; + when Field_Type_Declarator => + return "type_declarator"; + when Field_Enumeration_Literal_List => + return "enumeration_literal_list"; + when Field_Entity_Class_Entry_Chain => + return "entity_class_entry_chain"; + when Field_Group_Constituent_List => + return "group_constituent_list"; + when Field_Unit_Chain => + return "unit_chain"; + when Field_Primary_Unit => + return "primary_unit"; + when Field_Identifier => + return "identifier"; + when Field_Label => + return "label"; + when Field_Visible_Flag => + return "visible_flag"; + when Field_Range_Constraint => + return "range_constraint"; + when Field_Direction => + return "direction"; + when Field_Left_Limit => + return "left_limit"; + when Field_Right_Limit => + return "right_limit"; + when Field_Base_Type => + return "base_type"; + when Field_Resolution_Indication => + return "resolution_indication"; + when Field_Record_Element_Resolution_Chain => + return "record_element_resolution_chain"; + when Field_Tolerance => + return "tolerance"; + when Field_Plus_Terminal => + return "plus_terminal"; + when Field_Minus_Terminal => + return "minus_terminal"; + when Field_Simultaneous_Left => + return "simultaneous_left"; + when Field_Simultaneous_Right => + return "simultaneous_right"; + when Field_Text_File_Flag => + return "text_file_flag"; + when Field_Only_Characters_Flag => + return "only_characters_flag"; + when Field_Type_Staticness => + return "type_staticness"; + when Field_Constraint_State => + return "constraint_state"; + when Field_Index_Subtype_List => + return "index_subtype_list"; + when Field_Index_Subtype_Definition_List => + return "index_subtype_definition_list"; + when Field_Element_Subtype_Indication => + return "element_subtype_indication"; + when Field_Element_Subtype => + return "element_subtype"; + when Field_Index_Constraint_List => + return "index_constraint_list"; + when Field_Array_Element_Constraint => + return "array_element_constraint"; + when Field_Elements_Declaration_List => + return "elements_declaration_list"; + when Field_Designated_Type => + return "designated_type"; + when Field_Designated_Subtype_Indication => + return "designated_subtype_indication"; + when Field_Index_List => + return "index_list"; + when Field_Reference => + return "reference"; + when Field_Nature_Declarator => + return "nature_declarator"; + when Field_Across_Type => + return "across_type"; + when Field_Through_Type => + return "through_type"; + when Field_Target => + return "target"; + when Field_Waveform_Chain => + return "waveform_chain"; + when Field_Guard => + return "guard"; + when Field_Delay_Mechanism => + return "delay_mechanism"; + when Field_Reject_Time_Expression => + return "reject_time_expression"; + when Field_Sensitivity_List => + return "sensitivity_list"; + when Field_Process_Origin => + return "process_origin"; + when Field_Condition_Clause => + return "condition_clause"; + when Field_Timeout_Clause => + return "timeout_clause"; + when Field_Postponed_Flag => + return "postponed_flag"; + when Field_Callees_List => + return "callees_list"; + when Field_Passive_Flag => + return "passive_flag"; + when Field_Resolution_Function_Flag => + return "resolution_function_flag"; + when Field_Wait_State => + return "wait_state"; + when Field_All_Sensitized_State => + return "all_sensitized_state"; + when Field_Seen_Flag => + return "seen_flag"; + when Field_Pure_Flag => + return "pure_flag"; + when Field_Foreign_Flag => + return "foreign_flag"; + when Field_Resolved_Flag => + return "resolved_flag"; + when Field_Signal_Type_Flag => + return "signal_type_flag"; + when Field_Has_Signal_Flag => + return "has_signal_flag"; + when Field_Purity_State => + return "purity_state"; + when Field_Elab_Flag => + return "elab_flag"; + when Field_Index_Constraint_Flag => + return "index_constraint_flag"; + when Field_Assertion_Condition => + return "assertion_condition"; + when Field_Report_Expression => + return "report_expression"; + when Field_Severity_Expression => + return "severity_expression"; + when Field_Instantiated_Unit => + return "instantiated_unit"; + when Field_Generic_Map_Aspect_Chain => + return "generic_map_aspect_chain"; + when Field_Port_Map_Aspect_Chain => + return "port_map_aspect_chain"; + when Field_Configuration_Name => + return "configuration_name"; + when Field_Component_Configuration => + return "component_configuration"; + when Field_Configuration_Specification => + return "configuration_specification"; + when Field_Default_Binding_Indication => + return "default_binding_indication"; + when Field_Default_Configuration_Declaration => + return "default_configuration_declaration"; + when Field_Expression => + return "expression"; + when Field_Allocator_Designated_Type => + return "allocator_designated_type"; + when Field_Selected_Waveform_Chain => + return "selected_waveform_chain"; + when Field_Conditional_Waveform_Chain => + return "conditional_waveform_chain"; + when Field_Guard_Expression => + return "guard_expression"; + when Field_Guard_Decl => + return "guard_decl"; + when Field_Guard_Sensitivity_List => + return "guard_sensitivity_list"; + when Field_Block_Block_Configuration => + return "block_block_configuration"; + when Field_Package_Header => + return "package_header"; + when Field_Block_Header => + return "block_header"; + when Field_Uninstantiated_Package_Name => + return "uninstantiated_package_name"; + when Field_Generate_Block_Configuration => + return "generate_block_configuration"; + when Field_Generation_Scheme => + return "generation_scheme"; + when Field_Condition => + return "condition"; + when Field_Else_Clause => + return "else_clause"; + when Field_Parameter_Specification => + return "parameter_specification"; + when Field_Parent => + return "parent"; + when Field_Loop_Label => + return "loop_label"; + when Field_Component_Name => + return "component_name"; + when Field_Instantiation_List => + return "instantiation_list"; + when Field_Entity_Aspect => + return "entity_aspect"; + when Field_Default_Entity_Aspect => + return "default_entity_aspect"; + when Field_Default_Generic_Map_Aspect_Chain => + return "default_generic_map_aspect_chain"; + when Field_Default_Port_Map_Aspect_Chain => + return "default_port_map_aspect_chain"; + when Field_Binding_Indication => + return "binding_indication"; + when Field_Named_Entity => + return "named_entity"; + when Field_Alias_Declaration => + return "alias_declaration"; + when Field_Expr_Staticness => + return "expr_staticness"; + when Field_Error_Origin => + return "error_origin"; + when Field_Operand => + return "operand"; + when Field_Left => + return "left"; + when Field_Right => + return "right"; + when Field_Unit_Name => + return "unit_name"; + when Field_Name => + return "name"; + when Field_Group_Template_Name => + return "group_template_name"; + when Field_Name_Staticness => + return "name_staticness"; + when Field_Prefix => + return "prefix"; + when Field_Signature_Prefix => + return "signature_prefix"; + when Field_Slice_Subtype => + return "slice_subtype"; + when Field_Suffix => + return "suffix"; + when Field_Index_Subtype => + return "index_subtype"; + when Field_Parameter => + return "parameter"; + when Field_Actual_Type => + return "actual_type"; + when Field_Associated_Interface => + return "associated_interface"; + when Field_Association_Chain => + return "association_chain"; + when Field_Individual_Association_Chain => + return "individual_association_chain"; + when Field_Aggregate_Info => + return "aggregate_info"; + when Field_Sub_Aggregate_Info => + return "sub_aggregate_info"; + when Field_Aggr_Dynamic_Flag => + return "aggr_dynamic_flag"; + when Field_Aggr_Min_Length => + return "aggr_min_length"; + when Field_Aggr_Low_Limit => + return "aggr_low_limit"; + when Field_Aggr_High_Limit => + return "aggr_high_limit"; + when Field_Aggr_Others_Flag => + return "aggr_others_flag"; + when Field_Aggr_Named_Flag => + return "aggr_named_flag"; + when Field_Value_Staticness => + return "value_staticness"; + when Field_Association_Choices_Chain => + return "association_choices_chain"; + when Field_Case_Statement_Alternative_Chain => + return "case_statement_alternative_chain"; + when Field_Choice_Staticness => + return "choice_staticness"; + when Field_Procedure_Call => + return "procedure_call"; + when Field_Implementation => + return "implementation"; + when Field_Parameter_Association_Chain => + return "parameter_association_chain"; + when Field_Method_Object => + return "method_object"; + when Field_Subtype_Type_Mark => + return "subtype_type_mark"; + when Field_Type_Conversion_Subtype => + return "type_conversion_subtype"; + when Field_Type_Mark => + return "type_mark"; + when Field_File_Type_Mark => + return "file_type_mark"; + when Field_Return_Type_Mark => + return "return_type_mark"; + when Field_Lexical_Layout => + return "lexical_layout"; + when Field_Incomplete_Type_List => + return "incomplete_type_list"; + when Field_Has_Disconnect_Flag => + return "has_disconnect_flag"; + when Field_Has_Active_Flag => + return "has_active_flag"; + when Field_Is_Within_Flag => + return "is_within_flag"; + when Field_Type_Marks_List => + return "type_marks_list"; + when Field_Implicit_Alias_Flag => + return "implicit_alias_flag"; + when Field_Alias_Signature => + return "alias_signature"; + when Field_Attribute_Signature => + return "attribute_signature"; + when Field_Overload_List => + return "overload_list"; + when Field_Simple_Name_Identifier => + return "simple_name_identifier"; + when Field_Simple_Name_Subtype => + return "simple_name_subtype"; + when Field_Protected_Type_Body => + return "protected_type_body"; + when Field_Protected_Type_Declaration => + return "protected_type_declaration"; + when Field_End_Location => + return "end_location"; + when Field_String_Id => + return "string_id"; + when Field_String_Length => + return "string_length"; + when Field_Use_Flag => + return "use_flag"; + when Field_End_Has_Reserved_Id => + return "end_has_reserved_id"; + when Field_End_Has_Identifier => + return "end_has_identifier"; + when Field_End_Has_Postponed => + return "end_has_postponed"; + when Field_Has_Begin => + return "has_begin"; + when Field_Has_Is => + return "has_is"; + when Field_Has_Pure => + return "has_pure"; + when Field_Has_Body => + return "has_body"; + when Field_Has_Identifier_List => + return "has_identifier_list"; + when Field_Has_Mode => + return "has_mode"; + when Field_Is_Ref => + return "is_ref"; + when Field_Psl_Property => + return "psl_property"; + when Field_Psl_Declaration => + return "psl_declaration"; + when Field_Psl_Expression => + return "psl_expression"; + when Field_Psl_Boolean => + return "psl_boolean"; + when Field_PSL_Clock => + return "psl_clock"; + when Field_PSL_NFA => + return "psl_nfa"; + end case; + end Get_Field_Image; + + function Get_Iir_Image (K : Iir_Kind) return String is + begin + case K is + when Iir_Kind_Unused => + return "unused"; + when Iir_Kind_Error => + return "error"; + when Iir_Kind_Design_File => + return "design_file"; + when Iir_Kind_Design_Unit => + return "design_unit"; + when Iir_Kind_Library_Clause => + return "library_clause"; + when Iir_Kind_Use_Clause => + return "use_clause"; + when Iir_Kind_Integer_Literal => + return "integer_literal"; + when Iir_Kind_Floating_Point_Literal => + return "floating_point_literal"; + when Iir_Kind_Null_Literal => + return "null_literal"; + when Iir_Kind_String_Literal => + return "string_literal"; + when Iir_Kind_Physical_Int_Literal => + return "physical_int_literal"; + when Iir_Kind_Physical_Fp_Literal => + return "physical_fp_literal"; + when Iir_Kind_Bit_String_Literal => + return "bit_string_literal"; + when Iir_Kind_Simple_Aggregate => + return "simple_aggregate"; + when Iir_Kind_Overflow_Literal => + return "overflow_literal"; + when Iir_Kind_Waveform_Element => + return "waveform_element"; + when Iir_Kind_Conditional_Waveform => + return "conditional_waveform"; + when Iir_Kind_Association_Element_By_Expression => + return "association_element_by_expression"; + when Iir_Kind_Association_Element_By_Individual => + return "association_element_by_individual"; + when Iir_Kind_Association_Element_Open => + return "association_element_open"; + when Iir_Kind_Association_Element_Package => + return "association_element_package"; + when Iir_Kind_Choice_By_Others => + return "choice_by_others"; + when Iir_Kind_Choice_By_Expression => + return "choice_by_expression"; + when Iir_Kind_Choice_By_Range => + return "choice_by_range"; + when Iir_Kind_Choice_By_None => + return "choice_by_none"; + when Iir_Kind_Choice_By_Name => + return "choice_by_name"; + when Iir_Kind_Entity_Aspect_Entity => + return "entity_aspect_entity"; + when Iir_Kind_Entity_Aspect_Configuration => + return "entity_aspect_configuration"; + when Iir_Kind_Entity_Aspect_Open => + return "entity_aspect_open"; + when Iir_Kind_Block_Configuration => + return "block_configuration"; + when Iir_Kind_Block_Header => + return "block_header"; + when Iir_Kind_Component_Configuration => + return "component_configuration"; + when Iir_Kind_Binding_Indication => + return "binding_indication"; + when Iir_Kind_Entity_Class => + return "entity_class"; + when Iir_Kind_Attribute_Value => + return "attribute_value"; + when Iir_Kind_Signature => + return "signature"; + when Iir_Kind_Aggregate_Info => + return "aggregate_info"; + when Iir_Kind_Procedure_Call => + return "procedure_call"; + when Iir_Kind_Record_Element_Constraint => + return "record_element_constraint"; + when Iir_Kind_Array_Element_Resolution => + return "array_element_resolution"; + when Iir_Kind_Record_Resolution => + return "record_resolution"; + when Iir_Kind_Record_Element_Resolution => + return "record_element_resolution"; + when Iir_Kind_Attribute_Specification => + return "attribute_specification"; + when Iir_Kind_Disconnection_Specification => + return "disconnection_specification"; + when Iir_Kind_Configuration_Specification => + return "configuration_specification"; + when Iir_Kind_Access_Type_Definition => + return "access_type_definition"; + when Iir_Kind_Incomplete_Type_Definition => + return "incomplete_type_definition"; + when Iir_Kind_File_Type_Definition => + return "file_type_definition"; + when Iir_Kind_Protected_Type_Declaration => + return "protected_type_declaration"; + when Iir_Kind_Record_Type_Definition => + return "record_type_definition"; + when Iir_Kind_Array_Type_Definition => + return "array_type_definition"; + when Iir_Kind_Array_Subtype_Definition => + return "array_subtype_definition"; + when Iir_Kind_Record_Subtype_Definition => + return "record_subtype_definition"; + when Iir_Kind_Access_Subtype_Definition => + return "access_subtype_definition"; + when Iir_Kind_Physical_Subtype_Definition => + return "physical_subtype_definition"; + when Iir_Kind_Floating_Subtype_Definition => + return "floating_subtype_definition"; + when Iir_Kind_Integer_Subtype_Definition => + return "integer_subtype_definition"; + when Iir_Kind_Enumeration_Subtype_Definition => + return "enumeration_subtype_definition"; + when Iir_Kind_Enumeration_Type_Definition => + return "enumeration_type_definition"; + when Iir_Kind_Integer_Type_Definition => + return "integer_type_definition"; + when Iir_Kind_Floating_Type_Definition => + return "floating_type_definition"; + when Iir_Kind_Physical_Type_Definition => + return "physical_type_definition"; + when Iir_Kind_Range_Expression => + return "range_expression"; + when Iir_Kind_Protected_Type_Body => + return "protected_type_body"; + when Iir_Kind_Subtype_Definition => + return "subtype_definition"; + when Iir_Kind_Scalar_Nature_Definition => + return "scalar_nature_definition"; + when Iir_Kind_Overload_List => + return "overload_list"; + when Iir_Kind_Type_Declaration => + return "type_declaration"; + when Iir_Kind_Anonymous_Type_Declaration => + return "anonymous_type_declaration"; + when Iir_Kind_Subtype_Declaration => + return "subtype_declaration"; + when Iir_Kind_Nature_Declaration => + return "nature_declaration"; + when Iir_Kind_Subnature_Declaration => + return "subnature_declaration"; + when Iir_Kind_Package_Declaration => + return "package_declaration"; + when Iir_Kind_Package_Instantiation_Declaration => + return "package_instantiation_declaration"; + when Iir_Kind_Package_Body => + return "package_body"; + when Iir_Kind_Configuration_Declaration => + return "configuration_declaration"; + when Iir_Kind_Entity_Declaration => + return "entity_declaration"; + when Iir_Kind_Architecture_Body => + return "architecture_body"; + when Iir_Kind_Package_Header => + return "package_header"; + when Iir_Kind_Unit_Declaration => + return "unit_declaration"; + when Iir_Kind_Library_Declaration => + return "library_declaration"; + when Iir_Kind_Component_Declaration => + return "component_declaration"; + when Iir_Kind_Attribute_Declaration => + return "attribute_declaration"; + when Iir_Kind_Group_Template_Declaration => + return "group_template_declaration"; + when Iir_Kind_Group_Declaration => + return "group_declaration"; + when Iir_Kind_Element_Declaration => + return "element_declaration"; + when Iir_Kind_Non_Object_Alias_Declaration => + return "non_object_alias_declaration"; + when Iir_Kind_Psl_Declaration => + return "psl_declaration"; + when Iir_Kind_Terminal_Declaration => + return "terminal_declaration"; + when Iir_Kind_Free_Quantity_Declaration => + return "free_quantity_declaration"; + when Iir_Kind_Across_Quantity_Declaration => + return "across_quantity_declaration"; + when Iir_Kind_Through_Quantity_Declaration => + return "through_quantity_declaration"; + when Iir_Kind_Enumeration_Literal => + return "enumeration_literal"; + when Iir_Kind_Function_Declaration => + return "function_declaration"; + when Iir_Kind_Implicit_Function_Declaration => + return "implicit_function_declaration"; + when Iir_Kind_Implicit_Procedure_Declaration => + return "implicit_procedure_declaration"; + when Iir_Kind_Procedure_Declaration => + return "procedure_declaration"; + when Iir_Kind_Function_Body => + return "function_body"; + when Iir_Kind_Procedure_Body => + return "procedure_body"; + when Iir_Kind_Object_Alias_Declaration => + return "object_alias_declaration"; + when Iir_Kind_File_Declaration => + return "file_declaration"; + when Iir_Kind_Guard_Signal_Declaration => + return "guard_signal_declaration"; + when Iir_Kind_Signal_Declaration => + return "signal_declaration"; + when Iir_Kind_Variable_Declaration => + return "variable_declaration"; + when Iir_Kind_Constant_Declaration => + return "constant_declaration"; + when Iir_Kind_Iterator_Declaration => + return "iterator_declaration"; + when Iir_Kind_Interface_Constant_Declaration => + return "interface_constant_declaration"; + when Iir_Kind_Interface_Variable_Declaration => + return "interface_variable_declaration"; + when Iir_Kind_Interface_Signal_Declaration => + return "interface_signal_declaration"; + when Iir_Kind_Interface_File_Declaration => + return "interface_file_declaration"; + when Iir_Kind_Interface_Package_Declaration => + return "interface_package_declaration"; + when Iir_Kind_Identity_Operator => + return "identity_operator"; + when Iir_Kind_Negation_Operator => + return "negation_operator"; + when Iir_Kind_Absolute_Operator => + return "absolute_operator"; + when Iir_Kind_Not_Operator => + return "not_operator"; + when Iir_Kind_Condition_Operator => + return "condition_operator"; + when Iir_Kind_Reduction_And_Operator => + return "reduction_and_operator"; + when Iir_Kind_Reduction_Or_Operator => + return "reduction_or_operator"; + when Iir_Kind_Reduction_Nand_Operator => + return "reduction_nand_operator"; + when Iir_Kind_Reduction_Nor_Operator => + return "reduction_nor_operator"; + when Iir_Kind_Reduction_Xor_Operator => + return "reduction_xor_operator"; + when Iir_Kind_Reduction_Xnor_Operator => + return "reduction_xnor_operator"; + when Iir_Kind_And_Operator => + return "and_operator"; + when Iir_Kind_Or_Operator => + return "or_operator"; + when Iir_Kind_Nand_Operator => + return "nand_operator"; + when Iir_Kind_Nor_Operator => + return "nor_operator"; + when Iir_Kind_Xor_Operator => + return "xor_operator"; + when Iir_Kind_Xnor_Operator => + return "xnor_operator"; + when Iir_Kind_Equality_Operator => + return "equality_operator"; + when Iir_Kind_Inequality_Operator => + return "inequality_operator"; + when Iir_Kind_Less_Than_Operator => + return "less_than_operator"; + when Iir_Kind_Less_Than_Or_Equal_Operator => + return "less_than_or_equal_operator"; + when Iir_Kind_Greater_Than_Operator => + return "greater_than_operator"; + when Iir_Kind_Greater_Than_Or_Equal_Operator => + return "greater_than_or_equal_operator"; + when Iir_Kind_Match_Equality_Operator => + return "match_equality_operator"; + when Iir_Kind_Match_Inequality_Operator => + return "match_inequality_operator"; + when Iir_Kind_Match_Less_Than_Operator => + return "match_less_than_operator"; + when Iir_Kind_Match_Less_Than_Or_Equal_Operator => + return "match_less_than_or_equal_operator"; + when Iir_Kind_Match_Greater_Than_Operator => + return "match_greater_than_operator"; + when Iir_Kind_Match_Greater_Than_Or_Equal_Operator => + return "match_greater_than_or_equal_operator"; + when Iir_Kind_Sll_Operator => + return "sll_operator"; + when Iir_Kind_Sla_Operator => + return "sla_operator"; + when Iir_Kind_Srl_Operator => + return "srl_operator"; + when Iir_Kind_Sra_Operator => + return "sra_operator"; + when Iir_Kind_Rol_Operator => + return "rol_operator"; + when Iir_Kind_Ror_Operator => + return "ror_operator"; + when Iir_Kind_Addition_Operator => + return "addition_operator"; + when Iir_Kind_Substraction_Operator => + return "substraction_operator"; + when Iir_Kind_Concatenation_Operator => + return "concatenation_operator"; + when Iir_Kind_Multiplication_Operator => + return "multiplication_operator"; + when Iir_Kind_Division_Operator => + return "division_operator"; + when Iir_Kind_Modulus_Operator => + return "modulus_operator"; + when Iir_Kind_Remainder_Operator => + return "remainder_operator"; + when Iir_Kind_Exponentiation_Operator => + return "exponentiation_operator"; + when Iir_Kind_Function_Call => + return "function_call"; + when Iir_Kind_Aggregate => + return "aggregate"; + when Iir_Kind_Parenthesis_Expression => + return "parenthesis_expression"; + when Iir_Kind_Qualified_Expression => + return "qualified_expression"; + when Iir_Kind_Type_Conversion => + return "type_conversion"; + when Iir_Kind_Allocator_By_Expression => + return "allocator_by_expression"; + when Iir_Kind_Allocator_By_Subtype => + return "allocator_by_subtype"; + when Iir_Kind_Selected_Element => + return "selected_element"; + when Iir_Kind_Dereference => + return "dereference"; + when Iir_Kind_Implicit_Dereference => + return "implicit_dereference"; + when Iir_Kind_Slice_Name => + return "slice_name"; + when Iir_Kind_Indexed_Name => + return "indexed_name"; + when Iir_Kind_Psl_Expression => + return "psl_expression"; + when Iir_Kind_Sensitized_Process_Statement => + return "sensitized_process_statement"; + when Iir_Kind_Process_Statement => + return "process_statement"; + when Iir_Kind_Concurrent_Conditional_Signal_Assignment => + return "concurrent_conditional_signal_assignment"; + when Iir_Kind_Concurrent_Selected_Signal_Assignment => + return "concurrent_selected_signal_assignment"; + when Iir_Kind_Concurrent_Assertion_Statement => + return "concurrent_assertion_statement"; + when Iir_Kind_Psl_Default_Clock => + return "psl_default_clock"; + when Iir_Kind_Psl_Assert_Statement => + return "psl_assert_statement"; + when Iir_Kind_Psl_Cover_Statement => + return "psl_cover_statement"; + when Iir_Kind_Concurrent_Procedure_Call_Statement => + return "concurrent_procedure_call_statement"; + when Iir_Kind_Block_Statement => + return "block_statement"; + when Iir_Kind_Generate_Statement => + return "generate_statement"; + when Iir_Kind_Component_Instantiation_Statement => + return "component_instantiation_statement"; + when Iir_Kind_Simple_Simultaneous_Statement => + return "simple_simultaneous_statement"; + when Iir_Kind_Signal_Assignment_Statement => + return "signal_assignment_statement"; + when Iir_Kind_Null_Statement => + return "null_statement"; + when Iir_Kind_Assertion_Statement => + return "assertion_statement"; + when Iir_Kind_Report_Statement => + return "report_statement"; + when Iir_Kind_Wait_Statement => + return "wait_statement"; + when Iir_Kind_Variable_Assignment_Statement => + return "variable_assignment_statement"; + when Iir_Kind_Return_Statement => + return "return_statement"; + when Iir_Kind_For_Loop_Statement => + return "for_loop_statement"; + when Iir_Kind_While_Loop_Statement => + return "while_loop_statement"; + when Iir_Kind_Next_Statement => + return "next_statement"; + when Iir_Kind_Exit_Statement => + return "exit_statement"; + when Iir_Kind_Case_Statement => + return "case_statement"; + when Iir_Kind_Procedure_Call_Statement => + return "procedure_call_statement"; + when Iir_Kind_If_Statement => + return "if_statement"; + when Iir_Kind_Elsif => + return "elsif"; + when Iir_Kind_Character_Literal => + return "character_literal"; + when Iir_Kind_Simple_Name => + return "simple_name"; + when Iir_Kind_Selected_Name => + return "selected_name"; + when Iir_Kind_Operator_Symbol => + return "operator_symbol"; + when Iir_Kind_Selected_By_All_Name => + return "selected_by_all_name"; + when Iir_Kind_Parenthesis_Name => + return "parenthesis_name"; + when Iir_Kind_Base_Attribute => + return "base_attribute"; + when Iir_Kind_Left_Type_Attribute => + return "left_type_attribute"; + when Iir_Kind_Right_Type_Attribute => + return "right_type_attribute"; + when Iir_Kind_High_Type_Attribute => + return "high_type_attribute"; + when Iir_Kind_Low_Type_Attribute => + return "low_type_attribute"; + when Iir_Kind_Ascending_Type_Attribute => + return "ascending_type_attribute"; + when Iir_Kind_Image_Attribute => + return "image_attribute"; + when Iir_Kind_Value_Attribute => + return "value_attribute"; + when Iir_Kind_Pos_Attribute => + return "pos_attribute"; + when Iir_Kind_Val_Attribute => + return "val_attribute"; + when Iir_Kind_Succ_Attribute => + return "succ_attribute"; + when Iir_Kind_Pred_Attribute => + return "pred_attribute"; + when Iir_Kind_Leftof_Attribute => + return "leftof_attribute"; + when Iir_Kind_Rightof_Attribute => + return "rightof_attribute"; + when Iir_Kind_Delayed_Attribute => + return "delayed_attribute"; + when Iir_Kind_Stable_Attribute => + return "stable_attribute"; + when Iir_Kind_Quiet_Attribute => + return "quiet_attribute"; + when Iir_Kind_Transaction_Attribute => + return "transaction_attribute"; + when Iir_Kind_Event_Attribute => + return "event_attribute"; + when Iir_Kind_Active_Attribute => + return "active_attribute"; + when Iir_Kind_Last_Event_Attribute => + return "last_event_attribute"; + when Iir_Kind_Last_Active_Attribute => + return "last_active_attribute"; + when Iir_Kind_Last_Value_Attribute => + return "last_value_attribute"; + when Iir_Kind_Driving_Attribute => + return "driving_attribute"; + when Iir_Kind_Driving_Value_Attribute => + return "driving_value_attribute"; + when Iir_Kind_Behavior_Attribute => + return "behavior_attribute"; + when Iir_Kind_Structure_Attribute => + return "structure_attribute"; + when Iir_Kind_Simple_Name_Attribute => + return "simple_name_attribute"; + when Iir_Kind_Instance_Name_Attribute => + return "instance_name_attribute"; + when Iir_Kind_Path_Name_Attribute => + return "path_name_attribute"; + when Iir_Kind_Left_Array_Attribute => + return "left_array_attribute"; + when Iir_Kind_Right_Array_Attribute => + return "right_array_attribute"; + when Iir_Kind_High_Array_Attribute => + return "high_array_attribute"; + when Iir_Kind_Low_Array_Attribute => + return "low_array_attribute"; + when Iir_Kind_Length_Array_Attribute => + return "length_array_attribute"; + when Iir_Kind_Ascending_Array_Attribute => + return "ascending_array_attribute"; + when Iir_Kind_Range_Array_Attribute => + return "range_array_attribute"; + when Iir_Kind_Reverse_Range_Array_Attribute => + return "reverse_range_array_attribute"; + when Iir_Kind_Attribute_Name => + return "attribute_name"; + end case; + end Get_Iir_Image; + + function Get_Field_Attribute (F : Fields_Enum) return Field_Attribute is + begin + case F is + when Field_First_Design_Unit => + return Attr_Chain; + when Field_Last_Design_Unit => + return Attr_Ref; + when Field_Library_Declaration => + return Attr_None; + when Field_File_Time_Stamp => + return Attr_None; + when Field_Analysis_Time_Stamp => + return Attr_None; + when Field_Library => + return Attr_Ref; + when Field_File_Dependence_List => + return Attr_None; + when Field_Design_File_Filename => + return Attr_None; + when Field_Design_File_Directory => + return Attr_None; + when Field_Design_File => + return Attr_Ref; + when Field_Design_File_Chain => + return Attr_Chain; + when Field_Library_Directory => + return Attr_None; + when Field_Date => + return Attr_None; + when Field_Context_Items => + return Attr_Chain; + when Field_Dependence_List => + return Attr_Of_Ref; + when Field_Analysis_Checks_List => + return Attr_None; + when Field_Date_State => + return Attr_None; + when Field_Guarded_Target_State => + return Attr_None; + when Field_Library_Unit => + return Attr_None; + when Field_Hash_Chain => + return Attr_Ref; + when Field_Design_Unit_Source_Pos => + return Attr_None; + when Field_Design_Unit_Source_Line => + return Attr_None; + when Field_Design_Unit_Source_Col => + return Attr_None; + when Field_Value => + return Attr_None; + when Field_Enum_Pos => + return Attr_None; + when Field_Physical_Literal => + return Attr_None; + when Field_Physical_Unit_Value => + return Attr_None; + when Field_Fp_Value => + return Attr_None; + when Field_Enumeration_Decl => + return Attr_Ref; + when Field_Simple_Aggregate_List => + return Attr_None; + when Field_Bit_String_Base => + return Attr_None; + when Field_Bit_String_0 => + return Attr_None; + when Field_Bit_String_1 => + return Attr_None; + when Field_Literal_Origin => + return Attr_None; + when Field_Range_Origin => + return Attr_None; + when Field_Literal_Subtype => + return Attr_None; + when Field_Entity_Class => + return Attr_None; + when Field_Entity_Name_List => + return Attr_None; + when Field_Attribute_Designator => + return Attr_None; + when Field_Attribute_Specification_Chain => + return Attr_None; + when Field_Attribute_Specification => + return Attr_Ref; + when Field_Signal_List => + return Attr_None; + when Field_Designated_Entity => + return Attr_Ref; + when Field_Formal => + return Attr_None; + when Field_Actual => + return Attr_None; + when Field_In_Conversion => + return Attr_None; + when Field_Out_Conversion => + return Attr_None; + when Field_Whole_Association_Flag => + return Attr_None; + when Field_Collapse_Signal_Flag => + return Attr_None; + when Field_Artificial_Flag => + return Attr_None; + when Field_Open_Flag => + return Attr_None; + when Field_After_Drivers_Flag => + return Attr_None; + when Field_We_Value => + return Attr_None; + when Field_Time => + return Attr_None; + when Field_Associated_Expr => + return Attr_None; + when Field_Associated_Chain => + return Attr_Chain; + when Field_Choice_Name => + return Attr_None; + when Field_Choice_Expression => + return Attr_None; + when Field_Choice_Range => + return Attr_None; + when Field_Same_Alternative_Flag => + return Attr_None; + when Field_Architecture => + return Attr_None; + when Field_Block_Specification => + return Attr_None; + when Field_Prev_Block_Configuration => + return Attr_Ref; + when Field_Configuration_Item_Chain => + return Attr_Chain; + when Field_Attribute_Value_Chain => + return Attr_Chain; + when Field_Spec_Chain => + return Attr_None; + when Field_Attribute_Value_Spec_Chain => + return Attr_None; + when Field_Entity_Name => + return Attr_None; + when Field_Package => + return Attr_Ref; + when Field_Package_Body => + return Attr_Ref; + when Field_Need_Body => + return Attr_None; + when Field_Block_Configuration => + return Attr_None; + when Field_Concurrent_Statement_Chain => + return Attr_Chain; + when Field_Chain => + return Attr_Chain_Next; + when Field_Port_Chain => + return Attr_Chain; + when Field_Generic_Chain => + return Attr_Chain; + when Field_Type => + return Attr_Ref; + when Field_Subtype_Indication => + return Attr_Maybe_Ref; + when Field_Discrete_Range => + return Attr_None; + when Field_Type_Definition => + return Attr_None; + when Field_Subtype_Definition => + return Attr_None; + when Field_Nature => + return Attr_None; + when Field_Mode => + return Attr_None; + when Field_Signal_Kind => + return Attr_None; + when Field_Base_Name => + return Attr_Ref; + when Field_Interface_Declaration_Chain => + return Attr_Chain; + when Field_Subprogram_Specification => + return Attr_Ref; + when Field_Sequential_Statement_Chain => + return Attr_Chain; + when Field_Subprogram_Body => + return Attr_Ref; + when Field_Overload_Number => + return Attr_None; + when Field_Subprogram_Depth => + return Attr_None; + when Field_Subprogram_Hash => + return Attr_None; + when Field_Impure_Depth => + return Attr_None; + when Field_Return_Type => + return Attr_Ref; + when Field_Implicit_Definition => + return Attr_None; + when Field_Type_Reference => + return Attr_Ref; + when Field_Default_Value => + return Attr_Maybe_Ref; + when Field_Deferred_Declaration => + return Attr_None; + when Field_Deferred_Declaration_Flag => + return Attr_None; + when Field_Shared_Flag => + return Attr_None; + when Field_Design_Unit => + return Attr_None; + when Field_Block_Statement => + return Attr_None; + when Field_Signal_Driver => + return Attr_None; + when Field_Declaration_Chain => + return Attr_Chain; + when Field_File_Logical_Name => + return Attr_None; + when Field_File_Open_Kind => + return Attr_None; + when Field_Element_Position => + return Attr_None; + when Field_Element_Declaration => + return Attr_None; + when Field_Selected_Element => + return Attr_Ref; + when Field_Use_Clause_Chain => + return Attr_None; + when Field_Selected_Name => + return Attr_None; + when Field_Type_Declarator => + return Attr_Ref; + when Field_Enumeration_Literal_List => + return Attr_None; + when Field_Entity_Class_Entry_Chain => + return Attr_Chain; + when Field_Group_Constituent_List => + return Attr_None; + when Field_Unit_Chain => + return Attr_Chain; + when Field_Primary_Unit => + return Attr_Ref; + when Field_Identifier => + return Attr_None; + when Field_Label => + return Attr_None; + when Field_Visible_Flag => + return Attr_None; + when Field_Range_Constraint => + return Attr_None; + when Field_Direction => + return Attr_None; + when Field_Left_Limit => + return Attr_None; + when Field_Right_Limit => + return Attr_None; + when Field_Base_Type => + return Attr_Ref; + when Field_Resolution_Indication => + return Attr_None; + when Field_Record_Element_Resolution_Chain => + return Attr_Chain; + when Field_Tolerance => + return Attr_None; + when Field_Plus_Terminal => + return Attr_None; + when Field_Minus_Terminal => + return Attr_None; + when Field_Simultaneous_Left => + return Attr_None; + when Field_Simultaneous_Right => + return Attr_None; + when Field_Text_File_Flag => + return Attr_None; + when Field_Only_Characters_Flag => + return Attr_None; + when Field_Type_Staticness => + return Attr_None; + when Field_Constraint_State => + return Attr_None; + when Field_Index_Subtype_List => + return Attr_Ref; + when Field_Index_Subtype_Definition_List => + return Attr_None; + when Field_Element_Subtype_Indication => + return Attr_None; + when Field_Element_Subtype => + return Attr_Ref; + when Field_Index_Constraint_List => + return Attr_None; + when Field_Array_Element_Constraint => + return Attr_None; + when Field_Elements_Declaration_List => + return Attr_None; + when Field_Designated_Type => + return Attr_Ref; + when Field_Designated_Subtype_Indication => + return Attr_None; + when Field_Index_List => + return Attr_None; + when Field_Reference => + return Attr_None; + when Field_Nature_Declarator => + return Attr_None; + when Field_Across_Type => + return Attr_None; + when Field_Through_Type => + return Attr_None; + when Field_Target => + return Attr_None; + when Field_Waveform_Chain => + return Attr_Chain; + when Field_Guard => + return Attr_None; + when Field_Delay_Mechanism => + return Attr_None; + when Field_Reject_Time_Expression => + return Attr_None; + when Field_Sensitivity_List => + return Attr_None; + when Field_Process_Origin => + return Attr_None; + when Field_Condition_Clause => + return Attr_None; + when Field_Timeout_Clause => + return Attr_None; + when Field_Postponed_Flag => + return Attr_None; + when Field_Callees_List => + return Attr_Of_Ref; + when Field_Passive_Flag => + return Attr_None; + when Field_Resolution_Function_Flag => + return Attr_None; + when Field_Wait_State => + return Attr_None; + when Field_All_Sensitized_State => + return Attr_None; + when Field_Seen_Flag => + return Attr_None; + when Field_Pure_Flag => + return Attr_None; + when Field_Foreign_Flag => + return Attr_None; + when Field_Resolved_Flag => + return Attr_None; + when Field_Signal_Type_Flag => + return Attr_None; + when Field_Has_Signal_Flag => + return Attr_None; + when Field_Purity_State => + return Attr_None; + when Field_Elab_Flag => + return Attr_None; + when Field_Index_Constraint_Flag => + return Attr_None; + when Field_Assertion_Condition => + return Attr_None; + when Field_Report_Expression => + return Attr_None; + when Field_Severity_Expression => + return Attr_None; + when Field_Instantiated_Unit => + return Attr_None; + when Field_Generic_Map_Aspect_Chain => + return Attr_Chain; + when Field_Port_Map_Aspect_Chain => + return Attr_Chain; + when Field_Configuration_Name => + return Attr_None; + when Field_Component_Configuration => + return Attr_None; + when Field_Configuration_Specification => + return Attr_None; + when Field_Default_Binding_Indication => + return Attr_None; + when Field_Default_Configuration_Declaration => + return Attr_None; + when Field_Expression => + return Attr_None; + when Field_Allocator_Designated_Type => + return Attr_Ref; + when Field_Selected_Waveform_Chain => + return Attr_Chain; + when Field_Conditional_Waveform_Chain => + return Attr_Chain; + when Field_Guard_Expression => + return Attr_None; + when Field_Guard_Decl => + return Attr_None; + when Field_Guard_Sensitivity_List => + return Attr_None; + when Field_Block_Block_Configuration => + return Attr_None; + when Field_Package_Header => + return Attr_None; + when Field_Block_Header => + return Attr_None; + when Field_Uninstantiated_Package_Name => + return Attr_None; + when Field_Generate_Block_Configuration => + return Attr_None; + when Field_Generation_Scheme => + return Attr_None; + when Field_Condition => + return Attr_None; + when Field_Else_Clause => + return Attr_None; + when Field_Parameter_Specification => + return Attr_None; + when Field_Parent => + return Attr_Ref; + when Field_Loop_Label => + return Attr_None; + when Field_Component_Name => + return Attr_None; + when Field_Instantiation_List => + return Attr_None; + when Field_Entity_Aspect => + return Attr_None; + when Field_Default_Entity_Aspect => + return Attr_None; + when Field_Default_Generic_Map_Aspect_Chain => + return Attr_Chain; + when Field_Default_Port_Map_Aspect_Chain => + return Attr_Chain; + when Field_Binding_Indication => + return Attr_None; + when Field_Named_Entity => + return Attr_Ref; + when Field_Alias_Declaration => + return Attr_None; + when Field_Expr_Staticness => + return Attr_None; + when Field_Error_Origin => + return Attr_None; + when Field_Operand => + return Attr_None; + when Field_Left => + return Attr_None; + when Field_Right => + return Attr_None; + when Field_Unit_Name => + return Attr_None; + when Field_Name => + return Attr_None; + when Field_Group_Template_Name => + return Attr_None; + when Field_Name_Staticness => + return Attr_None; + when Field_Prefix => + return Attr_None; + when Field_Signature_Prefix => + return Attr_Ref; + when Field_Slice_Subtype => + return Attr_None; + when Field_Suffix => + return Attr_None; + when Field_Index_Subtype => + return Attr_None; + when Field_Parameter => + return Attr_None; + when Field_Actual_Type => + return Attr_None; + when Field_Associated_Interface => + return Attr_Ref; + when Field_Association_Chain => + return Attr_Chain; + when Field_Individual_Association_Chain => + return Attr_Chain; + when Field_Aggregate_Info => + return Attr_None; + when Field_Sub_Aggregate_Info => + return Attr_None; + when Field_Aggr_Dynamic_Flag => + return Attr_None; + when Field_Aggr_Min_Length => + return Attr_None; + when Field_Aggr_Low_Limit => + return Attr_None; + when Field_Aggr_High_Limit => + return Attr_None; + when Field_Aggr_Others_Flag => + return Attr_None; + when Field_Aggr_Named_Flag => + return Attr_None; + when Field_Value_Staticness => + return Attr_None; + when Field_Association_Choices_Chain => + return Attr_Chain; + when Field_Case_Statement_Alternative_Chain => + return Attr_Chain; + when Field_Choice_Staticness => + return Attr_None; + when Field_Procedure_Call => + return Attr_None; + when Field_Implementation => + return Attr_Ref; + when Field_Parameter_Association_Chain => + return Attr_Chain; + when Field_Method_Object => + return Attr_None; + when Field_Subtype_Type_Mark => + return Attr_None; + when Field_Type_Conversion_Subtype => + return Attr_None; + when Field_Type_Mark => + return Attr_None; + when Field_File_Type_Mark => + return Attr_None; + when Field_Return_Type_Mark => + return Attr_None; + when Field_Lexical_Layout => + return Attr_None; + when Field_Incomplete_Type_List => + return Attr_None; + when Field_Has_Disconnect_Flag => + return Attr_None; + when Field_Has_Active_Flag => + return Attr_None; + when Field_Is_Within_Flag => + return Attr_None; + when Field_Type_Marks_List => + return Attr_None; + when Field_Implicit_Alias_Flag => + return Attr_None; + when Field_Alias_Signature => + return Attr_None; + when Field_Attribute_Signature => + return Attr_None; + when Field_Overload_List => + return Attr_Of_Ref; + when Field_Simple_Name_Identifier => + return Attr_None; + when Field_Simple_Name_Subtype => + return Attr_None; + when Field_Protected_Type_Body => + return Attr_None; + when Field_Protected_Type_Declaration => + return Attr_None; + when Field_End_Location => + return Attr_None; + when Field_String_Id => + return Attr_None; + when Field_String_Length => + return Attr_None; + when Field_Use_Flag => + return Attr_None; + when Field_End_Has_Reserved_Id => + return Attr_None; + when Field_End_Has_Identifier => + return Attr_None; + when Field_End_Has_Postponed => + return Attr_None; + when Field_Has_Begin => + return Attr_None; + when Field_Has_Is => + return Attr_None; + when Field_Has_Pure => + return Attr_None; + when Field_Has_Body => + return Attr_None; + when Field_Has_Identifier_List => + return Attr_None; + when Field_Has_Mode => + return Attr_None; + when Field_Is_Ref => + return Attr_None; + when Field_Psl_Property => + return Attr_None; + when Field_Psl_Declaration => + return Attr_None; + when Field_Psl_Expression => + return Attr_None; + when Field_Psl_Boolean => + return Attr_None; + when Field_PSL_Clock => + return Attr_None; + when Field_PSL_NFA => + return Attr_None; + end case; + end Get_Field_Attribute; + + Fields_Of_Iir : constant Fields_Array := + ( + -- Iir_Kind_Unused + -- Iir_Kind_Error + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Expr_Staticness, + Field_Error_Origin, + Field_Type, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Design_File + Field_Design_File_Directory, + Field_Design_File_Filename, + Field_Analysis_Time_Stamp, + Field_File_Time_Stamp, + Field_Elab_Flag, + Field_File_Dependence_List, + Field_Chain, + Field_First_Design_Unit, + Field_Library, + Field_Last_Design_Unit, + -- Iir_Kind_Design_Unit + Field_Date, + Field_Design_Unit_Source_Line, + Field_Design_Unit_Source_Col, + Field_Identifier, + Field_Design_Unit_Source_Pos, + Field_End_Location, + Field_Elab_Flag, + Field_Date_State, + Field_Context_Items, + Field_Chain, + Field_Library_Unit, + Field_Analysis_Checks_List, + Field_Design_File, + Field_Hash_Chain, + Field_Dependence_List, + -- Iir_Kind_Library_Clause + Field_Identifier, + Field_Has_Identifier_List, + Field_Library_Declaration, + Field_Chain, + Field_Parent, + -- Iir_Kind_Use_Clause + Field_Selected_Name, + Field_Chain, + Field_Use_Clause_Chain, + Field_Parent, + -- Iir_Kind_Integer_Literal + Field_Value, + Field_Expr_Staticness, + Field_Literal_Origin, + Field_Type, + -- Iir_Kind_Floating_Point_Literal + Field_Fp_Value, + Field_Expr_Staticness, + Field_Literal_Origin, + Field_Type, + -- Iir_Kind_Null_Literal + Field_Expr_Staticness, + Field_Type, + -- Iir_Kind_String_Literal + Field_String_Id, + Field_String_Length, + Field_Expr_Staticness, + Field_Literal_Origin, + Field_Literal_Subtype, + Field_Type, + -- Iir_Kind_Physical_Int_Literal + Field_Value, + Field_Expr_Staticness, + Field_Literal_Origin, + Field_Unit_Name, + Field_Type, + -- Iir_Kind_Physical_Fp_Literal + Field_Fp_Value, + Field_Expr_Staticness, + Field_Literal_Origin, + Field_Unit_Name, + Field_Type, + -- Iir_Kind_Bit_String_Literal + Field_String_Id, + Field_String_Length, + Field_Bit_String_Base, + Field_Expr_Staticness, + Field_Literal_Origin, + Field_Literal_Subtype, + Field_Bit_String_0, + Field_Bit_String_1, + Field_Type, + -- Iir_Kind_Simple_Aggregate + Field_Expr_Staticness, + Field_Literal_Origin, + Field_Simple_Aggregate_List, + Field_Literal_Subtype, + Field_Type, + -- Iir_Kind_Overflow_Literal + Field_Expr_Staticness, + Field_Literal_Origin, + Field_Type, + -- Iir_Kind_Waveform_Element + Field_We_Value, + Field_Chain, + Field_Time, + -- Iir_Kind_Conditional_Waveform + Field_Condition, + Field_Chain, + Field_Waveform_Chain, + -- Iir_Kind_Association_Element_By_Expression + Field_Whole_Association_Flag, + Field_Collapse_Signal_Flag, + Field_Formal, + Field_Chain, + Field_Actual, + Field_In_Conversion, + Field_Out_Conversion, + -- Iir_Kind_Association_Element_By_Individual + Field_Whole_Association_Flag, + Field_Collapse_Signal_Flag, + Field_Formal, + Field_Chain, + Field_Actual_Type, + Field_Individual_Association_Chain, + -- Iir_Kind_Association_Element_Open + Field_Whole_Association_Flag, + Field_Collapse_Signal_Flag, + Field_Artificial_Flag, + Field_Formal, + Field_Chain, + -- Iir_Kind_Association_Element_Package + Field_Whole_Association_Flag, + Field_Collapse_Signal_Flag, + Field_Formal, + Field_Chain, + Field_Actual, + Field_Associated_Interface, + -- Iir_Kind_Choice_By_Others + Field_Same_Alternative_Flag, + Field_Chain, + Field_Associated_Expr, + Field_Associated_Chain, + Field_Parent, + -- Iir_Kind_Choice_By_Expression + Field_Same_Alternative_Flag, + Field_Choice_Staticness, + Field_Chain, + Field_Associated_Expr, + Field_Associated_Chain, + Field_Choice_Expression, + Field_Parent, + -- Iir_Kind_Choice_By_Range + Field_Same_Alternative_Flag, + Field_Choice_Staticness, + Field_Chain, + Field_Associated_Expr, + Field_Associated_Chain, + Field_Choice_Range, + Field_Parent, + -- Iir_Kind_Choice_By_None + Field_Same_Alternative_Flag, + Field_Chain, + Field_Associated_Expr, + Field_Associated_Chain, + Field_Parent, + -- Iir_Kind_Choice_By_Name + Field_Same_Alternative_Flag, + Field_Chain, + Field_Associated_Expr, + Field_Associated_Chain, + Field_Choice_Name, + Field_Parent, + -- Iir_Kind_Entity_Aspect_Entity + Field_Entity_Name, + Field_Architecture, + -- Iir_Kind_Entity_Aspect_Configuration + Field_Configuration_Name, + -- Iir_Kind_Entity_Aspect_Open + -- Iir_Kind_Block_Configuration + Field_Declaration_Chain, + Field_Chain, + Field_Configuration_Item_Chain, + Field_Block_Specification, + Field_Parent, + Field_Prev_Block_Configuration, + -- Iir_Kind_Block_Header + Field_Generic_Chain, + Field_Port_Chain, + Field_Generic_Map_Aspect_Chain, + Field_Port_Map_Aspect_Chain, + -- Iir_Kind_Component_Configuration + Field_Instantiation_List, + Field_Chain, + Field_Binding_Indication, + Field_Component_Name, + Field_Block_Configuration, + Field_Parent, + -- Iir_Kind_Binding_Indication + Field_Default_Entity_Aspect, + Field_Entity_Aspect, + Field_Default_Generic_Map_Aspect_Chain, + Field_Default_Port_Map_Aspect_Chain, + Field_Generic_Map_Aspect_Chain, + Field_Port_Map_Aspect_Chain, + -- Iir_Kind_Entity_Class + Field_Entity_Class, + Field_Chain, + -- Iir_Kind_Attribute_Value + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Spec_Chain, + Field_Chain, + Field_Type, + Field_Designated_Entity, + Field_Attribute_Specification, + Field_Base_Name, + -- Iir_Kind_Signature + Field_Type_Marks_List, + Field_Return_Type_Mark, + Field_Signature_Prefix, + -- Iir_Kind_Aggregate_Info + Field_Aggr_Min_Length, + Field_Aggr_Others_Flag, + Field_Aggr_Dynamic_Flag, + Field_Aggr_Named_Flag, + Field_Sub_Aggregate_Info, + Field_Aggr_Low_Limit, + Field_Aggr_High_Limit, + -- Iir_Kind_Procedure_Call + Field_Prefix, + Field_Parameter_Association_Chain, + Field_Method_Object, + Field_Implementation, + -- Iir_Kind_Record_Element_Constraint + Field_Identifier, + Field_Element_Position, + Field_Visible_Flag, + Field_Element_Declaration, + Field_Parent, + Field_Type, + -- Iir_Kind_Array_Element_Resolution + Field_Resolution_Indication, + -- Iir_Kind_Record_Resolution + Field_Record_Element_Resolution_Chain, + -- Iir_Kind_Record_Element_Resolution + Field_Identifier, + Field_Chain, + Field_Resolution_Indication, + -- Iir_Kind_Attribute_Specification + Field_Entity_Class, + Field_Entity_Name_List, + Field_Chain, + Field_Attribute_Value_Spec_Chain, + Field_Expression, + Field_Attribute_Designator, + Field_Attribute_Specification_Chain, + Field_Parent, + -- Iir_Kind_Disconnection_Specification + Field_Chain, + Field_Signal_List, + Field_Type_Mark, + Field_Expression, + Field_Parent, + -- Iir_Kind_Configuration_Specification + Field_Instantiation_List, + Field_Chain, + Field_Binding_Indication, + Field_Component_Name, + Field_Parent, + -- Iir_Kind_Access_Type_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Type_Staticness, + Field_Designated_Subtype_Indication, + Field_Designated_Type, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Incomplete_Type_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Type_Staticness, + Field_Incomplete_Type_List, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_File_Type_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Text_File_Flag, + Field_Type_Staticness, + Field_File_Type_Mark, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Protected_Type_Declaration + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Type_Staticness, + Field_Declaration_Chain, + Field_Protected_Type_Body, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Record_Type_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Type_Staticness, + Field_Constraint_State, + Field_Elements_Declaration_List, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Array_Type_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Index_Constraint_Flag, + Field_Type_Staticness, + Field_Constraint_State, + Field_Element_Subtype_Indication, + Field_Index_Subtype_Definition_List, + Field_Element_Subtype, + Field_Type_Declarator, + Field_Base_Type, + Field_Index_Subtype_List, + -- Iir_Kind_Array_Subtype_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Index_Constraint_Flag, + Field_Type_Staticness, + Field_Constraint_State, + Field_Subtype_Type_Mark, + Field_Resolution_Indication, + Field_Index_Constraint_List, + Field_Tolerance, + Field_Array_Element_Constraint, + Field_Element_Subtype, + Field_Type_Declarator, + Field_Base_Type, + Field_Index_Subtype_List, + -- Iir_Kind_Record_Subtype_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Type_Staticness, + Field_Constraint_State, + Field_Elements_Declaration_List, + Field_Subtype_Type_Mark, + Field_Resolution_Indication, + Field_Tolerance, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Access_Subtype_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Type_Staticness, + Field_Subtype_Type_Mark, + Field_Designated_Subtype_Indication, + Field_Designated_Type, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Physical_Subtype_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Type_Staticness, + Field_Range_Constraint, + Field_Subtype_Type_Mark, + Field_Resolution_Indication, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Floating_Subtype_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Type_Staticness, + Field_Range_Constraint, + Field_Subtype_Type_Mark, + Field_Resolution_Indication, + Field_Tolerance, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Integer_Subtype_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Type_Staticness, + Field_Range_Constraint, + Field_Subtype_Type_Mark, + Field_Resolution_Indication, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Enumeration_Subtype_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Type_Staticness, + Field_Range_Constraint, + Field_Subtype_Type_Mark, + Field_Resolution_Indication, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Enumeration_Type_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Only_Characters_Flag, + Field_Type_Staticness, + Field_Range_Constraint, + Field_Enumeration_Literal_List, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Integer_Type_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Type_Staticness, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Floating_Type_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Type_Staticness, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Physical_Type_Definition + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Type_Staticness, + Field_Unit_Chain, + Field_Type_Declarator, + Field_Base_Type, + -- Iir_Kind_Range_Expression + Field_Expr_Staticness, + Field_Direction, + Field_Left_Limit, + Field_Right_Limit, + Field_Range_Origin, + Field_Type, + -- Iir_Kind_Protected_Type_Body + Field_Identifier, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Declaration_Chain, + Field_Chain, + Field_Protected_Type_Declaration, + Field_Parent, + -- Iir_Kind_Subtype_Definition + Field_Range_Constraint, + Field_Subtype_Type_Mark, + Field_Resolution_Indication, + Field_Tolerance, + -- Iir_Kind_Scalar_Nature_Definition + Field_Reference, + Field_Nature_Declarator, + Field_Across_Type, + Field_Through_Type, + -- Iir_Kind_Overload_List + Field_Overload_List, + -- Iir_Kind_Type_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Use_Flag, + Field_Type_Definition, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Parent, + -- Iir_Kind_Anonymous_Type_Declaration + Field_Identifier, + Field_Type_Definition, + Field_Chain, + Field_Subtype_Definition, + Field_Parent, + -- Iir_Kind_Subtype_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Use_Flag, + Field_Is_Ref, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Subtype_Indication, + Field_Parent, + Field_Type, + -- Iir_Kind_Nature_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Use_Flag, + Field_Nature, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Parent, + -- Iir_Kind_Subnature_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Use_Flag, + Field_Nature, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Parent, + -- Iir_Kind_Package_Declaration + Field_Identifier, + Field_Need_Body, + Field_Visible_Flag, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Declaration_Chain, + Field_Attribute_Value_Chain, + Field_Package_Header, + Field_Parent, + Field_Package_Body, + -- Iir_Kind_Package_Instantiation_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Declaration_Chain, + Field_Attribute_Value_Chain, + Field_Uninstantiated_Package_Name, + Field_Generic_Chain, + Field_Generic_Map_Aspect_Chain, + Field_Parent, + Field_Package_Body, + -- Iir_Kind_Package_Body + Field_Identifier, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Declaration_Chain, + Field_Parent, + Field_Package, + -- Iir_Kind_Configuration_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Declaration_Chain, + Field_Entity_Name, + Field_Attribute_Value_Chain, + Field_Block_Configuration, + Field_Parent, + -- Iir_Kind_Entity_Declaration + Field_Identifier, + Field_Has_Begin, + Field_Visible_Flag, + Field_Is_Within_Flag, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Declaration_Chain, + Field_Attribute_Value_Chain, + Field_Concurrent_Statement_Chain, + Field_Generic_Chain, + Field_Port_Chain, + Field_Parent, + -- Iir_Kind_Architecture_Body + Field_Identifier, + Field_Foreign_Flag, + Field_Visible_Flag, + Field_Is_Within_Flag, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Declaration_Chain, + Field_Entity_Name, + Field_Attribute_Value_Chain, + Field_Concurrent_Statement_Chain, + Field_Default_Configuration_Declaration, + Field_Parent, + -- Iir_Kind_Package_Header + Field_Generic_Chain, + Field_Generic_Map_Aspect_Chain, + -- Iir_Kind_Unit_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Physical_Literal, + Field_Physical_Unit_Value, + Field_Parent, + Field_Type, + -- Iir_Kind_Library_Declaration + Field_Date, + Field_Library_Directory, + Field_Identifier, + Field_Visible_Flag, + Field_Design_File_Chain, + Field_Chain, + -- Iir_Kind_Component_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Use_Flag, + Field_Has_Is, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Generic_Chain, + Field_Port_Chain, + Field_Parent, + -- Iir_Kind_Attribute_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Use_Flag, + Field_Chain, + Field_Type_Mark, + Field_Parent, + Field_Type, + -- Iir_Kind_Group_Template_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Use_Flag, + Field_Entity_Class_Entry_Chain, + Field_Chain, + Field_Parent, + -- Iir_Kind_Group_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Use_Flag, + Field_Group_Constituent_List, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Group_Template_Name, + Field_Parent, + -- Iir_Kind_Element_Declaration + Field_Identifier, + Field_Element_Position, + Field_Has_Identifier_List, + Field_Visible_Flag, + Field_Is_Ref, + Field_Subtype_Indication, + Field_Type, + -- Iir_Kind_Non_Object_Alias_Declaration + Field_Identifier, + Field_Implicit_Alias_Flag, + Field_Visible_Flag, + Field_Use_Flag, + Field_Chain, + Field_Name, + Field_Alias_Signature, + Field_Parent, + -- Iir_Kind_Psl_Declaration + Field_Psl_Declaration, + Field_Identifier, + Field_PSL_Clock, + Field_PSL_NFA, + Field_Visible_Flag, + Field_Use_Flag, + Field_Chain, + Field_Parent, + -- Iir_Kind_Terminal_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Use_Flag, + Field_Nature, + Field_Chain, + Field_Parent, + -- Iir_Kind_Free_Quantity_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Use_Flag, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Default_Value, + Field_Parent, + Field_Type, + -- Iir_Kind_Across_Quantity_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Use_Flag, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Tolerance, + Field_Plus_Terminal, + Field_Minus_Terminal, + Field_Default_Value, + Field_Parent, + Field_Type, + -- Iir_Kind_Through_Quantity_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Use_Flag, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Tolerance, + Field_Plus_Terminal, + Field_Minus_Terminal, + Field_Default_Value, + Field_Parent, + Field_Type, + -- Iir_Kind_Enumeration_Literal + Field_Enum_Pos, + Field_Subprogram_Hash, + Field_Identifier, + Field_Seen_Flag, + Field_Visible_Flag, + Field_Is_Within_Flag, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Literal_Origin, + Field_Attribute_Value_Chain, + Field_Parent, + Field_Type, + Field_Enumeration_Decl, + -- Iir_Kind_Function_Declaration + Field_Subprogram_Depth, + Field_Subprogram_Hash, + Field_Overload_Number, + Field_Identifier, + Field_Seen_Flag, + Field_Pure_Flag, + Field_Foreign_Flag, + Field_Visible_Flag, + Field_Is_Within_Flag, + Field_Use_Flag, + Field_Resolution_Function_Flag, + Field_Has_Pure, + Field_Has_Body, + Field_Wait_State, + Field_All_Sensitized_State, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Interface_Declaration_Chain, + Field_Generic_Chain, + Field_Return_Type_Mark, + Field_Parent, + Field_Return_Type, + Field_Subprogram_Body, + -- Iir_Kind_Implicit_Function_Declaration + Field_Subprogram_Hash, + Field_Overload_Number, + Field_Identifier, + Field_Implicit_Definition, + Field_Seen_Flag, + Field_Pure_Flag, + Field_Visible_Flag, + Field_Is_Within_Flag, + Field_Use_Flag, + Field_Wait_State, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Interface_Declaration_Chain, + Field_Generic_Chain, + Field_Generic_Map_Aspect_Chain, + Field_Parent, + Field_Return_Type, + Field_Type_Reference, + -- Iir_Kind_Implicit_Procedure_Declaration + Field_Subprogram_Hash, + Field_Overload_Number, + Field_Identifier, + Field_Implicit_Definition, + Field_Seen_Flag, + Field_Visible_Flag, + Field_Is_Within_Flag, + Field_Use_Flag, + Field_Wait_State, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Interface_Declaration_Chain, + Field_Generic_Chain, + Field_Generic_Map_Aspect_Chain, + Field_Parent, + Field_Type_Reference, + -- Iir_Kind_Procedure_Declaration + Field_Subprogram_Depth, + Field_Subprogram_Hash, + Field_Overload_Number, + Field_Identifier, + Field_Seen_Flag, + Field_Passive_Flag, + Field_Foreign_Flag, + Field_Visible_Flag, + Field_Is_Within_Flag, + Field_Use_Flag, + Field_Has_Body, + Field_Wait_State, + Field_Purity_State, + Field_All_Sensitized_State, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Interface_Declaration_Chain, + Field_Generic_Chain, + Field_Return_Type_Mark, + Field_Parent, + Field_Subprogram_Body, + -- Iir_Kind_Function_Body + Field_Impure_Depth, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Declaration_Chain, + Field_Chain, + Field_Sequential_Statement_Chain, + Field_Parent, + Field_Subprogram_Specification, + Field_Callees_List, + -- Iir_Kind_Procedure_Body + Field_Impure_Depth, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Declaration_Chain, + Field_Chain, + Field_Sequential_Statement_Chain, + Field_Parent, + Field_Subprogram_Specification, + Field_Callees_List, + -- Iir_Kind_Object_Alias_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_After_Drivers_Flag, + Field_Use_Flag, + Field_Is_Ref, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Chain, + Field_Name, + Field_Subtype_Indication, + Field_Parent, + Field_Type, + -- Iir_Kind_File_Declaration + Field_Identifier, + Field_Has_Identifier_List, + Field_Visible_Flag, + Field_Use_Flag, + Field_Is_Ref, + Field_Has_Mode, + Field_Mode, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Chain, + Field_Attribute_Value_Chain, + Field_File_Logical_Name, + Field_File_Open_Kind, + Field_Subtype_Indication, + Field_Parent, + Field_Type, + -- Iir_Kind_Guard_Signal_Declaration + Field_Identifier, + Field_Has_Active_Flag, + Field_Visible_Flag, + Field_Use_Flag, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Signal_Kind, + Field_Guard_Expression, + Field_Attribute_Value_Chain, + Field_Guard_Sensitivity_List, + Field_Block_Statement, + Field_Parent, + Field_Type, + -- Iir_Kind_Signal_Declaration + Field_Identifier, + Field_Has_Disconnect_Flag, + Field_Has_Active_Flag, + Field_Has_Identifier_List, + Field_Visible_Flag, + Field_After_Drivers_Flag, + Field_Use_Flag, + Field_Is_Ref, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Signal_Kind, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Signal_Driver, + Field_Subtype_Indication, + Field_Default_Value, + Field_Parent, + Field_Type, + -- Iir_Kind_Variable_Declaration + Field_Identifier, + Field_Shared_Flag, + Field_Has_Identifier_List, + Field_Visible_Flag, + Field_Use_Flag, + Field_Is_Ref, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Subtype_Indication, + Field_Default_Value, + Field_Parent, + Field_Type, + -- Iir_Kind_Constant_Declaration + Field_Identifier, + Field_Deferred_Declaration_Flag, + Field_Has_Identifier_List, + Field_Visible_Flag, + Field_Use_Flag, + Field_Is_Ref, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Deferred_Declaration, + Field_Subtype_Indication, + Field_Default_Value, + Field_Parent, + Field_Type, + -- Iir_Kind_Iterator_Declaration + Field_Identifier, + Field_Has_Identifier_List, + Field_Visible_Flag, + Field_Use_Flag, + Field_Is_Ref, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Discrete_Range, + Field_Subtype_Indication, + Field_Parent, + Field_Type, + -- Iir_Kind_Interface_Constant_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_After_Drivers_Flag, + Field_Use_Flag, + Field_Is_Ref, + Field_Mode, + Field_Lexical_Layout, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Subtype_Indication, + Field_Default_Value, + Field_Parent, + Field_Type, + -- Iir_Kind_Interface_Variable_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_After_Drivers_Flag, + Field_Use_Flag, + Field_Is_Ref, + Field_Mode, + Field_Lexical_Layout, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Subtype_Indication, + Field_Default_Value, + Field_Parent, + Field_Type, + -- Iir_Kind_Interface_Signal_Declaration + Field_Identifier, + Field_Has_Disconnect_Flag, + Field_Has_Active_Flag, + Field_Open_Flag, + Field_Visible_Flag, + Field_After_Drivers_Flag, + Field_Use_Flag, + Field_Is_Ref, + Field_Mode, + Field_Lexical_Layout, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Signal_Kind, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Subtype_Indication, + Field_Default_Value, + Field_Parent, + Field_Type, + -- Iir_Kind_Interface_File_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_After_Drivers_Flag, + Field_Use_Flag, + Field_Is_Ref, + Field_Mode, + Field_Lexical_Layout, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Subtype_Indication, + Field_Default_Value, + Field_Parent, + Field_Type, + -- Iir_Kind_Interface_Package_Declaration + Field_Identifier, + Field_Visible_Flag, + Field_Declaration_Chain, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Uninstantiated_Package_Name, + Field_Generic_Chain, + Field_Generic_Map_Aspect_Chain, + Field_Parent, + -- Iir_Kind_Identity_Operator + Field_Expr_Staticness, + Field_Operand, + Field_Type, + Field_Implementation, + -- Iir_Kind_Negation_Operator + Field_Expr_Staticness, + Field_Operand, + Field_Type, + Field_Implementation, + -- Iir_Kind_Absolute_Operator + Field_Expr_Staticness, + Field_Operand, + Field_Type, + Field_Implementation, + -- Iir_Kind_Not_Operator + Field_Expr_Staticness, + Field_Operand, + Field_Type, + Field_Implementation, + -- Iir_Kind_Condition_Operator + Field_Expr_Staticness, + Field_Operand, + Field_Type, + Field_Implementation, + -- Iir_Kind_Reduction_And_Operator + Field_Expr_Staticness, + Field_Operand, + Field_Type, + Field_Implementation, + -- Iir_Kind_Reduction_Or_Operator + Field_Expr_Staticness, + Field_Operand, + Field_Type, + Field_Implementation, + -- Iir_Kind_Reduction_Nand_Operator + Field_Expr_Staticness, + Field_Operand, + Field_Type, + Field_Implementation, + -- Iir_Kind_Reduction_Nor_Operator + Field_Expr_Staticness, + Field_Operand, + Field_Type, + Field_Implementation, + -- Iir_Kind_Reduction_Xor_Operator + Field_Expr_Staticness, + Field_Operand, + Field_Type, + Field_Implementation, + -- Iir_Kind_Reduction_Xnor_Operator + Field_Expr_Staticness, + Field_Operand, + Field_Type, + Field_Implementation, + -- Iir_Kind_And_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Or_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Nand_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Nor_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Xor_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Xnor_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Equality_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Inequality_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Less_Than_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Less_Than_Or_Equal_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Greater_Than_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Greater_Than_Or_Equal_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Match_Equality_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Match_Inequality_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Match_Less_Than_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Match_Less_Than_Or_Equal_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Match_Greater_Than_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Match_Greater_Than_Or_Equal_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Sll_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Sla_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Srl_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Sra_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Rol_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Ror_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Addition_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Substraction_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Concatenation_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Multiplication_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Division_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Modulus_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Remainder_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Exponentiation_Operator + Field_Expr_Staticness, + Field_Left, + Field_Right, + Field_Type, + Field_Implementation, + -- Iir_Kind_Function_Call + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Parameter_Association_Chain, + Field_Method_Object, + Field_Type, + Field_Implementation, + Field_Base_Name, + -- Iir_Kind_Aggregate + Field_Expr_Staticness, + Field_Value_Staticness, + Field_Aggregate_Info, + Field_Association_Choices_Chain, + Field_Literal_Subtype, + Field_Type, + -- Iir_Kind_Parenthesis_Expression + Field_Expr_Staticness, + Field_Expression, + Field_Type, + -- Iir_Kind_Qualified_Expression + Field_Expr_Staticness, + Field_Type_Mark, + Field_Expression, + Field_Type, + -- Iir_Kind_Type_Conversion + Field_Expr_Staticness, + Field_Type_Conversion_Subtype, + Field_Type_Mark, + Field_Expression, + Field_Type, + -- Iir_Kind_Allocator_By_Expression + Field_Expr_Staticness, + Field_Expression, + Field_Type, + Field_Allocator_Designated_Type, + -- Iir_Kind_Allocator_By_Subtype + Field_Expr_Staticness, + Field_Subtype_Indication, + Field_Type, + Field_Allocator_Designated_Type, + -- Iir_Kind_Selected_Element + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + Field_Selected_Element, + Field_Base_Name, + -- Iir_Kind_Dereference + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Implicit_Dereference + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Slice_Name + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Suffix, + Field_Slice_Subtype, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Indexed_Name + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Index_List, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Psl_Expression + Field_Psl_Expression, + Field_Type, + -- Iir_Kind_Sensitized_Process_Statement + Field_Label, + Field_Seen_Flag, + Field_End_Has_Postponed, + Field_Passive_Flag, + Field_Postponed_Flag, + Field_Visible_Flag, + Field_Is_Within_Flag, + Field_Has_Is, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Wait_State, + Field_Declaration_Chain, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Sequential_Statement_Chain, + Field_Sensitivity_List, + Field_Process_Origin, + Field_Parent, + Field_Callees_List, + -- Iir_Kind_Process_Statement + Field_Label, + Field_Seen_Flag, + Field_End_Has_Postponed, + Field_Passive_Flag, + Field_Postponed_Flag, + Field_Visible_Flag, + Field_Is_Within_Flag, + Field_Has_Is, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Wait_State, + Field_Declaration_Chain, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Sequential_Statement_Chain, + Field_Process_Origin, + Field_Parent, + Field_Callees_List, + -- Iir_Kind_Concurrent_Conditional_Signal_Assignment + Field_Delay_Mechanism, + Field_Label, + Field_Postponed_Flag, + Field_Visible_Flag, + Field_Guarded_Target_State, + Field_Target, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Reject_Time_Expression, + Field_Conditional_Waveform_Chain, + Field_Guard, + Field_Parent, + -- Iir_Kind_Concurrent_Selected_Signal_Assignment + Field_Delay_Mechanism, + Field_Label, + Field_Postponed_Flag, + Field_Visible_Flag, + Field_Guarded_Target_State, + Field_Target, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Expression, + Field_Reject_Time_Expression, + Field_Selected_Waveform_Chain, + Field_Guard, + Field_Parent, + -- Iir_Kind_Concurrent_Assertion_Statement + Field_Label, + Field_Postponed_Flag, + Field_Visible_Flag, + Field_Assertion_Condition, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Severity_Expression, + Field_Report_Expression, + Field_Parent, + -- Iir_Kind_Psl_Default_Clock + Field_Psl_Boolean, + Field_Label, + Field_Chain, + Field_Parent, + -- Iir_Kind_Psl_Assert_Statement + Field_Psl_Property, + Field_Label, + Field_PSL_Clock, + Field_PSL_NFA, + Field_Visible_Flag, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Severity_Expression, + Field_Report_Expression, + Field_Parent, + -- Iir_Kind_Psl_Cover_Statement + Field_Psl_Property, + Field_Label, + Field_PSL_Clock, + Field_PSL_NFA, + Field_Visible_Flag, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Severity_Expression, + Field_Report_Expression, + Field_Parent, + -- Iir_Kind_Concurrent_Procedure_Call_Statement + Field_Label, + Field_Postponed_Flag, + Field_Visible_Flag, + Field_Procedure_Call, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Parent, + -- Iir_Kind_Block_Statement + Field_Label, + Field_Visible_Flag, + Field_Is_Within_Flag, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Declaration_Chain, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Concurrent_Statement_Chain, + Field_Block_Block_Configuration, + Field_Block_Header, + Field_Guard_Decl, + Field_Parent, + -- Iir_Kind_Generate_Statement + Field_Label, + Field_Has_Begin, + Field_Visible_Flag, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_Declaration_Chain, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Concurrent_Statement_Chain, + Field_Generation_Scheme, + Field_Generate_Block_Configuration, + Field_Parent, + -- Iir_Kind_Component_Instantiation_Statement + Field_Label, + Field_Visible_Flag, + Field_Instantiated_Unit, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Default_Binding_Indication, + Field_Component_Configuration, + Field_Configuration_Specification, + Field_Generic_Map_Aspect_Chain, + Field_Port_Map_Aspect_Chain, + Field_Parent, + -- Iir_Kind_Simple_Simultaneous_Statement + Field_Label, + Field_Visible_Flag, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Simultaneous_Left, + Field_Simultaneous_Right, + Field_Tolerance, + Field_Parent, + -- Iir_Kind_Signal_Assignment_Statement + Field_Delay_Mechanism, + Field_Label, + Field_Visible_Flag, + Field_Guarded_Target_State, + Field_Target, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Waveform_Chain, + Field_Reject_Time_Expression, + Field_Parent, + -- Iir_Kind_Null_Statement + Field_Label, + Field_Visible_Flag, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Parent, + -- Iir_Kind_Assertion_Statement + Field_Label, + Field_Visible_Flag, + Field_Assertion_Condition, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Severity_Expression, + Field_Report_Expression, + Field_Parent, + -- Iir_Kind_Report_Statement + Field_Label, + Field_Visible_Flag, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Severity_Expression, + Field_Report_Expression, + Field_Parent, + -- Iir_Kind_Wait_Statement + Field_Label, + Field_Visible_Flag, + Field_Timeout_Clause, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Condition_Clause, + Field_Sensitivity_List, + Field_Parent, + -- Iir_Kind_Variable_Assignment_Statement + Field_Label, + Field_Visible_Flag, + Field_Target, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Expression, + Field_Parent, + -- Iir_Kind_Return_Statement + Field_Label, + Field_Visible_Flag, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Expression, + Field_Parent, + Field_Type, + -- Iir_Kind_For_Loop_Statement + Field_Label, + Field_Visible_Flag, + Field_Is_Within_Flag, + Field_End_Has_Identifier, + Field_Parameter_Specification, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Sequential_Statement_Chain, + Field_Parent, + -- Iir_Kind_While_Loop_Statement + Field_Label, + Field_Visible_Flag, + Field_End_Has_Identifier, + Field_Condition, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Sequential_Statement_Chain, + Field_Parent, + -- Iir_Kind_Next_Statement + Field_Label, + Field_Visible_Flag, + Field_Condition, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Loop_Label, + Field_Parent, + -- Iir_Kind_Exit_Statement + Field_Label, + Field_Visible_Flag, + Field_Condition, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Loop_Label, + Field_Parent, + -- Iir_Kind_Case_Statement + Field_Label, + Field_Visible_Flag, + Field_End_Has_Identifier, + Field_Case_Statement_Alternative_Chain, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Expression, + Field_Parent, + -- Iir_Kind_Procedure_Call_Statement + Field_Label, + Field_Visible_Flag, + Field_Procedure_Call, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Parent, + -- Iir_Kind_If_Statement + Field_Label, + Field_Visible_Flag, + Field_End_Has_Identifier, + Field_Condition, + Field_Chain, + Field_Attribute_Value_Chain, + Field_Sequential_Statement_Chain, + Field_Else_Clause, + Field_Parent, + -- Iir_Kind_Elsif + Field_End_Has_Identifier, + Field_Condition, + Field_Sequential_Statement_Chain, + Field_Else_Clause, + Field_Parent, + -- Iir_Kind_Character_Literal + Field_Identifier, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Alias_Declaration, + Field_Type, + Field_Named_Entity, + Field_Base_Name, + -- Iir_Kind_Simple_Name + Field_Identifier, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Alias_Declaration, + Field_Type, + Field_Named_Entity, + Field_Base_Name, + -- Iir_Kind_Selected_Name + Field_Identifier, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Alias_Declaration, + Field_Type, + Field_Named_Entity, + Field_Base_Name, + -- Iir_Kind_Operator_Symbol + Field_Identifier, + Field_Alias_Declaration, + Field_Type, + Field_Named_Entity, + Field_Base_Name, + -- Iir_Kind_Selected_By_All_Name + Field_Expr_Staticness, + Field_Prefix, + Field_Type, + Field_Named_Entity, + Field_Base_Name, + -- Iir_Kind_Parenthesis_Name + Field_Prefix, + Field_Association_Chain, + Field_Type, + Field_Named_Entity, + -- Iir_Kind_Base_Attribute + Field_Prefix, + Field_Type, + -- Iir_Kind_Left_Type_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Right_Type_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + Field_Base_Name, + -- Iir_Kind_High_Type_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Low_Type_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Ascending_Type_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Image_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Value_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Pos_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Val_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Succ_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Pred_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Leftof_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Rightof_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Delayed_Attribute + Field_Has_Active_Flag, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Chain, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Stable_Attribute + Field_Has_Active_Flag, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Chain, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Quiet_Attribute + Field_Has_Active_Flag, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Chain, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Transaction_Attribute + Field_Has_Active_Flag, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Chain, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Event_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + -- Iir_Kind_Active_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + -- Iir_Kind_Last_Event_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + -- Iir_Kind_Last_Active_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + -- Iir_Kind_Last_Value_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + -- Iir_Kind_Driving_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + -- Iir_Kind_Driving_Value_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + -- Iir_Kind_Behavior_Attribute + -- Iir_Kind_Structure_Attribute + -- Iir_Kind_Simple_Name_Attribute + Field_Simple_Name_Identifier, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Simple_Name_Subtype, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Instance_Name_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Path_Name_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Left_Array_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Index_Subtype, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Right_Array_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Index_Subtype, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_High_Array_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Index_Subtype, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Low_Array_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Index_Subtype, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Length_Array_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Index_Subtype, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Ascending_Array_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Index_Subtype, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Range_Array_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Index_Subtype, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Reverse_Range_Array_Attribute + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Index_Subtype, + Field_Parameter, + Field_Type, + Field_Base_Name, + -- Iir_Kind_Attribute_Name + Field_Identifier, + Field_Expr_Staticness, + Field_Name_Staticness, + Field_Prefix, + Field_Attribute_Signature, + Field_Type, + Field_Named_Entity, + Field_Base_Name + ); + + Fields_Of_Iir_Last : constant array (Iir_Kind) of Integer := + ( + Iir_Kind_Unused => -1, + Iir_Kind_Error => 7, + Iir_Kind_Design_File => 17, + Iir_Kind_Design_Unit => 32, + Iir_Kind_Library_Clause => 37, + Iir_Kind_Use_Clause => 41, + Iir_Kind_Integer_Literal => 45, + Iir_Kind_Floating_Point_Literal => 49, + Iir_Kind_Null_Literal => 51, + Iir_Kind_String_Literal => 57, + Iir_Kind_Physical_Int_Literal => 62, + Iir_Kind_Physical_Fp_Literal => 67, + Iir_Kind_Bit_String_Literal => 76, + Iir_Kind_Simple_Aggregate => 81, + Iir_Kind_Overflow_Literal => 84, + Iir_Kind_Waveform_Element => 87, + Iir_Kind_Conditional_Waveform => 90, + Iir_Kind_Association_Element_By_Expression => 97, + Iir_Kind_Association_Element_By_Individual => 103, + Iir_Kind_Association_Element_Open => 108, + Iir_Kind_Association_Element_Package => 114, + Iir_Kind_Choice_By_Others => 119, + Iir_Kind_Choice_By_Expression => 126, + Iir_Kind_Choice_By_Range => 133, + Iir_Kind_Choice_By_None => 138, + Iir_Kind_Choice_By_Name => 144, + Iir_Kind_Entity_Aspect_Entity => 146, + Iir_Kind_Entity_Aspect_Configuration => 147, + Iir_Kind_Entity_Aspect_Open => 147, + Iir_Kind_Block_Configuration => 153, + Iir_Kind_Block_Header => 157, + Iir_Kind_Component_Configuration => 163, + Iir_Kind_Binding_Indication => 169, + Iir_Kind_Entity_Class => 171, + Iir_Kind_Attribute_Value => 179, + Iir_Kind_Signature => 182, + Iir_Kind_Aggregate_Info => 189, + Iir_Kind_Procedure_Call => 193, + Iir_Kind_Record_Element_Constraint => 199, + Iir_Kind_Array_Element_Resolution => 200, + Iir_Kind_Record_Resolution => 201, + Iir_Kind_Record_Element_Resolution => 204, + Iir_Kind_Attribute_Specification => 212, + Iir_Kind_Disconnection_Specification => 217, + Iir_Kind_Configuration_Specification => 222, + Iir_Kind_Access_Type_Definition => 229, + Iir_Kind_Incomplete_Type_Definition => 236, + Iir_Kind_File_Type_Definition => 243, + Iir_Kind_Protected_Type_Declaration => 252, + Iir_Kind_Record_Type_Definition => 262, + Iir_Kind_Array_Type_Definition => 274, + Iir_Kind_Array_Subtype_Definition => 289, + Iir_Kind_Record_Subtype_Definition => 300, + Iir_Kind_Access_Subtype_Definition => 308, + Iir_Kind_Physical_Subtype_Definition => 317, + Iir_Kind_Floating_Subtype_Definition => 327, + Iir_Kind_Integer_Subtype_Definition => 336, + Iir_Kind_Enumeration_Subtype_Definition => 345, + Iir_Kind_Enumeration_Type_Definition => 354, + Iir_Kind_Integer_Type_Definition => 360, + Iir_Kind_Floating_Type_Definition => 366, + Iir_Kind_Physical_Type_Definition => 375, + Iir_Kind_Range_Expression => 381, + Iir_Kind_Protected_Type_Body => 388, + Iir_Kind_Subtype_Definition => 392, + Iir_Kind_Scalar_Nature_Definition => 396, + Iir_Kind_Overload_List => 397, + Iir_Kind_Type_Declaration => 404, + Iir_Kind_Anonymous_Type_Declaration => 409, + Iir_Kind_Subtype_Declaration => 418, + Iir_Kind_Nature_Declaration => 425, + Iir_Kind_Subnature_Declaration => 432, + Iir_Kind_Package_Declaration => 442, + Iir_Kind_Package_Instantiation_Declaration => 453, + Iir_Kind_Package_Body => 459, + Iir_Kind_Configuration_Declaration => 468, + Iir_Kind_Entity_Declaration => 480, + Iir_Kind_Architecture_Body => 492, + Iir_Kind_Package_Header => 494, + Iir_Kind_Unit_Declaration => 504, + Iir_Kind_Library_Declaration => 510, + Iir_Kind_Component_Declaration => 521, + Iir_Kind_Attribute_Declaration => 528, + Iir_Kind_Group_Template_Declaration => 534, + Iir_Kind_Group_Declaration => 542, + Iir_Kind_Element_Declaration => 549, + Iir_Kind_Non_Object_Alias_Declaration => 557, + Iir_Kind_Psl_Declaration => 565, + Iir_Kind_Terminal_Declaration => 571, + Iir_Kind_Free_Quantity_Declaration => 581, + Iir_Kind_Across_Quantity_Declaration => 594, + Iir_Kind_Through_Quantity_Declaration => 607, + Iir_Kind_Enumeration_Literal => 620, + Iir_Kind_Function_Declaration => 643, + Iir_Kind_Implicit_Function_Declaration => 661, + Iir_Kind_Implicit_Procedure_Declaration => 677, + Iir_Kind_Procedure_Declaration => 698, + Iir_Kind_Function_Body => 707, + Iir_Kind_Procedure_Body => 716, + Iir_Kind_Object_Alias_Declaration => 728, + Iir_Kind_File_Declaration => 744, + Iir_Kind_Guard_Signal_Declaration => 757, + Iir_Kind_Signal_Declaration => 775, + Iir_Kind_Variable_Declaration => 789, + Iir_Kind_Constant_Declaration => 804, + Iir_Kind_Iterator_Declaration => 817, + Iir_Kind_Interface_Constant_Declaration => 832, + Iir_Kind_Interface_Variable_Declaration => 847, + Iir_Kind_Interface_Signal_Declaration => 866, + Iir_Kind_Interface_File_Declaration => 881, + Iir_Kind_Interface_Package_Declaration => 890, + Iir_Kind_Identity_Operator => 894, + Iir_Kind_Negation_Operator => 898, + Iir_Kind_Absolute_Operator => 902, + Iir_Kind_Not_Operator => 906, + Iir_Kind_Condition_Operator => 910, + Iir_Kind_Reduction_And_Operator => 914, + Iir_Kind_Reduction_Or_Operator => 918, + Iir_Kind_Reduction_Nand_Operator => 922, + Iir_Kind_Reduction_Nor_Operator => 926, + Iir_Kind_Reduction_Xor_Operator => 930, + Iir_Kind_Reduction_Xnor_Operator => 934, + Iir_Kind_And_Operator => 939, + Iir_Kind_Or_Operator => 944, + Iir_Kind_Nand_Operator => 949, + Iir_Kind_Nor_Operator => 954, + Iir_Kind_Xor_Operator => 959, + Iir_Kind_Xnor_Operator => 964, + Iir_Kind_Equality_Operator => 969, + Iir_Kind_Inequality_Operator => 974, + Iir_Kind_Less_Than_Operator => 979, + Iir_Kind_Less_Than_Or_Equal_Operator => 984, + Iir_Kind_Greater_Than_Operator => 989, + Iir_Kind_Greater_Than_Or_Equal_Operator => 994, + Iir_Kind_Match_Equality_Operator => 999, + Iir_Kind_Match_Inequality_Operator => 1004, + Iir_Kind_Match_Less_Than_Operator => 1009, + Iir_Kind_Match_Less_Than_Or_Equal_Operator => 1014, + Iir_Kind_Match_Greater_Than_Operator => 1019, + Iir_Kind_Match_Greater_Than_Or_Equal_Operator => 1024, + Iir_Kind_Sll_Operator => 1029, + Iir_Kind_Sla_Operator => 1034, + Iir_Kind_Srl_Operator => 1039, + Iir_Kind_Sra_Operator => 1044, + Iir_Kind_Rol_Operator => 1049, + Iir_Kind_Ror_Operator => 1054, + Iir_Kind_Addition_Operator => 1059, + Iir_Kind_Substraction_Operator => 1064, + Iir_Kind_Concatenation_Operator => 1069, + Iir_Kind_Multiplication_Operator => 1074, + Iir_Kind_Division_Operator => 1079, + Iir_Kind_Modulus_Operator => 1084, + Iir_Kind_Remainder_Operator => 1089, + Iir_Kind_Exponentiation_Operator => 1094, + Iir_Kind_Function_Call => 1102, + Iir_Kind_Aggregate => 1108, + Iir_Kind_Parenthesis_Expression => 1111, + Iir_Kind_Qualified_Expression => 1115, + Iir_Kind_Type_Conversion => 1120, + Iir_Kind_Allocator_By_Expression => 1124, + Iir_Kind_Allocator_By_Subtype => 1128, + Iir_Kind_Selected_Element => 1134, + Iir_Kind_Dereference => 1139, + Iir_Kind_Implicit_Dereference => 1144, + Iir_Kind_Slice_Name => 1151, + Iir_Kind_Indexed_Name => 1157, + Iir_Kind_Psl_Expression => 1159, + Iir_Kind_Sensitized_Process_Statement => 1178, + Iir_Kind_Process_Statement => 1196, + Iir_Kind_Concurrent_Conditional_Signal_Assignment => 1208, + Iir_Kind_Concurrent_Selected_Signal_Assignment => 1221, + Iir_Kind_Concurrent_Assertion_Statement => 1230, + Iir_Kind_Psl_Default_Clock => 1234, + Iir_Kind_Psl_Assert_Statement => 1244, + Iir_Kind_Psl_Cover_Statement => 1254, + Iir_Kind_Concurrent_Procedure_Call_Statement => 1261, + Iir_Kind_Block_Statement => 1274, + Iir_Kind_Generate_Statement => 1286, + Iir_Kind_Component_Instantiation_Statement => 1297, + Iir_Kind_Simple_Simultaneous_Statement => 1305, + Iir_Kind_Signal_Assignment_Statement => 1315, + Iir_Kind_Null_Statement => 1320, + Iir_Kind_Assertion_Statement => 1328, + Iir_Kind_Report_Statement => 1335, + Iir_Kind_Wait_Statement => 1343, + Iir_Kind_Variable_Assignment_Statement => 1350, + Iir_Kind_Return_Statement => 1357, + Iir_Kind_For_Loop_Statement => 1366, + Iir_Kind_While_Loop_Statement => 1374, + Iir_Kind_Next_Statement => 1381, + Iir_Kind_Exit_Statement => 1388, + Iir_Kind_Case_Statement => 1396, + Iir_Kind_Procedure_Call_Statement => 1402, + Iir_Kind_If_Statement => 1411, + Iir_Kind_Elsif => 1416, + Iir_Kind_Character_Literal => 1423, + Iir_Kind_Simple_Name => 1430, + Iir_Kind_Selected_Name => 1438, + Iir_Kind_Operator_Symbol => 1443, + Iir_Kind_Selected_By_All_Name => 1448, + Iir_Kind_Parenthesis_Name => 1452, + Iir_Kind_Base_Attribute => 1454, + Iir_Kind_Left_Type_Attribute => 1459, + Iir_Kind_Right_Type_Attribute => 1464, + Iir_Kind_High_Type_Attribute => 1469, + Iir_Kind_Low_Type_Attribute => 1474, + Iir_Kind_Ascending_Type_Attribute => 1479, + Iir_Kind_Image_Attribute => 1485, + Iir_Kind_Value_Attribute => 1491, + Iir_Kind_Pos_Attribute => 1497, + Iir_Kind_Val_Attribute => 1503, + Iir_Kind_Succ_Attribute => 1509, + Iir_Kind_Pred_Attribute => 1515, + Iir_Kind_Leftof_Attribute => 1521, + Iir_Kind_Rightof_Attribute => 1527, + Iir_Kind_Delayed_Attribute => 1535, + Iir_Kind_Stable_Attribute => 1543, + Iir_Kind_Quiet_Attribute => 1551, + Iir_Kind_Transaction_Attribute => 1559, + Iir_Kind_Event_Attribute => 1563, + Iir_Kind_Active_Attribute => 1567, + Iir_Kind_Last_Event_Attribute => 1571, + Iir_Kind_Last_Active_Attribute => 1575, + Iir_Kind_Last_Value_Attribute => 1579, + Iir_Kind_Driving_Attribute => 1583, + Iir_Kind_Driving_Value_Attribute => 1587, + Iir_Kind_Behavior_Attribute => 1587, + Iir_Kind_Structure_Attribute => 1587, + Iir_Kind_Simple_Name_Attribute => 1594, + Iir_Kind_Instance_Name_Attribute => 1599, + Iir_Kind_Path_Name_Attribute => 1604, + Iir_Kind_Left_Array_Attribute => 1611, + Iir_Kind_Right_Array_Attribute => 1618, + Iir_Kind_High_Array_Attribute => 1625, + Iir_Kind_Low_Array_Attribute => 1632, + Iir_Kind_Length_Array_Attribute => 1639, + Iir_Kind_Ascending_Array_Attribute => 1646, + Iir_Kind_Range_Array_Attribute => 1653, + Iir_Kind_Reverse_Range_Array_Attribute => 1660, + Iir_Kind_Attribute_Name => 1668 + ); + + function Get_Fields (K : Iir_Kind) return Fields_Array + is + First : Natural; + Last : Integer; + begin + if K = Iir_Kind'First then + First := Fields_Of_Iir'First; + else + First := Fields_Of_Iir_Last (Iir_Kind'Pred (K)) + 1; + end if; + Last := Fields_Of_Iir_Last (K); + return Fields_Of_Iir (First .. Last); + end Get_Fields; + + function Get_Base_Type + (N : Iir; F : Fields_Enum) return Base_Type is + begin + pragma Assert (Fields_Type (F) = Type_Base_Type); + case F is + when Field_Bit_String_Base => + return Get_Bit_String_Base (N); + when others => + raise Internal_Error; + end case; + end Get_Base_Type; + + procedure Set_Base_Type + (N : Iir; F : Fields_Enum; V: Base_Type) is + begin + pragma Assert (Fields_Type (F) = Type_Base_Type); + case F is + when Field_Bit_String_Base => + Set_Bit_String_Base (N, V); + when others => + raise Internal_Error; + end case; + end Set_Base_Type; + + function Get_Boolean + (N : Iir; F : Fields_Enum) return Boolean is + begin + pragma Assert (Fields_Type (F) = Type_Boolean); + case F is + when Field_Whole_Association_Flag => + return Get_Whole_Association_Flag (N); + when Field_Collapse_Signal_Flag => + return Get_Collapse_Signal_Flag (N); + when Field_Artificial_Flag => + return Get_Artificial_Flag (N); + when Field_Open_Flag => + return Get_Open_Flag (N); + when Field_After_Drivers_Flag => + return Get_After_Drivers_Flag (N); + when Field_Same_Alternative_Flag => + return Get_Same_Alternative_Flag (N); + when Field_Need_Body => + return Get_Need_Body (N); + when Field_Deferred_Declaration_Flag => + return Get_Deferred_Declaration_Flag (N); + when Field_Shared_Flag => + return Get_Shared_Flag (N); + when Field_Visible_Flag => + return Get_Visible_Flag (N); + when Field_Text_File_Flag => + return Get_Text_File_Flag (N); + when Field_Only_Characters_Flag => + return Get_Only_Characters_Flag (N); + when Field_Postponed_Flag => + return Get_Postponed_Flag (N); + when Field_Passive_Flag => + return Get_Passive_Flag (N); + when Field_Resolution_Function_Flag => + return Get_Resolution_Function_Flag (N); + when Field_Seen_Flag => + return Get_Seen_Flag (N); + when Field_Pure_Flag => + return Get_Pure_Flag (N); + when Field_Foreign_Flag => + return Get_Foreign_Flag (N); + when Field_Resolved_Flag => + return Get_Resolved_Flag (N); + when Field_Signal_Type_Flag => + return Get_Signal_Type_Flag (N); + when Field_Has_Signal_Flag => + return Get_Has_Signal_Flag (N); + when Field_Elab_Flag => + return Get_Elab_Flag (N); + when Field_Index_Constraint_Flag => + return Get_Index_Constraint_Flag (N); + when Field_Aggr_Dynamic_Flag => + return Get_Aggr_Dynamic_Flag (N); + when Field_Aggr_Others_Flag => + return Get_Aggr_Others_Flag (N); + when Field_Aggr_Named_Flag => + return Get_Aggr_Named_Flag (N); + when Field_Has_Disconnect_Flag => + return Get_Has_Disconnect_Flag (N); + when Field_Has_Active_Flag => + return Get_Has_Active_Flag (N); + when Field_Is_Within_Flag => + return Get_Is_Within_Flag (N); + when Field_Implicit_Alias_Flag => + return Get_Implicit_Alias_Flag (N); + when Field_Use_Flag => + return Get_Use_Flag (N); + when Field_End_Has_Reserved_Id => + return Get_End_Has_Reserved_Id (N); + when Field_End_Has_Identifier => + return Get_End_Has_Identifier (N); + when Field_End_Has_Postponed => + return Get_End_Has_Postponed (N); + when Field_Has_Begin => + return Get_Has_Begin (N); + when Field_Has_Is => + return Get_Has_Is (N); + when Field_Has_Pure => + return Get_Has_Pure (N); + when Field_Has_Body => + return Get_Has_Body (N); + when Field_Has_Identifier_List => + return Get_Has_Identifier_List (N); + when Field_Has_Mode => + return Get_Has_Mode (N); + when Field_Is_Ref => + return Get_Is_Ref (N); + when others => + raise Internal_Error; + end case; + end Get_Boolean; + + procedure Set_Boolean + (N : Iir; F : Fields_Enum; V: Boolean) is + begin + pragma Assert (Fields_Type (F) = Type_Boolean); + case F is + when Field_Whole_Association_Flag => + Set_Whole_Association_Flag (N, V); + when Field_Collapse_Signal_Flag => + Set_Collapse_Signal_Flag (N, V); + when Field_Artificial_Flag => + Set_Artificial_Flag (N, V); + when Field_Open_Flag => + Set_Open_Flag (N, V); + when Field_After_Drivers_Flag => + Set_After_Drivers_Flag (N, V); + when Field_Same_Alternative_Flag => + Set_Same_Alternative_Flag (N, V); + when Field_Need_Body => + Set_Need_Body (N, V); + when Field_Deferred_Declaration_Flag => + Set_Deferred_Declaration_Flag (N, V); + when Field_Shared_Flag => + Set_Shared_Flag (N, V); + when Field_Visible_Flag => + Set_Visible_Flag (N, V); + when Field_Text_File_Flag => + Set_Text_File_Flag (N, V); + when Field_Only_Characters_Flag => + Set_Only_Characters_Flag (N, V); + when Field_Postponed_Flag => + Set_Postponed_Flag (N, V); + when Field_Passive_Flag => + Set_Passive_Flag (N, V); + when Field_Resolution_Function_Flag => + Set_Resolution_Function_Flag (N, V); + when Field_Seen_Flag => + Set_Seen_Flag (N, V); + when Field_Pure_Flag => + Set_Pure_Flag (N, V); + when Field_Foreign_Flag => + Set_Foreign_Flag (N, V); + when Field_Resolved_Flag => + Set_Resolved_Flag (N, V); + when Field_Signal_Type_Flag => + Set_Signal_Type_Flag (N, V); + when Field_Has_Signal_Flag => + Set_Has_Signal_Flag (N, V); + when Field_Elab_Flag => + Set_Elab_Flag (N, V); + when Field_Index_Constraint_Flag => + Set_Index_Constraint_Flag (N, V); + when Field_Aggr_Dynamic_Flag => + Set_Aggr_Dynamic_Flag (N, V); + when Field_Aggr_Others_Flag => + Set_Aggr_Others_Flag (N, V); + when Field_Aggr_Named_Flag => + Set_Aggr_Named_Flag (N, V); + when Field_Has_Disconnect_Flag => + Set_Has_Disconnect_Flag (N, V); + when Field_Has_Active_Flag => + Set_Has_Active_Flag (N, V); + when Field_Is_Within_Flag => + Set_Is_Within_Flag (N, V); + when Field_Implicit_Alias_Flag => + Set_Implicit_Alias_Flag (N, V); + when Field_Use_Flag => + Set_Use_Flag (N, V); + when Field_End_Has_Reserved_Id => + Set_End_Has_Reserved_Id (N, V); + when Field_End_Has_Identifier => + Set_End_Has_Identifier (N, V); + when Field_End_Has_Postponed => + Set_End_Has_Postponed (N, V); + when Field_Has_Begin => + Set_Has_Begin (N, V); + when Field_Has_Is => + Set_Has_Is (N, V); + when Field_Has_Pure => + Set_Has_Pure (N, V); + when Field_Has_Body => + Set_Has_Body (N, V); + when Field_Has_Identifier_List => + Set_Has_Identifier_List (N, V); + when Field_Has_Mode => + Set_Has_Mode (N, V); + when Field_Is_Ref => + Set_Is_Ref (N, V); + when others => + raise Internal_Error; + end case; + end Set_Boolean; + + function Get_Date_State_Type + (N : Iir; F : Fields_Enum) return Date_State_Type is + begin + pragma Assert (Fields_Type (F) = Type_Date_State_Type); + case F is + when Field_Date_State => + return Get_Date_State (N); + when others => + raise Internal_Error; + end case; + end Get_Date_State_Type; + + procedure Set_Date_State_Type + (N : Iir; F : Fields_Enum; V: Date_State_Type) is + begin + pragma Assert (Fields_Type (F) = Type_Date_State_Type); + case F is + when Field_Date_State => + Set_Date_State (N, V); + when others => + raise Internal_Error; + end case; + end Set_Date_State_Type; + + function Get_Date_Type + (N : Iir; F : Fields_Enum) return Date_Type is + begin + pragma Assert (Fields_Type (F) = Type_Date_Type); + case F is + when Field_Date => + return Get_Date (N); + when others => + raise Internal_Error; + end case; + end Get_Date_Type; + + procedure Set_Date_Type + (N : Iir; F : Fields_Enum; V: Date_Type) is + begin + pragma Assert (Fields_Type (F) = Type_Date_Type); + case F is + when Field_Date => + Set_Date (N, V); + when others => + raise Internal_Error; + end case; + end Set_Date_Type; + + function Get_Iir + (N : Iir; F : Fields_Enum) return Iir is + begin + pragma Assert (Fields_Type (F) = Type_Iir); + case F is + when Field_First_Design_Unit => + return Get_First_Design_Unit (N); + when Field_Last_Design_Unit => + return Get_Last_Design_Unit (N); + when Field_Library_Declaration => + return Get_Library_Declaration (N); + when Field_Library => + return Get_Library (N); + when Field_Design_File => + return Get_Design_File (N); + when Field_Design_File_Chain => + return Get_Design_File_Chain (N); + when Field_Context_Items => + return Get_Context_Items (N); + when Field_Library_Unit => + return Get_Library_Unit (N); + when Field_Hash_Chain => + return Get_Hash_Chain (N); + when Field_Physical_Literal => + return Get_Physical_Literal (N); + when Field_Physical_Unit_Value => + return Get_Physical_Unit_Value (N); + when Field_Enumeration_Decl => + return Get_Enumeration_Decl (N); + when Field_Bit_String_0 => + return Get_Bit_String_0 (N); + when Field_Bit_String_1 => + return Get_Bit_String_1 (N); + when Field_Literal_Origin => + return Get_Literal_Origin (N); + when Field_Range_Origin => + return Get_Range_Origin (N); + when Field_Literal_Subtype => + return Get_Literal_Subtype (N); + when Field_Attribute_Designator => + return Get_Attribute_Designator (N); + when Field_Attribute_Specification_Chain => + return Get_Attribute_Specification_Chain (N); + when Field_Attribute_Specification => + return Get_Attribute_Specification (N); + when Field_Designated_Entity => + return Get_Designated_Entity (N); + when Field_Formal => + return Get_Formal (N); + when Field_Actual => + return Get_Actual (N); + when Field_In_Conversion => + return Get_In_Conversion (N); + when Field_Out_Conversion => + return Get_Out_Conversion (N); + when Field_We_Value => + return Get_We_Value (N); + when Field_Time => + return Get_Time (N); + when Field_Associated_Expr => + return Get_Associated_Expr (N); + when Field_Associated_Chain => + return Get_Associated_Chain (N); + when Field_Choice_Name => + return Get_Choice_Name (N); + when Field_Choice_Expression => + return Get_Choice_Expression (N); + when Field_Choice_Range => + return Get_Choice_Range (N); + when Field_Architecture => + return Get_Architecture (N); + when Field_Block_Specification => + return Get_Block_Specification (N); + when Field_Prev_Block_Configuration => + return Get_Prev_Block_Configuration (N); + when Field_Configuration_Item_Chain => + return Get_Configuration_Item_Chain (N); + when Field_Attribute_Value_Chain => + return Get_Attribute_Value_Chain (N); + when Field_Spec_Chain => + return Get_Spec_Chain (N); + when Field_Attribute_Value_Spec_Chain => + return Get_Attribute_Value_Spec_Chain (N); + when Field_Entity_Name => + return Get_Entity_Name (N); + when Field_Package => + return Get_Package (N); + when Field_Package_Body => + return Get_Package_Body (N); + when Field_Block_Configuration => + return Get_Block_Configuration (N); + when Field_Concurrent_Statement_Chain => + return Get_Concurrent_Statement_Chain (N); + when Field_Chain => + return Get_Chain (N); + when Field_Port_Chain => + return Get_Port_Chain (N); + when Field_Generic_Chain => + return Get_Generic_Chain (N); + when Field_Type => + return Get_Type (N); + when Field_Subtype_Indication => + return Get_Subtype_Indication (N); + when Field_Discrete_Range => + return Get_Discrete_Range (N); + when Field_Type_Definition => + return Get_Type_Definition (N); + when Field_Subtype_Definition => + return Get_Subtype_Definition (N); + when Field_Nature => + return Get_Nature (N); + when Field_Base_Name => + return Get_Base_Name (N); + when Field_Interface_Declaration_Chain => + return Get_Interface_Declaration_Chain (N); + when Field_Subprogram_Specification => + return Get_Subprogram_Specification (N); + when Field_Sequential_Statement_Chain => + return Get_Sequential_Statement_Chain (N); + when Field_Subprogram_Body => + return Get_Subprogram_Body (N); + when Field_Return_Type => + return Get_Return_Type (N); + when Field_Type_Reference => + return Get_Type_Reference (N); + when Field_Default_Value => + return Get_Default_Value (N); + when Field_Deferred_Declaration => + return Get_Deferred_Declaration (N); + when Field_Design_Unit => + return Get_Design_Unit (N); + when Field_Block_Statement => + return Get_Block_Statement (N); + when Field_Signal_Driver => + return Get_Signal_Driver (N); + when Field_Declaration_Chain => + return Get_Declaration_Chain (N); + when Field_File_Logical_Name => + return Get_File_Logical_Name (N); + when Field_File_Open_Kind => + return Get_File_Open_Kind (N); + when Field_Element_Declaration => + return Get_Element_Declaration (N); + when Field_Selected_Element => + return Get_Selected_Element (N); + when Field_Use_Clause_Chain => + return Get_Use_Clause_Chain (N); + when Field_Selected_Name => + return Get_Selected_Name (N); + when Field_Type_Declarator => + return Get_Type_Declarator (N); + when Field_Entity_Class_Entry_Chain => + return Get_Entity_Class_Entry_Chain (N); + when Field_Unit_Chain => + return Get_Unit_Chain (N); + when Field_Primary_Unit => + return Get_Primary_Unit (N); + when Field_Range_Constraint => + return Get_Range_Constraint (N); + when Field_Left_Limit => + return Get_Left_Limit (N); + when Field_Right_Limit => + return Get_Right_Limit (N); + when Field_Base_Type => + return Get_Base_Type (N); + when Field_Resolution_Indication => + return Get_Resolution_Indication (N); + when Field_Record_Element_Resolution_Chain => + return Get_Record_Element_Resolution_Chain (N); + when Field_Tolerance => + return Get_Tolerance (N); + when Field_Plus_Terminal => + return Get_Plus_Terminal (N); + when Field_Minus_Terminal => + return Get_Minus_Terminal (N); + when Field_Simultaneous_Left => + return Get_Simultaneous_Left (N); + when Field_Simultaneous_Right => + return Get_Simultaneous_Right (N); + when Field_Element_Subtype_Indication => + return Get_Element_Subtype_Indication (N); + when Field_Element_Subtype => + return Get_Element_Subtype (N); + when Field_Array_Element_Constraint => + return Get_Array_Element_Constraint (N); + when Field_Designated_Type => + return Get_Designated_Type (N); + when Field_Designated_Subtype_Indication => + return Get_Designated_Subtype_Indication (N); + when Field_Reference => + return Get_Reference (N); + when Field_Nature_Declarator => + return Get_Nature_Declarator (N); + when Field_Across_Type => + return Get_Across_Type (N); + when Field_Through_Type => + return Get_Through_Type (N); + when Field_Target => + return Get_Target (N); + when Field_Waveform_Chain => + return Get_Waveform_Chain (N); + when Field_Guard => + return Get_Guard (N); + when Field_Reject_Time_Expression => + return Get_Reject_Time_Expression (N); + when Field_Process_Origin => + return Get_Process_Origin (N); + when Field_Condition_Clause => + return Get_Condition_Clause (N); + when Field_Timeout_Clause => + return Get_Timeout_Clause (N); + when Field_Assertion_Condition => + return Get_Assertion_Condition (N); + when Field_Report_Expression => + return Get_Report_Expression (N); + when Field_Severity_Expression => + return Get_Severity_Expression (N); + when Field_Instantiated_Unit => + return Get_Instantiated_Unit (N); + when Field_Generic_Map_Aspect_Chain => + return Get_Generic_Map_Aspect_Chain (N); + when Field_Port_Map_Aspect_Chain => + return Get_Port_Map_Aspect_Chain (N); + when Field_Configuration_Name => + return Get_Configuration_Name (N); + when Field_Component_Configuration => + return Get_Component_Configuration (N); + when Field_Configuration_Specification => + return Get_Configuration_Specification (N); + when Field_Default_Binding_Indication => + return Get_Default_Binding_Indication (N); + when Field_Default_Configuration_Declaration => + return Get_Default_Configuration_Declaration (N); + when Field_Expression => + return Get_Expression (N); + when Field_Allocator_Designated_Type => + return Get_Allocator_Designated_Type (N); + when Field_Selected_Waveform_Chain => + return Get_Selected_Waveform_Chain (N); + when Field_Conditional_Waveform_Chain => + return Get_Conditional_Waveform_Chain (N); + when Field_Guard_Expression => + return Get_Guard_Expression (N); + when Field_Guard_Decl => + return Get_Guard_Decl (N); + when Field_Block_Block_Configuration => + return Get_Block_Block_Configuration (N); + when Field_Package_Header => + return Get_Package_Header (N); + when Field_Block_Header => + return Get_Block_Header (N); + when Field_Uninstantiated_Package_Name => + return Get_Uninstantiated_Package_Name (N); + when Field_Generate_Block_Configuration => + return Get_Generate_Block_Configuration (N); + when Field_Generation_Scheme => + return Get_Generation_Scheme (N); + when Field_Condition => + return Get_Condition (N); + when Field_Else_Clause => + return Get_Else_Clause (N); + when Field_Parameter_Specification => + return Get_Parameter_Specification (N); + when Field_Parent => + return Get_Parent (N); + when Field_Loop_Label => + return Get_Loop_Label (N); + when Field_Component_Name => + return Get_Component_Name (N); + when Field_Entity_Aspect => + return Get_Entity_Aspect (N); + when Field_Default_Entity_Aspect => + return Get_Default_Entity_Aspect (N); + when Field_Default_Generic_Map_Aspect_Chain => + return Get_Default_Generic_Map_Aspect_Chain (N); + when Field_Default_Port_Map_Aspect_Chain => + return Get_Default_Port_Map_Aspect_Chain (N); + when Field_Binding_Indication => + return Get_Binding_Indication (N); + when Field_Named_Entity => + return Get_Named_Entity (N); + when Field_Alias_Declaration => + return Get_Alias_Declaration (N); + when Field_Error_Origin => + return Get_Error_Origin (N); + when Field_Operand => + return Get_Operand (N); + when Field_Left => + return Get_Left (N); + when Field_Right => + return Get_Right (N); + when Field_Unit_Name => + return Get_Unit_Name (N); + when Field_Name => + return Get_Name (N); + when Field_Group_Template_Name => + return Get_Group_Template_Name (N); + when Field_Prefix => + return Get_Prefix (N); + when Field_Signature_Prefix => + return Get_Signature_Prefix (N); + when Field_Slice_Subtype => + return Get_Slice_Subtype (N); + when Field_Suffix => + return Get_Suffix (N); + when Field_Index_Subtype => + return Get_Index_Subtype (N); + when Field_Parameter => + return Get_Parameter (N); + when Field_Actual_Type => + return Get_Actual_Type (N); + when Field_Associated_Interface => + return Get_Associated_Interface (N); + when Field_Association_Chain => + return Get_Association_Chain (N); + when Field_Individual_Association_Chain => + return Get_Individual_Association_Chain (N); + when Field_Aggregate_Info => + return Get_Aggregate_Info (N); + when Field_Sub_Aggregate_Info => + return Get_Sub_Aggregate_Info (N); + when Field_Aggr_Low_Limit => + return Get_Aggr_Low_Limit (N); + when Field_Aggr_High_Limit => + return Get_Aggr_High_Limit (N); + when Field_Association_Choices_Chain => + return Get_Association_Choices_Chain (N); + when Field_Case_Statement_Alternative_Chain => + return Get_Case_Statement_Alternative_Chain (N); + when Field_Procedure_Call => + return Get_Procedure_Call (N); + when Field_Implementation => + return Get_Implementation (N); + when Field_Parameter_Association_Chain => + return Get_Parameter_Association_Chain (N); + when Field_Method_Object => + return Get_Method_Object (N); + when Field_Subtype_Type_Mark => + return Get_Subtype_Type_Mark (N); + when Field_Type_Conversion_Subtype => + return Get_Type_Conversion_Subtype (N); + when Field_Type_Mark => + return Get_Type_Mark (N); + when Field_File_Type_Mark => + return Get_File_Type_Mark (N); + when Field_Return_Type_Mark => + return Get_Return_Type_Mark (N); + when Field_Alias_Signature => + return Get_Alias_Signature (N); + when Field_Attribute_Signature => + return Get_Attribute_Signature (N); + when Field_Simple_Name_Subtype => + return Get_Simple_Name_Subtype (N); + when Field_Protected_Type_Body => + return Get_Protected_Type_Body (N); + when Field_Protected_Type_Declaration => + return Get_Protected_Type_Declaration (N); + when others => + raise Internal_Error; + end case; + end Get_Iir; + + procedure Set_Iir + (N : Iir; F : Fields_Enum; V: Iir) is + begin + pragma Assert (Fields_Type (F) = Type_Iir); + case F is + when Field_First_Design_Unit => + Set_First_Design_Unit (N, V); + when Field_Last_Design_Unit => + Set_Last_Design_Unit (N, V); + when Field_Library_Declaration => + Set_Library_Declaration (N, V); + when Field_Library => + Set_Library (N, V); + when Field_Design_File => + Set_Design_File (N, V); + when Field_Design_File_Chain => + Set_Design_File_Chain (N, V); + when Field_Context_Items => + Set_Context_Items (N, V); + when Field_Library_Unit => + Set_Library_Unit (N, V); + when Field_Hash_Chain => + Set_Hash_Chain (N, V); + when Field_Physical_Literal => + Set_Physical_Literal (N, V); + when Field_Physical_Unit_Value => + Set_Physical_Unit_Value (N, V); + when Field_Enumeration_Decl => + Set_Enumeration_Decl (N, V); + when Field_Bit_String_0 => + Set_Bit_String_0 (N, V); + when Field_Bit_String_1 => + Set_Bit_String_1 (N, V); + when Field_Literal_Origin => + Set_Literal_Origin (N, V); + when Field_Range_Origin => + Set_Range_Origin (N, V); + when Field_Literal_Subtype => + Set_Literal_Subtype (N, V); + when Field_Attribute_Designator => + Set_Attribute_Designator (N, V); + when Field_Attribute_Specification_Chain => + Set_Attribute_Specification_Chain (N, V); + when Field_Attribute_Specification => + Set_Attribute_Specification (N, V); + when Field_Designated_Entity => + Set_Designated_Entity (N, V); + when Field_Formal => + Set_Formal (N, V); + when Field_Actual => + Set_Actual (N, V); + when Field_In_Conversion => + Set_In_Conversion (N, V); + when Field_Out_Conversion => + Set_Out_Conversion (N, V); + when Field_We_Value => + Set_We_Value (N, V); + when Field_Time => + Set_Time (N, V); + when Field_Associated_Expr => + Set_Associated_Expr (N, V); + when Field_Associated_Chain => + Set_Associated_Chain (N, V); + when Field_Choice_Name => + Set_Choice_Name (N, V); + when Field_Choice_Expression => + Set_Choice_Expression (N, V); + when Field_Choice_Range => + Set_Choice_Range (N, V); + when Field_Architecture => + Set_Architecture (N, V); + when Field_Block_Specification => + Set_Block_Specification (N, V); + when Field_Prev_Block_Configuration => + Set_Prev_Block_Configuration (N, V); + when Field_Configuration_Item_Chain => + Set_Configuration_Item_Chain (N, V); + when Field_Attribute_Value_Chain => + Set_Attribute_Value_Chain (N, V); + when Field_Spec_Chain => + Set_Spec_Chain (N, V); + when Field_Attribute_Value_Spec_Chain => + Set_Attribute_Value_Spec_Chain (N, V); + when Field_Entity_Name => + Set_Entity_Name (N, V); + when Field_Package => + Set_Package (N, V); + when Field_Package_Body => + Set_Package_Body (N, V); + when Field_Block_Configuration => + Set_Block_Configuration (N, V); + when Field_Concurrent_Statement_Chain => + Set_Concurrent_Statement_Chain (N, V); + when Field_Chain => + Set_Chain (N, V); + when Field_Port_Chain => + Set_Port_Chain (N, V); + when Field_Generic_Chain => + Set_Generic_Chain (N, V); + when Field_Type => + Set_Type (N, V); + when Field_Subtype_Indication => + Set_Subtype_Indication (N, V); + when Field_Discrete_Range => + Set_Discrete_Range (N, V); + when Field_Type_Definition => + Set_Type_Definition (N, V); + when Field_Subtype_Definition => + Set_Subtype_Definition (N, V); + when Field_Nature => + Set_Nature (N, V); + when Field_Base_Name => + Set_Base_Name (N, V); + when Field_Interface_Declaration_Chain => + Set_Interface_Declaration_Chain (N, V); + when Field_Subprogram_Specification => + Set_Subprogram_Specification (N, V); + when Field_Sequential_Statement_Chain => + Set_Sequential_Statement_Chain (N, V); + when Field_Subprogram_Body => + Set_Subprogram_Body (N, V); + when Field_Return_Type => + Set_Return_Type (N, V); + when Field_Type_Reference => + Set_Type_Reference (N, V); + when Field_Default_Value => + Set_Default_Value (N, V); + when Field_Deferred_Declaration => + Set_Deferred_Declaration (N, V); + when Field_Design_Unit => + Set_Design_Unit (N, V); + when Field_Block_Statement => + Set_Block_Statement (N, V); + when Field_Signal_Driver => + Set_Signal_Driver (N, V); + when Field_Declaration_Chain => + Set_Declaration_Chain (N, V); + when Field_File_Logical_Name => + Set_File_Logical_Name (N, V); + when Field_File_Open_Kind => + Set_File_Open_Kind (N, V); + when Field_Element_Declaration => + Set_Element_Declaration (N, V); + when Field_Selected_Element => + Set_Selected_Element (N, V); + when Field_Use_Clause_Chain => + Set_Use_Clause_Chain (N, V); + when Field_Selected_Name => + Set_Selected_Name (N, V); + when Field_Type_Declarator => + Set_Type_Declarator (N, V); + when Field_Entity_Class_Entry_Chain => + Set_Entity_Class_Entry_Chain (N, V); + when Field_Unit_Chain => + Set_Unit_Chain (N, V); + when Field_Primary_Unit => + Set_Primary_Unit (N, V); + when Field_Range_Constraint => + Set_Range_Constraint (N, V); + when Field_Left_Limit => + Set_Left_Limit (N, V); + when Field_Right_Limit => + Set_Right_Limit (N, V); + when Field_Base_Type => + Set_Base_Type (N, V); + when Field_Resolution_Indication => + Set_Resolution_Indication (N, V); + when Field_Record_Element_Resolution_Chain => + Set_Record_Element_Resolution_Chain (N, V); + when Field_Tolerance => + Set_Tolerance (N, V); + when Field_Plus_Terminal => + Set_Plus_Terminal (N, V); + when Field_Minus_Terminal => + Set_Minus_Terminal (N, V); + when Field_Simultaneous_Left => + Set_Simultaneous_Left (N, V); + when Field_Simultaneous_Right => + Set_Simultaneous_Right (N, V); + when Field_Element_Subtype_Indication => + Set_Element_Subtype_Indication (N, V); + when Field_Element_Subtype => + Set_Element_Subtype (N, V); + when Field_Array_Element_Constraint => + Set_Array_Element_Constraint (N, V); + when Field_Designated_Type => + Set_Designated_Type (N, V); + when Field_Designated_Subtype_Indication => + Set_Designated_Subtype_Indication (N, V); + when Field_Reference => + Set_Reference (N, V); + when Field_Nature_Declarator => + Set_Nature_Declarator (N, V); + when Field_Across_Type => + Set_Across_Type (N, V); + when Field_Through_Type => + Set_Through_Type (N, V); + when Field_Target => + Set_Target (N, V); + when Field_Waveform_Chain => + Set_Waveform_Chain (N, V); + when Field_Guard => + Set_Guard (N, V); + when Field_Reject_Time_Expression => + Set_Reject_Time_Expression (N, V); + when Field_Process_Origin => + Set_Process_Origin (N, V); + when Field_Condition_Clause => + Set_Condition_Clause (N, V); + when Field_Timeout_Clause => + Set_Timeout_Clause (N, V); + when Field_Assertion_Condition => + Set_Assertion_Condition (N, V); + when Field_Report_Expression => + Set_Report_Expression (N, V); + when Field_Severity_Expression => + Set_Severity_Expression (N, V); + when Field_Instantiated_Unit => + Set_Instantiated_Unit (N, V); + when Field_Generic_Map_Aspect_Chain => + Set_Generic_Map_Aspect_Chain (N, V); + when Field_Port_Map_Aspect_Chain => + Set_Port_Map_Aspect_Chain (N, V); + when Field_Configuration_Name => + Set_Configuration_Name (N, V); + when Field_Component_Configuration => + Set_Component_Configuration (N, V); + when Field_Configuration_Specification => + Set_Configuration_Specification (N, V); + when Field_Default_Binding_Indication => + Set_Default_Binding_Indication (N, V); + when Field_Default_Configuration_Declaration => + Set_Default_Configuration_Declaration (N, V); + when Field_Expression => + Set_Expression (N, V); + when Field_Allocator_Designated_Type => + Set_Allocator_Designated_Type (N, V); + when Field_Selected_Waveform_Chain => + Set_Selected_Waveform_Chain (N, V); + when Field_Conditional_Waveform_Chain => + Set_Conditional_Waveform_Chain (N, V); + when Field_Guard_Expression => + Set_Guard_Expression (N, V); + when Field_Guard_Decl => + Set_Guard_Decl (N, V); + when Field_Block_Block_Configuration => + Set_Block_Block_Configuration (N, V); + when Field_Package_Header => + Set_Package_Header (N, V); + when Field_Block_Header => + Set_Block_Header (N, V); + when Field_Uninstantiated_Package_Name => + Set_Uninstantiated_Package_Name (N, V); + when Field_Generate_Block_Configuration => + Set_Generate_Block_Configuration (N, V); + when Field_Generation_Scheme => + Set_Generation_Scheme (N, V); + when Field_Condition => + Set_Condition (N, V); + when Field_Else_Clause => + Set_Else_Clause (N, V); + when Field_Parameter_Specification => + Set_Parameter_Specification (N, V); + when Field_Parent => + Set_Parent (N, V); + when Field_Loop_Label => + Set_Loop_Label (N, V); + when Field_Component_Name => + Set_Component_Name (N, V); + when Field_Entity_Aspect => + Set_Entity_Aspect (N, V); + when Field_Default_Entity_Aspect => + Set_Default_Entity_Aspect (N, V); + when Field_Default_Generic_Map_Aspect_Chain => + Set_Default_Generic_Map_Aspect_Chain (N, V); + when Field_Default_Port_Map_Aspect_Chain => + Set_Default_Port_Map_Aspect_Chain (N, V); + when Field_Binding_Indication => + Set_Binding_Indication (N, V); + when Field_Named_Entity => + Set_Named_Entity (N, V); + when Field_Alias_Declaration => + Set_Alias_Declaration (N, V); + when Field_Error_Origin => + Set_Error_Origin (N, V); + when Field_Operand => + Set_Operand (N, V); + when Field_Left => + Set_Left (N, V); + when Field_Right => + Set_Right (N, V); + when Field_Unit_Name => + Set_Unit_Name (N, V); + when Field_Name => + Set_Name (N, V); + when Field_Group_Template_Name => + Set_Group_Template_Name (N, V); + when Field_Prefix => + Set_Prefix (N, V); + when Field_Signature_Prefix => + Set_Signature_Prefix (N, V); + when Field_Slice_Subtype => + Set_Slice_Subtype (N, V); + when Field_Suffix => + Set_Suffix (N, V); + when Field_Index_Subtype => + Set_Index_Subtype (N, V); + when Field_Parameter => + Set_Parameter (N, V); + when Field_Actual_Type => + Set_Actual_Type (N, V); + when Field_Associated_Interface => + Set_Associated_Interface (N, V); + when Field_Association_Chain => + Set_Association_Chain (N, V); + when Field_Individual_Association_Chain => + Set_Individual_Association_Chain (N, V); + when Field_Aggregate_Info => + Set_Aggregate_Info (N, V); + when Field_Sub_Aggregate_Info => + Set_Sub_Aggregate_Info (N, V); + when Field_Aggr_Low_Limit => + Set_Aggr_Low_Limit (N, V); + when Field_Aggr_High_Limit => + Set_Aggr_High_Limit (N, V); + when Field_Association_Choices_Chain => + Set_Association_Choices_Chain (N, V); + when Field_Case_Statement_Alternative_Chain => + Set_Case_Statement_Alternative_Chain (N, V); + when Field_Procedure_Call => + Set_Procedure_Call (N, V); + when Field_Implementation => + Set_Implementation (N, V); + when Field_Parameter_Association_Chain => + Set_Parameter_Association_Chain (N, V); + when Field_Method_Object => + Set_Method_Object (N, V); + when Field_Subtype_Type_Mark => + Set_Subtype_Type_Mark (N, V); + when Field_Type_Conversion_Subtype => + Set_Type_Conversion_Subtype (N, V); + when Field_Type_Mark => + Set_Type_Mark (N, V); + when Field_File_Type_Mark => + Set_File_Type_Mark (N, V); + when Field_Return_Type_Mark => + Set_Return_Type_Mark (N, V); + when Field_Alias_Signature => + Set_Alias_Signature (N, V); + when Field_Attribute_Signature => + Set_Attribute_Signature (N, V); + when Field_Simple_Name_Subtype => + Set_Simple_Name_Subtype (N, V); + when Field_Protected_Type_Body => + Set_Protected_Type_Body (N, V); + when Field_Protected_Type_Declaration => + Set_Protected_Type_Declaration (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir; + + function Get_Iir_All_Sensitized + (N : Iir; F : Fields_Enum) return Iir_All_Sensitized is + begin + pragma Assert (Fields_Type (F) = Type_Iir_All_Sensitized); + case F is + when Field_All_Sensitized_State => + return Get_All_Sensitized_State (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_All_Sensitized; + + procedure Set_Iir_All_Sensitized + (N : Iir; F : Fields_Enum; V: Iir_All_Sensitized) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_All_Sensitized); + case F is + when Field_All_Sensitized_State => + Set_All_Sensitized_State (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_All_Sensitized; + + function Get_Iir_Constraint + (N : Iir; F : Fields_Enum) return Iir_Constraint is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Constraint); + case F is + when Field_Constraint_State => + return Get_Constraint_State (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Constraint; + + procedure Set_Iir_Constraint + (N : Iir; F : Fields_Enum; V: Iir_Constraint) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Constraint); + case F is + when Field_Constraint_State => + Set_Constraint_State (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Constraint; + + function Get_Iir_Delay_Mechanism + (N : Iir; F : Fields_Enum) return Iir_Delay_Mechanism is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Delay_Mechanism); + case F is + when Field_Delay_Mechanism => + return Get_Delay_Mechanism (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Delay_Mechanism; + + procedure Set_Iir_Delay_Mechanism + (N : Iir; F : Fields_Enum; V: Iir_Delay_Mechanism) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Delay_Mechanism); + case F is + when Field_Delay_Mechanism => + Set_Delay_Mechanism (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Delay_Mechanism; + + function Get_Iir_Direction + (N : Iir; F : Fields_Enum) return Iir_Direction is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Direction); + case F is + when Field_Direction => + return Get_Direction (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Direction; + + procedure Set_Iir_Direction + (N : Iir; F : Fields_Enum; V: Iir_Direction) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Direction); + case F is + when Field_Direction => + Set_Direction (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Direction; + + function Get_Iir_Fp64 + (N : Iir; F : Fields_Enum) return Iir_Fp64 is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Fp64); + case F is + when Field_Fp_Value => + return Get_Fp_Value (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Fp64; + + procedure Set_Iir_Fp64 + (N : Iir; F : Fields_Enum; V: Iir_Fp64) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Fp64); + case F is + when Field_Fp_Value => + Set_Fp_Value (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Fp64; + + function Get_Iir_Index32 + (N : Iir; F : Fields_Enum) return Iir_Index32 is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Index32); + case F is + when Field_Element_Position => + return Get_Element_Position (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Index32; + + procedure Set_Iir_Index32 + (N : Iir; F : Fields_Enum; V: Iir_Index32) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Index32); + case F is + when Field_Element_Position => + Set_Element_Position (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Index32; + + function Get_Iir_Int32 + (N : Iir; F : Fields_Enum) return Iir_Int32 is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Int32); + case F is + when Field_Enum_Pos => + return Get_Enum_Pos (N); + when Field_Overload_Number => + return Get_Overload_Number (N); + when Field_Subprogram_Depth => + return Get_Subprogram_Depth (N); + when Field_Subprogram_Hash => + return Get_Subprogram_Hash (N); + when Field_Impure_Depth => + return Get_Impure_Depth (N); + when Field_Aggr_Min_Length => + return Get_Aggr_Min_Length (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Int32; + + procedure Set_Iir_Int32 + (N : Iir; F : Fields_Enum; V: Iir_Int32) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Int32); + case F is + when Field_Enum_Pos => + Set_Enum_Pos (N, V); + when Field_Overload_Number => + Set_Overload_Number (N, V); + when Field_Subprogram_Depth => + Set_Subprogram_Depth (N, V); + when Field_Subprogram_Hash => + Set_Subprogram_Hash (N, V); + when Field_Impure_Depth => + Set_Impure_Depth (N, V); + when Field_Aggr_Min_Length => + Set_Aggr_Min_Length (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Int32; + + function Get_Iir_Int64 + (N : Iir; F : Fields_Enum) return Iir_Int64 is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Int64); + case F is + when Field_Value => + return Get_Value (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Int64; + + procedure Set_Iir_Int64 + (N : Iir; F : Fields_Enum; V: Iir_Int64) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Int64); + case F is + when Field_Value => + Set_Value (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Int64; + + function Get_Iir_Lexical_Layout_Type + (N : Iir; F : Fields_Enum) return Iir_Lexical_Layout_Type is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Lexical_Layout_Type); + case F is + when Field_Lexical_Layout => + return Get_Lexical_Layout (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Lexical_Layout_Type; + + procedure Set_Iir_Lexical_Layout_Type + (N : Iir; F : Fields_Enum; V: Iir_Lexical_Layout_Type) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Lexical_Layout_Type); + case F is + when Field_Lexical_Layout => + Set_Lexical_Layout (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Lexical_Layout_Type; + + function Get_Iir_List + (N : Iir; F : Fields_Enum) return Iir_List is + begin + pragma Assert (Fields_Type (F) = Type_Iir_List); + case F is + when Field_File_Dependence_List => + return Get_File_Dependence_List (N); + when Field_Dependence_List => + return Get_Dependence_List (N); + when Field_Analysis_Checks_List => + return Get_Analysis_Checks_List (N); + when Field_Simple_Aggregate_List => + return Get_Simple_Aggregate_List (N); + when Field_Entity_Name_List => + return Get_Entity_Name_List (N); + when Field_Signal_List => + return Get_Signal_List (N); + when Field_Enumeration_Literal_List => + return Get_Enumeration_Literal_List (N); + when Field_Group_Constituent_List => + return Get_Group_Constituent_List (N); + when Field_Index_Subtype_List => + return Get_Index_Subtype_List (N); + when Field_Index_Subtype_Definition_List => + return Get_Index_Subtype_Definition_List (N); + when Field_Index_Constraint_List => + return Get_Index_Constraint_List (N); + when Field_Elements_Declaration_List => + return Get_Elements_Declaration_List (N); + when Field_Index_List => + return Get_Index_List (N); + when Field_Sensitivity_List => + return Get_Sensitivity_List (N); + when Field_Callees_List => + return Get_Callees_List (N); + when Field_Guard_Sensitivity_List => + return Get_Guard_Sensitivity_List (N); + when Field_Instantiation_List => + return Get_Instantiation_List (N); + when Field_Incomplete_Type_List => + return Get_Incomplete_Type_List (N); + when Field_Type_Marks_List => + return Get_Type_Marks_List (N); + when Field_Overload_List => + return Get_Overload_List (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_List; + + procedure Set_Iir_List + (N : Iir; F : Fields_Enum; V: Iir_List) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_List); + case F is + when Field_File_Dependence_List => + Set_File_Dependence_List (N, V); + when Field_Dependence_List => + Set_Dependence_List (N, V); + when Field_Analysis_Checks_List => + Set_Analysis_Checks_List (N, V); + when Field_Simple_Aggregate_List => + Set_Simple_Aggregate_List (N, V); + when Field_Entity_Name_List => + Set_Entity_Name_List (N, V); + when Field_Signal_List => + Set_Signal_List (N, V); + when Field_Enumeration_Literal_List => + Set_Enumeration_Literal_List (N, V); + when Field_Group_Constituent_List => + Set_Group_Constituent_List (N, V); + when Field_Index_Subtype_List => + Set_Index_Subtype_List (N, V); + when Field_Index_Subtype_Definition_List => + Set_Index_Subtype_Definition_List (N, V); + when Field_Index_Constraint_List => + Set_Index_Constraint_List (N, V); + when Field_Elements_Declaration_List => + Set_Elements_Declaration_List (N, V); + when Field_Index_List => + Set_Index_List (N, V); + when Field_Sensitivity_List => + Set_Sensitivity_List (N, V); + when Field_Callees_List => + Set_Callees_List (N, V); + when Field_Guard_Sensitivity_List => + Set_Guard_Sensitivity_List (N, V); + when Field_Instantiation_List => + Set_Instantiation_List (N, V); + when Field_Incomplete_Type_List => + Set_Incomplete_Type_List (N, V); + when Field_Type_Marks_List => + Set_Type_Marks_List (N, V); + when Field_Overload_List => + Set_Overload_List (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_List; + + function Get_Iir_Mode + (N : Iir; F : Fields_Enum) return Iir_Mode is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Mode); + case F is + when Field_Mode => + return Get_Mode (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Mode; + + procedure Set_Iir_Mode + (N : Iir; F : Fields_Enum; V: Iir_Mode) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Mode); + case F is + when Field_Mode => + Set_Mode (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Mode; + + function Get_Iir_Predefined_Functions + (N : Iir; F : Fields_Enum) return Iir_Predefined_Functions is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Predefined_Functions); + case F is + when Field_Implicit_Definition => + return Get_Implicit_Definition (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Predefined_Functions; + + procedure Set_Iir_Predefined_Functions + (N : Iir; F : Fields_Enum; V: Iir_Predefined_Functions) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Predefined_Functions); + case F is + when Field_Implicit_Definition => + Set_Implicit_Definition (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Predefined_Functions; + + function Get_Iir_Pure_State + (N : Iir; F : Fields_Enum) return Iir_Pure_State is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Pure_State); + case F is + when Field_Purity_State => + return Get_Purity_State (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Pure_State; + + procedure Set_Iir_Pure_State + (N : Iir; F : Fields_Enum; V: Iir_Pure_State) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Pure_State); + case F is + when Field_Purity_State => + Set_Purity_State (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Pure_State; + + function Get_Iir_Signal_Kind + (N : Iir; F : Fields_Enum) return Iir_Signal_Kind is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Signal_Kind); + case F is + when Field_Signal_Kind => + return Get_Signal_Kind (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Signal_Kind; + + procedure Set_Iir_Signal_Kind + (N : Iir; F : Fields_Enum; V: Iir_Signal_Kind) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Signal_Kind); + case F is + when Field_Signal_Kind => + Set_Signal_Kind (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Signal_Kind; + + function Get_Iir_Staticness + (N : Iir; F : Fields_Enum) return Iir_Staticness is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Staticness); + case F is + when Field_Type_Staticness => + return Get_Type_Staticness (N); + when Field_Expr_Staticness => + return Get_Expr_Staticness (N); + when Field_Name_Staticness => + return Get_Name_Staticness (N); + when Field_Value_Staticness => + return Get_Value_Staticness (N); + when Field_Choice_Staticness => + return Get_Choice_Staticness (N); + when others => + raise Internal_Error; + end case; + end Get_Iir_Staticness; + + procedure Set_Iir_Staticness + (N : Iir; F : Fields_Enum; V: Iir_Staticness) is + begin + pragma Assert (Fields_Type (F) = Type_Iir_Staticness); + case F is + when Field_Type_Staticness => + Set_Type_Staticness (N, V); + when Field_Expr_Staticness => + Set_Expr_Staticness (N, V); + when Field_Name_Staticness => + Set_Name_Staticness (N, V); + when Field_Value_Staticness => + Set_Value_Staticness (N, V); + when Field_Choice_Staticness => + Set_Choice_Staticness (N, V); + when others => + raise Internal_Error; + end case; + end Set_Iir_Staticness; + + function Get_Int32 + (N : Iir; F : Fields_Enum) return Int32 is + begin + pragma Assert (Fields_Type (F) = Type_Int32); + case F is + when Field_Design_Unit_Source_Line => + return Get_Design_Unit_Source_Line (N); + when Field_Design_Unit_Source_Col => + return Get_Design_Unit_Source_Col (N); + when Field_String_Length => + return Get_String_Length (N); + when others => + raise Internal_Error; + end case; + end Get_Int32; + + procedure Set_Int32 + (N : Iir; F : Fields_Enum; V: Int32) is + begin + pragma Assert (Fields_Type (F) = Type_Int32); + case F is + when Field_Design_Unit_Source_Line => + Set_Design_Unit_Source_Line (N, V); + when Field_Design_Unit_Source_Col => + Set_Design_Unit_Source_Col (N, V); + when Field_String_Length => + Set_String_Length (N, V); + when others => + raise Internal_Error; + end case; + end Set_Int32; + + function Get_Location_Type + (N : Iir; F : Fields_Enum) return Location_Type is + begin + pragma Assert (Fields_Type (F) = Type_Location_Type); + case F is + when Field_End_Location => + return Get_End_Location (N); + when others => + raise Internal_Error; + end case; + end Get_Location_Type; + + procedure Set_Location_Type + (N : Iir; F : Fields_Enum; V: Location_Type) is + begin + pragma Assert (Fields_Type (F) = Type_Location_Type); + case F is + when Field_End_Location => + Set_End_Location (N, V); + when others => + raise Internal_Error; + end case; + end Set_Location_Type; + + function Get_Name_Id + (N : Iir; F : Fields_Enum) return Name_Id is + begin + pragma Assert (Fields_Type (F) = Type_Name_Id); + case F is + when Field_Design_File_Filename => + return Get_Design_File_Filename (N); + when Field_Design_File_Directory => + return Get_Design_File_Directory (N); + when Field_Library_Directory => + return Get_Library_Directory (N); + when Field_Identifier => + return Get_Identifier (N); + when Field_Label => + return Get_Label (N); + when Field_Simple_Name_Identifier => + return Get_Simple_Name_Identifier (N); + when others => + raise Internal_Error; + end case; + end Get_Name_Id; + + procedure Set_Name_Id + (N : Iir; F : Fields_Enum; V: Name_Id) is + begin + pragma Assert (Fields_Type (F) = Type_Name_Id); + case F is + when Field_Design_File_Filename => + Set_Design_File_Filename (N, V); + when Field_Design_File_Directory => + Set_Design_File_Directory (N, V); + when Field_Library_Directory => + Set_Library_Directory (N, V); + when Field_Identifier => + Set_Identifier (N, V); + when Field_Label => + Set_Label (N, V); + when Field_Simple_Name_Identifier => + Set_Simple_Name_Identifier (N, V); + when others => + raise Internal_Error; + end case; + end Set_Name_Id; + + function Get_PSL_NFA + (N : Iir; F : Fields_Enum) return PSL_NFA is + begin + pragma Assert (Fields_Type (F) = Type_PSL_NFA); + case F is + when Field_PSL_NFA => + return Get_PSL_NFA (N); + when others => + raise Internal_Error; + end case; + end Get_PSL_NFA; + + procedure Set_PSL_NFA + (N : Iir; F : Fields_Enum; V: PSL_NFA) is + begin + pragma Assert (Fields_Type (F) = Type_PSL_NFA); + case F is + when Field_PSL_NFA => + Set_PSL_NFA (N, V); + when others => + raise Internal_Error; + end case; + end Set_PSL_NFA; + + function Get_PSL_Node + (N : Iir; F : Fields_Enum) return PSL_Node is + begin + pragma Assert (Fields_Type (F) = Type_PSL_Node); + case F is + when Field_Psl_Property => + return Get_Psl_Property (N); + when Field_Psl_Declaration => + return Get_Psl_Declaration (N); + when Field_Psl_Expression => + return Get_Psl_Expression (N); + when Field_Psl_Boolean => + return Get_Psl_Boolean (N); + when Field_PSL_Clock => + return Get_PSL_Clock (N); + when others => + raise Internal_Error; + end case; + end Get_PSL_Node; + + procedure Set_PSL_Node + (N : Iir; F : Fields_Enum; V: PSL_Node) is + begin + pragma Assert (Fields_Type (F) = Type_PSL_Node); + case F is + when Field_Psl_Property => + Set_Psl_Property (N, V); + when Field_Psl_Declaration => + Set_Psl_Declaration (N, V); + when Field_Psl_Expression => + Set_Psl_Expression (N, V); + when Field_Psl_Boolean => + Set_Psl_Boolean (N, V); + when Field_PSL_Clock => + Set_PSL_Clock (N, V); + when others => + raise Internal_Error; + end case; + end Set_PSL_Node; + + function Get_Source_Ptr + (N : Iir; F : Fields_Enum) return Source_Ptr is + begin + pragma Assert (Fields_Type (F) = Type_Source_Ptr); + case F is + when Field_Design_Unit_Source_Pos => + return Get_Design_Unit_Source_Pos (N); + when others => + raise Internal_Error; + end case; + end Get_Source_Ptr; + + procedure Set_Source_Ptr + (N : Iir; F : Fields_Enum; V: Source_Ptr) is + begin + pragma Assert (Fields_Type (F) = Type_Source_Ptr); + case F is + when Field_Design_Unit_Source_Pos => + Set_Design_Unit_Source_Pos (N, V); + when others => + raise Internal_Error; + end case; + end Set_Source_Ptr; + + function Get_String_Id + (N : Iir; F : Fields_Enum) return String_Id is + begin + pragma Assert (Fields_Type (F) = Type_String_Id); + case F is + when Field_String_Id => + return Get_String_Id (N); + when others => + raise Internal_Error; + end case; + end Get_String_Id; + + procedure Set_String_Id + (N : Iir; F : Fields_Enum; V: String_Id) is + begin + pragma Assert (Fields_Type (F) = Type_String_Id); + case F is + when Field_String_Id => + Set_String_Id (N, V); + when others => + raise Internal_Error; + end case; + end Set_String_Id; + + function Get_Time_Stamp_Id + (N : Iir; F : Fields_Enum) return Time_Stamp_Id is + begin + pragma Assert (Fields_Type (F) = Type_Time_Stamp_Id); + case F is + when Field_File_Time_Stamp => + return Get_File_Time_Stamp (N); + when Field_Analysis_Time_Stamp => + return Get_Analysis_Time_Stamp (N); + when others => + raise Internal_Error; + end case; + end Get_Time_Stamp_Id; + + procedure Set_Time_Stamp_Id + (N : Iir; F : Fields_Enum; V: Time_Stamp_Id) is + begin + pragma Assert (Fields_Type (F) = Type_Time_Stamp_Id); + case F is + when Field_File_Time_Stamp => + Set_File_Time_Stamp (N, V); + when Field_Analysis_Time_Stamp => + Set_Analysis_Time_Stamp (N, V); + when others => + raise Internal_Error; + end case; + end Set_Time_Stamp_Id; + + function Get_Token_Type + (N : Iir; F : Fields_Enum) return Token_Type is + begin + pragma Assert (Fields_Type (F) = Type_Token_Type); + case F is + when Field_Entity_Class => + return Get_Entity_Class (N); + when others => + raise Internal_Error; + end case; + end Get_Token_Type; + + procedure Set_Token_Type + (N : Iir; F : Fields_Enum; V: Token_Type) is + begin + pragma Assert (Fields_Type (F) = Type_Token_Type); + case F is + when Field_Entity_Class => + Set_Entity_Class (N, V); + when others => + raise Internal_Error; + end case; + end Set_Token_Type; + + function Get_Tri_State_Type + (N : Iir; F : Fields_Enum) return Tri_State_Type is + begin + pragma Assert (Fields_Type (F) = Type_Tri_State_Type); + case F is + when Field_Guarded_Target_State => + return Get_Guarded_Target_State (N); + when Field_Wait_State => + return Get_Wait_State (N); + when others => + raise Internal_Error; + end case; + end Get_Tri_State_Type; + + procedure Set_Tri_State_Type + (N : Iir; F : Fields_Enum; V: Tri_State_Type) is + begin + pragma Assert (Fields_Type (F) = Type_Tri_State_Type); + case F is + when Field_Guarded_Target_State => + Set_Guarded_Target_State (N, V); + when Field_Wait_State => + Set_Wait_State (N, V); + when others => + raise Internal_Error; + end case; + end Set_Tri_State_Type; + + function Has_First_Design_Unit (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_File; + end Has_First_Design_Unit; + + function Has_Last_Design_Unit (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_File; + end Has_Last_Design_Unit; + + function Has_Library_Declaration (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Library_Clause; + end Has_Library_Declaration; + + function Has_File_Time_Stamp (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_File; + end Has_File_Time_Stamp; + + function Has_Analysis_Time_Stamp (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_File; + end Has_Analysis_Time_Stamp; + + function Has_Library (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_File; + end Has_Library; + + function Has_File_Dependence_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_File; + end Has_File_Dependence_List; + + function Has_Design_File_Filename (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_File; + end Has_Design_File_Filename; + + function Has_Design_File_Directory (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_File; + end Has_Design_File_Directory; + + function Has_Design_File (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_Unit; + end Has_Design_File; + + function Has_Design_File_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Library_Declaration; + end Has_Design_File_Chain; + + function Has_Library_Directory (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Library_Declaration; + end Has_Library_Directory; + + function Has_Date (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Design_Unit + | Iir_Kind_Library_Declaration => + return True; + when others => + return False; + end case; + end Has_Date; + + function Has_Context_Items (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_Unit; + end Has_Context_Items; + + function Has_Dependence_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_Unit; + end Has_Dependence_List; + + function Has_Analysis_Checks_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_Unit; + end Has_Analysis_Checks_List; + + function Has_Date_State (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_Unit; + end Has_Date_State; + + function Has_Guarded_Target_State (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Signal_Assignment_Statement => + return True; + when others => + return False; + end case; + end Has_Guarded_Target_State; + + function Has_Library_Unit (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_Unit; + end Has_Library_Unit; + + function Has_Hash_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_Unit; + end Has_Hash_Chain; + + function Has_Design_Unit_Source_Pos (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_Unit; + end Has_Design_Unit_Source_Pos; + + function Has_Design_Unit_Source_Line (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_Unit; + end Has_Design_Unit_Source_Line; + + function Has_Design_Unit_Source_Col (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_Unit; + end Has_Design_Unit_Source_Col; + + function Has_Value (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Integer_Literal + | Iir_Kind_Physical_Int_Literal => + return True; + when others => + return False; + end case; + end Has_Value; + + function Has_Enum_Pos (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Enumeration_Literal; + end Has_Enum_Pos; + + function Has_Physical_Literal (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Unit_Declaration; + end Has_Physical_Literal; + + function Has_Physical_Unit_Value (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Unit_Declaration; + end Has_Physical_Unit_Value; + + function Has_Fp_Value (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Floating_Point_Literal + | Iir_Kind_Physical_Fp_Literal => + return True; + when others => + return False; + end case; + end Has_Fp_Value; + + function Has_Enumeration_Decl (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Enumeration_Literal; + end Has_Enumeration_Decl; + + function Has_Simple_Aggregate_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Simple_Aggregate; + end Has_Simple_Aggregate_List; + + function Has_Bit_String_Base (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Bit_String_Literal; + end Has_Bit_String_Base; + + function Has_Bit_String_0 (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Bit_String_Literal; + end Has_Bit_String_0; + + function Has_Bit_String_1 (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Bit_String_Literal; + end Has_Bit_String_1; + + function Has_Literal_Origin (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Integer_Literal + | Iir_Kind_Floating_Point_Literal + | Iir_Kind_String_Literal + | Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Bit_String_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Overflow_Literal + | Iir_Kind_Enumeration_Literal => + return True; + when others => + return False; + end case; + end Has_Literal_Origin; + + function Has_Range_Origin (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Range_Expression; + end Has_Range_Origin; + + function Has_Literal_Subtype (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Aggregate => + return True; + when others => + return False; + end case; + end Has_Literal_Subtype; + + function Has_Entity_Class (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Entity_Class + | Iir_Kind_Attribute_Specification => + return True; + when others => + return False; + end case; + end Has_Entity_Class; + + function Has_Entity_Name_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Attribute_Specification; + end Has_Entity_Name_List; + + function Has_Attribute_Designator (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Attribute_Specification; + end Has_Attribute_Designator; + + function Has_Attribute_Specification_Chain (K : Iir_Kind) + return Boolean is + begin + return K = Iir_Kind_Attribute_Specification; + end Has_Attribute_Specification_Chain; + + function Has_Attribute_Specification (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Attribute_Value; + end Has_Attribute_Specification; + + function Has_Signal_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Disconnection_Specification; + end Has_Signal_List; + + function Has_Designated_Entity (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Attribute_Value; + end Has_Designated_Entity; + + function Has_Formal (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Association_Element_By_Expression + | Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Open + | Iir_Kind_Association_Element_Package => + return True; + when others => + return False; + end case; + end Has_Formal; + + function Has_Actual (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Association_Element_By_Expression + | Iir_Kind_Association_Element_Package => + return True; + when others => + return False; + end case; + end Has_Actual; + + function Has_In_Conversion (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Association_Element_By_Expression; + end Has_In_Conversion; + + function Has_Out_Conversion (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Association_Element_By_Expression; + end Has_Out_Conversion; + + function Has_Whole_Association_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Association_Element_By_Expression + | Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Open + | Iir_Kind_Association_Element_Package => + return True; + when others => + return False; + end case; + end Has_Whole_Association_Flag; + + function Has_Collapse_Signal_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Association_Element_By_Expression + | Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Open + | Iir_Kind_Association_Element_Package => + return True; + when others => + return False; + end case; + end Has_Collapse_Signal_Flag; + + function Has_Artificial_Flag (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Association_Element_Open; + end Has_Artificial_Flag; + + function Has_Open_Flag (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Interface_Signal_Declaration; + end Has_Open_Flag; + + function Has_After_Drivers_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration => + return True; + when others => + return False; + end case; + end Has_After_Drivers_Flag; + + function Has_We_Value (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Waveform_Element; + end Has_We_Value; + + function Has_Time (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Waveform_Element; + end Has_Time; + + function Has_Associated_Expr (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Choice_By_Others + | Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_None + | Iir_Kind_Choice_By_Name => + return True; + when others => + return False; + end case; + end Has_Associated_Expr; + + function Has_Associated_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Choice_By_Others + | Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_None + | Iir_Kind_Choice_By_Name => + return True; + when others => + return False; + end case; + end Has_Associated_Chain; + + function Has_Choice_Name (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Choice_By_Name; + end Has_Choice_Name; + + function Has_Choice_Expression (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Choice_By_Expression; + end Has_Choice_Expression; + + function Has_Choice_Range (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Choice_By_Range; + end Has_Choice_Range; + + function Has_Same_Alternative_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Choice_By_Others + | Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_None + | Iir_Kind_Choice_By_Name => + return True; + when others => + return False; + end case; + end Has_Same_Alternative_Flag; + + function Has_Architecture (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Entity_Aspect_Entity; + end Has_Architecture; + + function Has_Block_Specification (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Block_Configuration; + end Has_Block_Specification; + + function Has_Prev_Block_Configuration (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Block_Configuration; + end Has_Prev_Block_Configuration; + + function Has_Configuration_Item_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Block_Configuration; + end Has_Configuration_Item_Chain; + + function Has_Attribute_Value_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Unit_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Group_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement + | Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Null_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement + | Iir_Kind_Wait_Statement + | Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_Case_Statement + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_If_Statement => + return True; + when others => + return False; + end case; + end Has_Attribute_Value_Chain; + + function Has_Spec_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Attribute_Value; + end Has_Spec_Chain; + + function Has_Attribute_Value_Spec_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Attribute_Specification; + end Has_Attribute_Value_Spec_Chain; + + function Has_Entity_Name (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Entity_Aspect_Entity + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Architecture_Body => + return True; + when others => + return False; + end case; + end Has_Entity_Name; + + function Has_Package (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Package_Body; + end Has_Package; + + function Has_Package_Body (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + return True; + when others => + return False; + end case; + end Has_Package_Body; + + function Has_Need_Body (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Package_Declaration; + end Has_Need_Body; + + function Has_Block_Configuration (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Component_Configuration + | Iir_Kind_Configuration_Declaration => + return True; + when others => + return False; + end case; + end Has_Block_Configuration; + + function Has_Concurrent_Statement_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + return True; + when others => + return False; + end case; + end Has_Concurrent_Statement_Chain; + + function Has_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Design_File + | Iir_Kind_Design_Unit + | Iir_Kind_Library_Clause + | Iir_Kind_Use_Clause + | Iir_Kind_Waveform_Element + | Iir_Kind_Conditional_Waveform + | Iir_Kind_Association_Element_By_Expression + | Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Open + | Iir_Kind_Association_Element_Package + | Iir_Kind_Choice_By_Others + | Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_None + | Iir_Kind_Choice_By_Name + | Iir_Kind_Block_Configuration + | Iir_Kind_Component_Configuration + | Iir_Kind_Entity_Class + | Iir_Kind_Attribute_Value + | Iir_Kind_Record_Element_Resolution + | Iir_Kind_Attribute_Specification + | Iir_Kind_Disconnection_Specification + | Iir_Kind_Configuration_Specification + | Iir_Kind_Protected_Type_Body + | Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration + | Iir_Kind_Unit_Declaration + | Iir_Kind_Library_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration + | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Psl_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement + | Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Null_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement + | Iir_Kind_Wait_Statement + | Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_Case_Statement + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_If_Statement + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute => + return True; + when others => + return False; + end case; + end Has_Chain; + + function Has_Port_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Block_Header + | Iir_Kind_Entity_Declaration + | Iir_Kind_Component_Declaration => + return True; + when others => + return False; + end case; + end Has_Port_Chain; + + function Has_Generic_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Block_Header + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Header + | Iir_Kind_Component_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Interface_Package_Declaration => + return True; + when others => + return False; + end case; + end Has_Generic_Chain; + + function Has_Type (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Error + | Iir_Kind_Integer_Literal + | Iir_Kind_Floating_Point_Literal + | Iir_Kind_Null_Literal + | Iir_Kind_String_Literal + | Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Bit_String_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Overflow_Literal + | Iir_Kind_Attribute_Value + | Iir_Kind_Record_Element_Constraint + | Iir_Kind_Range_Expression + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Unit_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Element_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Identity_Operator + | Iir_Kind_Negation_Operator + | Iir_Kind_Absolute_Operator + | Iir_Kind_Not_Operator + | Iir_Kind_Condition_Operator + | Iir_Kind_Reduction_And_Operator + | Iir_Kind_Reduction_Or_Operator + | Iir_Kind_Reduction_Nand_Operator + | Iir_Kind_Reduction_Nor_Operator + | Iir_Kind_Reduction_Xor_Operator + | Iir_Kind_Reduction_Xnor_Operator + | Iir_Kind_And_Operator + | Iir_Kind_Or_Operator + | Iir_Kind_Nand_Operator + | Iir_Kind_Nor_Operator + | Iir_Kind_Xor_Operator + | Iir_Kind_Xnor_Operator + | Iir_Kind_Equality_Operator + | Iir_Kind_Inequality_Operator + | Iir_Kind_Less_Than_Operator + | Iir_Kind_Less_Than_Or_Equal_Operator + | Iir_Kind_Greater_Than_Operator + | Iir_Kind_Greater_Than_Or_Equal_Operator + | Iir_Kind_Match_Equality_Operator + | Iir_Kind_Match_Inequality_Operator + | Iir_Kind_Match_Less_Than_Operator + | Iir_Kind_Match_Less_Than_Or_Equal_Operator + | Iir_Kind_Match_Greater_Than_Operator + | Iir_Kind_Match_Greater_Than_Or_Equal_Operator + | Iir_Kind_Sll_Operator + | Iir_Kind_Sla_Operator + | Iir_Kind_Srl_Operator + | Iir_Kind_Sra_Operator + | Iir_Kind_Rol_Operator + | Iir_Kind_Ror_Operator + | Iir_Kind_Addition_Operator + | Iir_Kind_Substraction_Operator + | Iir_Kind_Concatenation_Operator + | Iir_Kind_Multiplication_Operator + | Iir_Kind_Division_Operator + | Iir_Kind_Modulus_Operator + | Iir_Kind_Remainder_Operator + | Iir_Kind_Exponentiation_Operator + | Iir_Kind_Function_Call + | Iir_Kind_Aggregate + | Iir_Kind_Parenthesis_Expression + | Iir_Kind_Qualified_Expression + | Iir_Kind_Type_Conversion + | Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Psl_Expression + | Iir_Kind_Return_Statement + | Iir_Kind_Character_Literal + | Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Operator_Symbol + | Iir_Kind_Selected_By_All_Name + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Base_Attribute + | Iir_Kind_Left_Type_Attribute + | Iir_Kind_Right_Type_Attribute + | Iir_Kind_High_Type_Attribute + | Iir_Kind_Low_Type_Attribute + | Iir_Kind_Ascending_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute + | Iir_Kind_Pos_Attribute + | Iir_Kind_Val_Attribute + | Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute + | Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Event_Attribute + | Iir_Kind_Active_Attribute + | Iir_Kind_Last_Event_Attribute + | Iir_Kind_Last_Active_Attribute + | Iir_Kind_Last_Value_Attribute + | Iir_Kind_Driving_Attribute + | Iir_Kind_Driving_Value_Attribute + | Iir_Kind_Simple_Name_Attribute + | Iir_Kind_Instance_Name_Attribute + | Iir_Kind_Path_Name_Attribute + | Iir_Kind_Left_Array_Attribute + | Iir_Kind_Right_Array_Attribute + | Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute + | Iir_Kind_Length_Array_Attribute + | Iir_Kind_Ascending_Array_Attribute + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Attribute_Name => + return True; + when others => + return False; + end case; + end Has_Type; + + function Has_Subtype_Indication (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Element_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Allocator_By_Subtype => + return True; + when others => + return False; + end case; + end Has_Subtype_Indication; + + function Has_Discrete_Range (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Iterator_Declaration; + end Has_Discrete_Range; + + function Has_Type_Definition (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + return True; + when others => + return False; + end case; + end Has_Type_Definition; + + function Has_Subtype_Definition (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Anonymous_Type_Declaration; + end Has_Subtype_Definition; + + function Has_Nature (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration + | Iir_Kind_Terminal_Declaration => + return True; + when others => + return False; + end case; + end Has_Nature; + + function Has_Mode (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_File_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration => + return True; + when others => + return False; + end case; + end Has_Mode; + + function Has_Signal_Kind (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + return True; + when others => + return False; + end case; + end Has_Signal_Kind; + + function Has_Base_Name (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Attribute_Value + | Iir_Kind_Function_Call + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Operator_Symbol + | Iir_Kind_Selected_By_All_Name + | Iir_Kind_Left_Type_Attribute + | Iir_Kind_Right_Type_Attribute + | Iir_Kind_High_Type_Attribute + | Iir_Kind_Low_Type_Attribute + | Iir_Kind_Ascending_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute + | Iir_Kind_Pos_Attribute + | Iir_Kind_Val_Attribute + | Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute + | Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Simple_Name_Attribute + | Iir_Kind_Instance_Name_Attribute + | Iir_Kind_Path_Name_Attribute + | Iir_Kind_Left_Array_Attribute + | Iir_Kind_Right_Array_Attribute + | Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute + | Iir_Kind_Length_Array_Attribute + | Iir_Kind_Ascending_Array_Attribute + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Attribute_Name => + return True; + when others => + return False; + end case; + end Has_Base_Name; + + function Has_Interface_Declaration_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when others => + return False; + end case; + end Has_Interface_Declaration_Chain; + + function Has_Subprogram_Specification (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + return True; + when others => + return False; + end case; + end Has_Subprogram_Specification; + + function Has_Sequential_Statement_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_If_Statement + | Iir_Kind_Elsif => + return True; + when others => + return False; + end case; + end Has_Sequential_Statement_Chain; + + function Has_Subprogram_Body (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when others => + return False; + end case; + end Has_Subprogram_Body; + + function Has_Overload_Number (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when others => + return False; + end case; + end Has_Overload_Number; + + function Has_Subprogram_Depth (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when others => + return False; + end case; + end Has_Subprogram_Depth; + + function Has_Subprogram_Hash (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when others => + return False; + end case; + end Has_Subprogram_Hash; + + function Has_Impure_Depth (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + return True; + when others => + return False; + end case; + end Has_Impure_Depth; + + function Has_Return_Type (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration => + return True; + when others => + return False; + end case; + end Has_Return_Type; + + function Has_Implicit_Definition (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + return True; + when others => + return False; + end case; + end Has_Implicit_Definition; + + function Has_Type_Reference (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + return True; + when others => + return False; + end case; + end Has_Type_Reference; + + function Has_Default_Value (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration => + return True; + when others => + return False; + end case; + end Has_Default_Value; + + function Has_Deferred_Declaration (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Constant_Declaration; + end Has_Deferred_Declaration; + + function Has_Deferred_Declaration_Flag (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Constant_Declaration; + end Has_Deferred_Declaration_Flag; + + function Has_Shared_Flag (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Variable_Declaration; + end Has_Shared_Flag; + + function Has_Design_Unit (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body => + return True; + when others => + return False; + end case; + end Has_Design_Unit; + + function Has_Block_Statement (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Guard_Signal_Declaration; + end Has_Block_Statement; + + function Has_Signal_Driver (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Signal_Declaration; + end Has_Signal_Driver; + + function Has_Declaration_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Block_Configuration + | Iir_Kind_Protected_Type_Declaration + | Iir_Kind_Protected_Type_Body + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + return True; + when others => + return False; + end case; + end Has_Declaration_Chain; + + function Has_File_Logical_Name (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_File_Declaration; + end Has_File_Logical_Name; + + function Has_File_Open_Kind (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_File_Declaration; + end Has_File_Open_Kind; + + function Has_Element_Position (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Record_Element_Constraint + | Iir_Kind_Element_Declaration => + return True; + when others => + return False; + end case; + end Has_Element_Position; + + function Has_Element_Declaration (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Record_Element_Constraint; + end Has_Element_Declaration; + + function Has_Selected_Element (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Selected_Element; + end Has_Selected_Element; + + function Has_Use_Clause_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Use_Clause; + end Has_Use_Clause_Chain; + + function Has_Selected_Name (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Use_Clause; + end Has_Selected_Name; + + function Has_Type_Declarator (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Error + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Incomplete_Type_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Protected_Type_Declaration + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + return True; + when others => + return False; + end case; + end Has_Type_Declarator; + + function Has_Enumeration_Literal_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Enumeration_Type_Definition; + end Has_Enumeration_Literal_List; + + function Has_Entity_Class_Entry_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Group_Template_Declaration; + end Has_Entity_Class_Entry_Chain; + + function Has_Group_Constituent_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Group_Declaration; + end Has_Group_Constituent_List; + + function Has_Unit_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Physical_Type_Definition; + end Has_Unit_Chain; + + function Has_Primary_Unit (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Physical_Type_Definition; + end Has_Primary_Unit; + + function Has_Identifier (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Design_Unit + | Iir_Kind_Library_Clause + | Iir_Kind_Record_Element_Constraint + | Iir_Kind_Record_Element_Resolution + | Iir_Kind_Protected_Type_Body + | Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Unit_Declaration + | Iir_Kind_Library_Declaration + | Iir_Kind_Component_Declaration + | 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_Psl_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement + | Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Null_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement + | Iir_Kind_Wait_Statement + | Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_Case_Statement + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_If_Statement + | Iir_Kind_Character_Literal + | Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Operator_Symbol + | Iir_Kind_Attribute_Name => + return True; + when others => + return False; + end case; + end Has_Identifier; + + function Has_Label (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement + | Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Null_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement + | Iir_Kind_Wait_Statement + | Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_Case_Statement + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_If_Statement => + return True; + when others => + return False; + end case; + end Has_Label; + + function Has_Visible_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Record_Element_Constraint + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Unit_Declaration + | Iir_Kind_Library_Declaration + | Iir_Kind_Component_Declaration + | 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_Psl_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement + | Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Null_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement + | Iir_Kind_Wait_Statement + | Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_Case_Statement + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_If_Statement => + return True; + when others => + return False; + end case; + end Has_Visible_Flag; + + function Has_Range_Constraint (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Subtype_Definition => + return True; + when others => + return False; + end case; + end Has_Range_Constraint; + + function Has_Direction (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Range_Expression; + end Has_Direction; + + function Has_Left_Limit (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Range_Expression; + end Has_Left_Limit; + + function Has_Right_Limit (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Range_Expression; + end Has_Right_Limit; + + function Has_Base_Type (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Error + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Incomplete_Type_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Protected_Type_Declaration + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + return True; + when others => + return False; + end case; + end Has_Base_Type; + + function Has_Resolution_Indication (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Array_Element_Resolution + | Iir_Kind_Record_Element_Resolution + | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Subtype_Definition => + return True; + when others => + return False; + end case; + end Has_Resolution_Indication; + + function Has_Record_Element_Resolution_Chain (K : Iir_Kind) + return Boolean is + begin + return K = Iir_Kind_Record_Resolution; + end Has_Record_Element_Resolution_Chain; + + function Has_Tolerance (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Subtype_Definition + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Simple_Simultaneous_Statement => + return True; + when others => + return False; + end case; + end Has_Tolerance; + + function Has_Plus_Terminal (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + return True; + when others => + return False; + end case; + end Has_Plus_Terminal; + + function Has_Minus_Terminal (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + return True; + when others => + return False; + end case; + end Has_Minus_Terminal; + + function Has_Simultaneous_Left (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Simple_Simultaneous_Statement; + end Has_Simultaneous_Left; + + function Has_Simultaneous_Right (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Simple_Simultaneous_Statement; + end Has_Simultaneous_Right; + + function Has_Text_File_Flag (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_File_Type_Definition; + end Has_Text_File_Flag; + + function Has_Only_Characters_Flag (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Enumeration_Type_Definition; + end Has_Only_Characters_Flag; + + function Has_Type_Staticness (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Error + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Incomplete_Type_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Protected_Type_Declaration + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + return True; + when others => + return False; + end case; + end Has_Type_Staticness; + + function Has_Constraint_State (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition => + return True; + when others => + return False; + end case; + end Has_Constraint_State; + + function Has_Index_Subtype_List (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + return True; + when others => + return False; + end case; + end Has_Index_Subtype_List; + + function Has_Index_Subtype_Definition_List (K : Iir_Kind) + return Boolean is + begin + return K = Iir_Kind_Array_Type_Definition; + end Has_Index_Subtype_Definition_List; + + function Has_Element_Subtype_Indication (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Array_Type_Definition; + end Has_Element_Subtype_Indication; + + function Has_Element_Subtype (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + return True; + when others => + return False; + end case; + end Has_Element_Subtype; + + function Has_Index_Constraint_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Array_Subtype_Definition; + end Has_Index_Constraint_List; + + function Has_Array_Element_Constraint (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Array_Subtype_Definition; + end Has_Array_Element_Constraint; + + function Has_Elements_Declaration_List (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + return True; + when others => + return False; + end case; + end Has_Elements_Declaration_List; + + function Has_Designated_Type (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + return True; + when others => + return False; + end case; + end Has_Designated_Type; + + function Has_Designated_Subtype_Indication (K : Iir_Kind) + return Boolean is + begin + case K is + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + return True; + when others => + return False; + end case; + end Has_Designated_Subtype_Indication; + + function Has_Index_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Indexed_Name; + end Has_Index_List; + + function Has_Reference (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Scalar_Nature_Definition; + end Has_Reference; + + function Has_Nature_Declarator (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Scalar_Nature_Definition; + end Has_Nature_Declarator; + + function Has_Across_Type (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Scalar_Nature_Definition; + end Has_Across_Type; + + function Has_Through_Type (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Scalar_Nature_Definition; + end Has_Through_Type; + + function Has_Target (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Variable_Assignment_Statement => + return True; + when others => + return False; + end case; + end Has_Target; + + function Has_Waveform_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Conditional_Waveform + | Iir_Kind_Signal_Assignment_Statement => + return True; + when others => + return False; + end case; + end Has_Waveform_Chain; + + function Has_Guard (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment => + return True; + when others => + return False; + end case; + end Has_Guard; + + function Has_Delay_Mechanism (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Signal_Assignment_Statement => + return True; + when others => + return False; + end case; + end Has_Delay_Mechanism; + + function Has_Reject_Time_Expression (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Signal_Assignment_Statement => + return True; + when others => + return False; + end case; + end Has_Reject_Time_Expression; + + function Has_Sensitivity_List (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Wait_Statement => + return True; + when others => + return False; + end case; + end Has_Sensitivity_List; + + function Has_Process_Origin (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + return True; + when others => + return False; + end case; + end Has_Process_Origin; + + function Has_Condition_Clause (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Wait_Statement; + end Has_Condition_Clause; + + function Has_Timeout_Clause (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Wait_Statement; + end Has_Timeout_Clause; + + function Has_Postponed_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Concurrent_Procedure_Call_Statement => + return True; + when others => + return False; + end case; + end Has_Postponed_Flag; + + function Has_Callees_List (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + return True; + when others => + return False; + end case; + end Has_Callees_List; + + function Has_Passive_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + return True; + when others => + return False; + end case; + end Has_Passive_Flag; + + function Has_Resolution_Function_Flag (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Function_Declaration; + end Has_Resolution_Function_Flag; + + function Has_Wait_State (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + return True; + when others => + return False; + end case; + end Has_Wait_State; + + function Has_All_Sensitized_State (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when others => + return False; + end case; + end Has_All_Sensitized_State; + + function Has_Seen_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + return True; + when others => + return False; + end case; + end Has_Seen_Flag; + + function Has_Pure_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration => + return True; + when others => + return False; + end case; + end Has_Pure_Flag; + + function Has_Foreign_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Architecture_Body + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when others => + return False; + end case; + end Has_Foreign_Flag; + + function Has_Resolved_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Error + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Incomplete_Type_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Protected_Type_Declaration + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + return True; + when others => + return False; + end case; + end Has_Resolved_Flag; + + function Has_Signal_Type_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Error + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Incomplete_Type_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Protected_Type_Declaration + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + return True; + when others => + return False; + end case; + end Has_Signal_Type_Flag; + + function Has_Has_Signal_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Error + | Iir_Kind_Incomplete_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + return True; + when others => + return False; + end case; + end Has_Has_Signal_Flag; + + function Has_Purity_State (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Procedure_Declaration; + end Has_Purity_State; + + function Has_Elab_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Design_File + | Iir_Kind_Design_Unit => + return True; + when others => + return False; + end case; + end Has_Elab_Flag; + + function Has_Index_Constraint_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + return True; + when others => + return False; + end case; + end Has_Index_Constraint_Flag; + + function Has_Assertion_Condition (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Assertion_Statement => + return True; + when others => + return False; + end case; + end Has_Assertion_Condition; + + function Has_Report_Expression (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement => + return True; + when others => + return False; + end case; + end Has_Report_Expression; + + function Has_Severity_Expression (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement => + return True; + when others => + return False; + end case; + end Has_Severity_Expression; + + function Has_Instantiated_Unit (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Component_Instantiation_Statement; + end Has_Instantiated_Unit; + + function Has_Generic_Map_Aspect_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Block_Header + | Iir_Kind_Binding_Indication + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Package_Header + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Component_Instantiation_Statement => + return True; + when others => + return False; + end case; + end Has_Generic_Map_Aspect_Chain; + + function Has_Port_Map_Aspect_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Block_Header + | Iir_Kind_Binding_Indication + | Iir_Kind_Component_Instantiation_Statement => + return True; + when others => + return False; + end case; + end Has_Port_Map_Aspect_Chain; + + function Has_Configuration_Name (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Entity_Aspect_Configuration; + end Has_Configuration_Name; + + function Has_Component_Configuration (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Component_Instantiation_Statement; + end Has_Component_Configuration; + + function Has_Configuration_Specification (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Component_Instantiation_Statement; + end Has_Configuration_Specification; + + function Has_Default_Binding_Indication (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Component_Instantiation_Statement; + end Has_Default_Binding_Indication; + + function Has_Default_Configuration_Declaration (K : Iir_Kind) + return Boolean is + begin + return K = Iir_Kind_Architecture_Body; + end Has_Default_Configuration_Declaration; + + function Has_Expression (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Attribute_Specification + | Iir_Kind_Disconnection_Specification + | Iir_Kind_Parenthesis_Expression + | Iir_Kind_Qualified_Expression + | Iir_Kind_Type_Conversion + | Iir_Kind_Allocator_By_Expression + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_Case_Statement => + return True; + when others => + return False; + end case; + end Has_Expression; + + function Has_Allocator_Designated_Type (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype => + return True; + when others => + return False; + end case; + end Has_Allocator_Designated_Type; + + function Has_Selected_Waveform_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Concurrent_Selected_Signal_Assignment; + end Has_Selected_Waveform_Chain; + + function Has_Conditional_Waveform_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Concurrent_Conditional_Signal_Assignment; + end Has_Conditional_Waveform_Chain; + + function Has_Guard_Expression (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Guard_Signal_Declaration; + end Has_Guard_Expression; + + function Has_Guard_Decl (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Block_Statement; + end Has_Guard_Decl; + + function Has_Guard_Sensitivity_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Guard_Signal_Declaration; + end Has_Guard_Sensitivity_List; + + function Has_Block_Block_Configuration (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Block_Statement; + end Has_Block_Block_Configuration; + + function Has_Package_Header (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Package_Declaration; + end Has_Package_Header; + + function Has_Block_Header (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Block_Statement; + end Has_Block_Header; + + function Has_Uninstantiated_Package_Name (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Interface_Package_Declaration => + return True; + when others => + return False; + end case; + end Has_Uninstantiated_Package_Name; + + function Has_Generate_Block_Configuration (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Generate_Statement; + end Has_Generate_Block_Configuration; + + function Has_Generation_Scheme (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Generate_Statement; + end Has_Generation_Scheme; + + function Has_Condition (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Conditional_Waveform + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_If_Statement + | Iir_Kind_Elsif => + return True; + when others => + return False; + end case; + end Has_Condition; + + function Has_Else_Clause (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_If_Statement + | Iir_Kind_Elsif => + return True; + when others => + return False; + end case; + end Has_Else_Clause; + + function Has_Parameter_Specification (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_For_Loop_Statement; + end Has_Parameter_Specification; + + function Has_Parent (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Design_File + | Iir_Kind_Design_Unit + | Iir_Kind_Library_Clause + | Iir_Kind_Use_Clause + | Iir_Kind_Choice_By_Others + | Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_None + | Iir_Kind_Choice_By_Name + | Iir_Kind_Block_Configuration + | Iir_Kind_Component_Configuration + | Iir_Kind_Record_Element_Constraint + | Iir_Kind_Attribute_Specification + | Iir_Kind_Disconnection_Specification + | Iir_Kind_Configuration_Specification + | Iir_Kind_Protected_Type_Body + | Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Unit_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration + | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Psl_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement + | Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Null_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement + | Iir_Kind_Wait_Statement + | Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_Case_Statement + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_If_Statement + | Iir_Kind_Elsif => + return True; + when others => + return False; + end case; + end Has_Parent; + + function Has_Loop_Label (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement => + return True; + when others => + return False; + end case; + end Has_Loop_Label; + + function Has_Component_Name (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Component_Configuration + | Iir_Kind_Configuration_Specification => + return True; + when others => + return False; + end case; + end Has_Component_Name; + + function Has_Instantiation_List (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Component_Configuration + | Iir_Kind_Configuration_Specification => + return True; + when others => + return False; + end case; + end Has_Instantiation_List; + + function Has_Entity_Aspect (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Binding_Indication; + end Has_Entity_Aspect; + + function Has_Default_Entity_Aspect (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Binding_Indication; + end Has_Default_Entity_Aspect; + + function Has_Default_Generic_Map_Aspect_Chain (K : Iir_Kind) + return Boolean is + begin + return K = Iir_Kind_Binding_Indication; + end Has_Default_Generic_Map_Aspect_Chain; + + function Has_Default_Port_Map_Aspect_Chain (K : Iir_Kind) + return Boolean is + begin + return K = Iir_Kind_Binding_Indication; + end Has_Default_Port_Map_Aspect_Chain; + + function Has_Binding_Indication (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Component_Configuration + | Iir_Kind_Configuration_Specification => + return True; + when others => + return False; + end case; + end Has_Binding_Indication; + + function Has_Named_Entity (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Character_Literal + | Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Operator_Symbol + | Iir_Kind_Selected_By_All_Name + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Attribute_Name => + return True; + when others => + return False; + end case; + end Has_Named_Entity; + + function Has_Alias_Declaration (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Character_Literal + | Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Operator_Symbol => + return True; + when others => + return False; + end case; + end Has_Alias_Declaration; + + function Has_Expr_Staticness (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Error + | Iir_Kind_Integer_Literal + | Iir_Kind_Floating_Point_Literal + | Iir_Kind_Null_Literal + | Iir_Kind_String_Literal + | Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Bit_String_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Overflow_Literal + | Iir_Kind_Attribute_Value + | Iir_Kind_Range_Expression + | Iir_Kind_Unit_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Identity_Operator + | Iir_Kind_Negation_Operator + | Iir_Kind_Absolute_Operator + | Iir_Kind_Not_Operator + | Iir_Kind_Condition_Operator + | Iir_Kind_Reduction_And_Operator + | Iir_Kind_Reduction_Or_Operator + | Iir_Kind_Reduction_Nand_Operator + | Iir_Kind_Reduction_Nor_Operator + | Iir_Kind_Reduction_Xor_Operator + | Iir_Kind_Reduction_Xnor_Operator + | Iir_Kind_And_Operator + | Iir_Kind_Or_Operator + | Iir_Kind_Nand_Operator + | Iir_Kind_Nor_Operator + | Iir_Kind_Xor_Operator + | Iir_Kind_Xnor_Operator + | Iir_Kind_Equality_Operator + | Iir_Kind_Inequality_Operator + | Iir_Kind_Less_Than_Operator + | Iir_Kind_Less_Than_Or_Equal_Operator + | Iir_Kind_Greater_Than_Operator + | Iir_Kind_Greater_Than_Or_Equal_Operator + | Iir_Kind_Match_Equality_Operator + | Iir_Kind_Match_Inequality_Operator + | Iir_Kind_Match_Less_Than_Operator + | Iir_Kind_Match_Less_Than_Or_Equal_Operator + | Iir_Kind_Match_Greater_Than_Operator + | Iir_Kind_Match_Greater_Than_Or_Equal_Operator + | Iir_Kind_Sll_Operator + | Iir_Kind_Sla_Operator + | Iir_Kind_Srl_Operator + | Iir_Kind_Sra_Operator + | Iir_Kind_Rol_Operator + | Iir_Kind_Ror_Operator + | Iir_Kind_Addition_Operator + | Iir_Kind_Substraction_Operator + | Iir_Kind_Concatenation_Operator + | Iir_Kind_Multiplication_Operator + | Iir_Kind_Division_Operator + | Iir_Kind_Modulus_Operator + | Iir_Kind_Remainder_Operator + | Iir_Kind_Exponentiation_Operator + | Iir_Kind_Function_Call + | Iir_Kind_Aggregate + | Iir_Kind_Parenthesis_Expression + | Iir_Kind_Qualified_Expression + | Iir_Kind_Type_Conversion + | Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Selected_By_All_Name + | Iir_Kind_Left_Type_Attribute + | Iir_Kind_Right_Type_Attribute + | Iir_Kind_High_Type_Attribute + | Iir_Kind_Low_Type_Attribute + | Iir_Kind_Ascending_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute + | Iir_Kind_Pos_Attribute + | Iir_Kind_Val_Attribute + | Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute + | Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Event_Attribute + | Iir_Kind_Active_Attribute + | Iir_Kind_Last_Event_Attribute + | Iir_Kind_Last_Active_Attribute + | Iir_Kind_Last_Value_Attribute + | Iir_Kind_Driving_Attribute + | Iir_Kind_Driving_Value_Attribute + | Iir_Kind_Simple_Name_Attribute + | Iir_Kind_Instance_Name_Attribute + | Iir_Kind_Path_Name_Attribute + | Iir_Kind_Left_Array_Attribute + | Iir_Kind_Right_Array_Attribute + | Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute + | Iir_Kind_Length_Array_Attribute + | Iir_Kind_Ascending_Array_Attribute + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Attribute_Name => + return True; + when others => + return False; + end case; + end Has_Expr_Staticness; + + function Has_Error_Origin (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Error; + end Has_Error_Origin; + + function Has_Operand (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Identity_Operator + | Iir_Kind_Negation_Operator + | Iir_Kind_Absolute_Operator + | Iir_Kind_Not_Operator + | Iir_Kind_Condition_Operator + | Iir_Kind_Reduction_And_Operator + | Iir_Kind_Reduction_Or_Operator + | Iir_Kind_Reduction_Nand_Operator + | Iir_Kind_Reduction_Nor_Operator + | Iir_Kind_Reduction_Xor_Operator + | Iir_Kind_Reduction_Xnor_Operator => + return True; + when others => + return False; + end case; + end Has_Operand; + + function Has_Left (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_And_Operator + | Iir_Kind_Or_Operator + | Iir_Kind_Nand_Operator + | Iir_Kind_Nor_Operator + | Iir_Kind_Xor_Operator + | Iir_Kind_Xnor_Operator + | Iir_Kind_Equality_Operator + | Iir_Kind_Inequality_Operator + | Iir_Kind_Less_Than_Operator + | Iir_Kind_Less_Than_Or_Equal_Operator + | Iir_Kind_Greater_Than_Operator + | Iir_Kind_Greater_Than_Or_Equal_Operator + | Iir_Kind_Match_Equality_Operator + | Iir_Kind_Match_Inequality_Operator + | Iir_Kind_Match_Less_Than_Operator + | Iir_Kind_Match_Less_Than_Or_Equal_Operator + | Iir_Kind_Match_Greater_Than_Operator + | Iir_Kind_Match_Greater_Than_Or_Equal_Operator + | Iir_Kind_Sll_Operator + | Iir_Kind_Sla_Operator + | Iir_Kind_Srl_Operator + | Iir_Kind_Sra_Operator + | Iir_Kind_Rol_Operator + | Iir_Kind_Ror_Operator + | Iir_Kind_Addition_Operator + | Iir_Kind_Substraction_Operator + | Iir_Kind_Concatenation_Operator + | Iir_Kind_Multiplication_Operator + | Iir_Kind_Division_Operator + | Iir_Kind_Modulus_Operator + | Iir_Kind_Remainder_Operator + | Iir_Kind_Exponentiation_Operator => + return True; + when others => + return False; + end case; + end Has_Left; + + function Has_Right (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_And_Operator + | Iir_Kind_Or_Operator + | Iir_Kind_Nand_Operator + | Iir_Kind_Nor_Operator + | Iir_Kind_Xor_Operator + | Iir_Kind_Xnor_Operator + | Iir_Kind_Equality_Operator + | Iir_Kind_Inequality_Operator + | Iir_Kind_Less_Than_Operator + | Iir_Kind_Less_Than_Or_Equal_Operator + | Iir_Kind_Greater_Than_Operator + | Iir_Kind_Greater_Than_Or_Equal_Operator + | Iir_Kind_Match_Equality_Operator + | Iir_Kind_Match_Inequality_Operator + | Iir_Kind_Match_Less_Than_Operator + | Iir_Kind_Match_Less_Than_Or_Equal_Operator + | Iir_Kind_Match_Greater_Than_Operator + | Iir_Kind_Match_Greater_Than_Or_Equal_Operator + | Iir_Kind_Sll_Operator + | Iir_Kind_Sla_Operator + | Iir_Kind_Srl_Operator + | Iir_Kind_Sra_Operator + | Iir_Kind_Rol_Operator + | Iir_Kind_Ror_Operator + | Iir_Kind_Addition_Operator + | Iir_Kind_Substraction_Operator + | Iir_Kind_Concatenation_Operator + | Iir_Kind_Multiplication_Operator + | Iir_Kind_Division_Operator + | Iir_Kind_Modulus_Operator + | Iir_Kind_Remainder_Operator + | Iir_Kind_Exponentiation_Operator => + return True; + when others => + return False; + end case; + end Has_Right; + + function Has_Unit_Name (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal => + return True; + when others => + return False; + end case; + end Has_Unit_Name; + + function Has_Name (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Object_Alias_Declaration => + return True; + when others => + return False; + end case; + end Has_Name; + + function Has_Group_Template_Name (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Group_Declaration; + end Has_Group_Template_Name; + + function Has_Name_Staticness (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Attribute_Value + | Iir_Kind_Unit_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Function_Call + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Left_Type_Attribute + | Iir_Kind_Right_Type_Attribute + | Iir_Kind_High_Type_Attribute + | Iir_Kind_Low_Type_Attribute + | Iir_Kind_Ascending_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute + | Iir_Kind_Pos_Attribute + | Iir_Kind_Val_Attribute + | Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute + | Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Event_Attribute + | Iir_Kind_Active_Attribute + | Iir_Kind_Last_Event_Attribute + | Iir_Kind_Last_Active_Attribute + | Iir_Kind_Last_Value_Attribute + | Iir_Kind_Driving_Attribute + | Iir_Kind_Driving_Value_Attribute + | Iir_Kind_Simple_Name_Attribute + | Iir_Kind_Instance_Name_Attribute + | Iir_Kind_Path_Name_Attribute + | Iir_Kind_Left_Array_Attribute + | Iir_Kind_Right_Array_Attribute + | Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute + | Iir_Kind_Length_Array_Attribute + | Iir_Kind_Ascending_Array_Attribute + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Attribute_Name => + return True; + when others => + return False; + end case; + end Has_Name_Staticness; + + function Has_Prefix (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Procedure_Call + | Iir_Kind_Function_Call + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Selected_By_All_Name + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Base_Attribute + | Iir_Kind_Left_Type_Attribute + | Iir_Kind_Right_Type_Attribute + | Iir_Kind_High_Type_Attribute + | Iir_Kind_Low_Type_Attribute + | Iir_Kind_Ascending_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute + | Iir_Kind_Pos_Attribute + | Iir_Kind_Val_Attribute + | Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute + | Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Event_Attribute + | Iir_Kind_Active_Attribute + | Iir_Kind_Last_Event_Attribute + | Iir_Kind_Last_Active_Attribute + | Iir_Kind_Last_Value_Attribute + | Iir_Kind_Driving_Attribute + | Iir_Kind_Driving_Value_Attribute + | Iir_Kind_Simple_Name_Attribute + | Iir_Kind_Instance_Name_Attribute + | Iir_Kind_Path_Name_Attribute + | Iir_Kind_Left_Array_Attribute + | Iir_Kind_Right_Array_Attribute + | Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute + | Iir_Kind_Length_Array_Attribute + | Iir_Kind_Ascending_Array_Attribute + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Attribute_Name => + return True; + when others => + return False; + end case; + end Has_Prefix; + + function Has_Signature_Prefix (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Signature; + end Has_Signature_Prefix; + + function Has_Slice_Subtype (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Slice_Name; + end Has_Slice_Subtype; + + function Has_Suffix (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Slice_Name; + end Has_Suffix; + + function Has_Index_Subtype (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Left_Array_Attribute + | Iir_Kind_Right_Array_Attribute + | Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute + | Iir_Kind_Length_Array_Attribute + | Iir_Kind_Ascending_Array_Attribute + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + return True; + when others => + return False; + end case; + end Has_Index_Subtype; + + function Has_Parameter (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute + | Iir_Kind_Pos_Attribute + | Iir_Kind_Val_Attribute + | Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute + | Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Left_Array_Attribute + | Iir_Kind_Right_Array_Attribute + | Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute + | Iir_Kind_Length_Array_Attribute + | Iir_Kind_Ascending_Array_Attribute + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + return True; + when others => + return False; + end case; + end Has_Parameter; + + function Has_Actual_Type (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Association_Element_By_Individual; + end Has_Actual_Type; + + function Has_Associated_Interface (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Association_Element_Package; + end Has_Associated_Interface; + + function Has_Association_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Parenthesis_Name; + end Has_Association_Chain; + + function Has_Individual_Association_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Association_Element_By_Individual; + end Has_Individual_Association_Chain; + + function Has_Aggregate_Info (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Aggregate; + end Has_Aggregate_Info; + + function Has_Sub_Aggregate_Info (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Aggregate_Info; + end Has_Sub_Aggregate_Info; + + function Has_Aggr_Dynamic_Flag (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Aggregate_Info; + end Has_Aggr_Dynamic_Flag; + + function Has_Aggr_Min_Length (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Aggregate_Info; + end Has_Aggr_Min_Length; + + function Has_Aggr_Low_Limit (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Aggregate_Info; + end Has_Aggr_Low_Limit; + + function Has_Aggr_High_Limit (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Aggregate_Info; + end Has_Aggr_High_Limit; + + function Has_Aggr_Others_Flag (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Aggregate_Info; + end Has_Aggr_Others_Flag; + + function Has_Aggr_Named_Flag (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Aggregate_Info; + end Has_Aggr_Named_Flag; + + function Has_Value_Staticness (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Aggregate; + end Has_Value_Staticness; + + function Has_Association_Choices_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Aggregate; + end Has_Association_Choices_Chain; + + function Has_Case_Statement_Alternative_Chain (K : Iir_Kind) + return Boolean is + begin + return K = Iir_Kind_Case_Statement; + end Has_Case_Statement_Alternative_Chain; + + function Has_Choice_Staticness (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range => + return True; + when others => + return False; + end case; + end Has_Choice_Staticness; + + function Has_Procedure_Call (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Procedure_Call_Statement => + return True; + when others => + return False; + end case; + end Has_Procedure_Call; + + function Has_Implementation (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Procedure_Call + | Iir_Kind_Identity_Operator + | Iir_Kind_Negation_Operator + | Iir_Kind_Absolute_Operator + | Iir_Kind_Not_Operator + | Iir_Kind_Condition_Operator + | Iir_Kind_Reduction_And_Operator + | Iir_Kind_Reduction_Or_Operator + | Iir_Kind_Reduction_Nand_Operator + | Iir_Kind_Reduction_Nor_Operator + | Iir_Kind_Reduction_Xor_Operator + | Iir_Kind_Reduction_Xnor_Operator + | Iir_Kind_And_Operator + | Iir_Kind_Or_Operator + | Iir_Kind_Nand_Operator + | Iir_Kind_Nor_Operator + | Iir_Kind_Xor_Operator + | Iir_Kind_Xnor_Operator + | Iir_Kind_Equality_Operator + | Iir_Kind_Inequality_Operator + | Iir_Kind_Less_Than_Operator + | Iir_Kind_Less_Than_Or_Equal_Operator + | Iir_Kind_Greater_Than_Operator + | Iir_Kind_Greater_Than_Or_Equal_Operator + | Iir_Kind_Match_Equality_Operator + | Iir_Kind_Match_Inequality_Operator + | Iir_Kind_Match_Less_Than_Operator + | Iir_Kind_Match_Less_Than_Or_Equal_Operator + | Iir_Kind_Match_Greater_Than_Operator + | Iir_Kind_Match_Greater_Than_Or_Equal_Operator + | Iir_Kind_Sll_Operator + | Iir_Kind_Sla_Operator + | Iir_Kind_Srl_Operator + | Iir_Kind_Sra_Operator + | Iir_Kind_Rol_Operator + | Iir_Kind_Ror_Operator + | Iir_Kind_Addition_Operator + | Iir_Kind_Substraction_Operator + | Iir_Kind_Concatenation_Operator + | Iir_Kind_Multiplication_Operator + | Iir_Kind_Division_Operator + | Iir_Kind_Modulus_Operator + | Iir_Kind_Remainder_Operator + | Iir_Kind_Exponentiation_Operator + | Iir_Kind_Function_Call => + return True; + when others => + return False; + end case; + end Has_Implementation; + + function Has_Parameter_Association_Chain (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Procedure_Call + | Iir_Kind_Function_Call => + return True; + when others => + return False; + end case; + end Has_Parameter_Association_Chain; + + function Has_Method_Object (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Procedure_Call + | Iir_Kind_Function_Call => + return True; + when others => + return False; + end case; + end Has_Method_Object; + + function Has_Subtype_Type_Mark (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Subtype_Definition => + return True; + when others => + return False; + end case; + end Has_Subtype_Type_Mark; + + function Has_Type_Conversion_Subtype (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Type_Conversion; + end Has_Type_Conversion_Subtype; + + function Has_Type_Mark (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Disconnection_Specification + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Qualified_Expression + | Iir_Kind_Type_Conversion => + return True; + when others => + return False; + end case; + end Has_Type_Mark; + + function Has_File_Type_Mark (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_File_Type_Definition; + end Has_File_Type_Mark; + + function Has_Return_Type_Mark (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Signature + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when others => + return False; + end case; + end Has_Return_Type_Mark; + + function Has_Lexical_Layout (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration => + return True; + when others => + return False; + end case; + end Has_Lexical_Layout; + + function Has_Incomplete_Type_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Incomplete_Type_Definition; + end Has_Incomplete_Type_List; + + function Has_Has_Disconnect_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + return True; + when others => + return False; + end case; + end Has_Has_Disconnect_Flag; + + function Has_Has_Active_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute => + return True; + when others => + return False; + end case; + end Has_Has_Active_Flag; + + function Has_Is_Within_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_For_Loop_Statement => + return True; + when others => + return False; + end case; + end Has_Is_Within_Flag; + + function Has_Type_Marks_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Signature; + end Has_Type_Marks_List; + + function Has_Implicit_Alias_Flag (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Non_Object_Alias_Declaration; + end Has_Implicit_Alias_Flag; + + function Has_Alias_Signature (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Non_Object_Alias_Declaration; + end Has_Alias_Signature; + + function Has_Attribute_Signature (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Attribute_Name; + end Has_Attribute_Signature; + + function Has_Overload_List (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Overload_List; + end Has_Overload_List; + + function Has_Simple_Name_Identifier (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Simple_Name_Attribute; + end Has_Simple_Name_Identifier; + + function Has_Simple_Name_Subtype (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Simple_Name_Attribute; + end Has_Simple_Name_Subtype; + + function Has_Protected_Type_Body (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Protected_Type_Declaration; + end Has_Protected_Type_Body; + + function Has_Protected_Type_Declaration (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Protected_Type_Body; + end Has_Protected_Type_Declaration; + + function Has_End_Location (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Design_Unit; + end Has_End_Location; + + function Has_String_Id (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + return True; + when others => + return False; + end case; + end Has_String_Id; + + function Has_String_Length (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + return True; + when others => + return False; + end case; + end Has_String_Length; + + function Has_Use_Flag (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration + | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Psl_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration => + return True; + when others => + return False; + end case; + end Has_Use_Flag; + + function Has_End_Has_Reserved_Id (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Protected_Type_Declaration + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Protected_Type_Body + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Component_Declaration + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + return True; + when others => + return False; + end case; + end Has_End_Has_Reserved_Id; + + function Has_End_Has_Identifier (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Protected_Type_Declaration + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Protected_Type_Body + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Component_Declaration + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Case_Statement + | Iir_Kind_If_Statement + | Iir_Kind_Elsif => + return True; + when others => + return False; + end case; + end Has_End_Has_Identifier; + + function Has_End_Has_Postponed (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + return True; + when others => + return False; + end case; + end Has_End_Has_Postponed; + + function Has_Has_Begin (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Generate_Statement => + return True; + when others => + return False; + end case; + end Has_Has_Begin; + + function Has_Has_Is (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Component_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + return True; + when others => + return False; + end case; + end Has_Has_Is; + + function Has_Has_Pure (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Function_Declaration; + end Has_Has_Pure; + + function Has_Has_Body (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when others => + return False; + end case; + end Has_Has_Body; + + function Has_Has_Identifier_List (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Library_Clause + | Iir_Kind_Element_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration => + return True; + when others => + return False; + end case; + end Has_Has_Identifier_List; + + function Has_Has_Mode (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_File_Declaration; + end Has_Has_Mode; + + function Has_Is_Ref (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Element_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration => + return True; + when others => + return False; + end case; + end Has_Is_Ref; + + function Has_Psl_Property (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + return True; + when others => + return False; + end case; + end Has_Psl_Property; + + function Has_Psl_Declaration (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Psl_Declaration; + end Has_Psl_Declaration; + + function Has_Psl_Expression (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Psl_Expression; + end Has_Psl_Expression; + + function Has_Psl_Boolean (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Psl_Default_Clock; + end Has_Psl_Boolean; + + function Has_PSL_Clock (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Psl_Declaration + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + return True; + when others => + return False; + end case; + end Has_PSL_Clock; + + function Has_PSL_NFA (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Psl_Declaration + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + return True; + when others => + return False; + end case; + end Has_PSL_NFA; + +end Nodes_Meta; diff --git a/src/vhdl/nodes_meta.adb.in b/src/vhdl/nodes_meta.adb.in new file mode 100644 index 000000000..d94c2d626 --- /dev/null +++ b/src/vhdl/nodes_meta.adb.in @@ -0,0 +1,76 @@ +-- Meta description of nodes. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package body Nodes_Meta is + Fields_Type : constant array (Fields_Enum) of Types_Enum := + ( + -- FIELDS_TYPE + ); + + function Get_Field_Type (F : Fields_Enum) return Types_Enum is + begin + return Fields_Type (F); + end Get_Field_Type; + + function Get_Field_Image (F : Fields_Enum) return String is + begin + case F is + -- FIELD_IMAGE + end case; + end Get_Field_Image; + + function Get_Iir_Image (K : Iir_Kind) return String is + begin + case K is + -- IIR_IMAGE + end case; + end Get_Iir_Image; + + function Get_Field_Attribute (F : Fields_Enum) return Field_Attribute is + begin + case F is + -- FIELD_ATTRIBUTE + end case; + end Get_Field_Attribute; + + Fields_Of_Iir : constant Fields_Array := + ( + -- FIELDS_ARRAY + ); + + Fields_Of_Iir_Last : constant array (Iir_Kind) of Integer := + ( + -- FIELDS_ARRAY_POS + ); + + function Get_Fields (K : Iir_Kind) return Fields_Array + is + First : Natural; + Last : Integer; + begin + if K = Iir_Kind'First then + First := Fields_Of_Iir'First; + else + First := Fields_Of_Iir_Last (Iir_Kind'Pred (K)) + 1; + end if; + Last := Fields_Of_Iir_Last (K); + return Fields_Of_Iir (First .. Last); + end Get_Fields; + + -- FUNCS_BODY +end Nodes_Meta; diff --git a/src/vhdl/nodes_meta.ads b/src/vhdl/nodes_meta.ads new file mode 100644 index 000000000..2d1f5e1c0 --- /dev/null +++ b/src/vhdl/nodes_meta.ads @@ -0,0 +1,823 @@ +-- Meta description of nodes. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with Iirs; use Iirs; +with Tokens; use Tokens; + +package Nodes_Meta is + -- The enumeration of all possible types in the nodes. + type Types_Enum is + ( + Type_Base_Type, + Type_Boolean, + Type_Date_State_Type, + Type_Date_Type, + Type_Iir, + Type_Iir_All_Sensitized, + Type_Iir_Constraint, + Type_Iir_Delay_Mechanism, + Type_Iir_Direction, + Type_Iir_Fp64, + Type_Iir_Index32, + Type_Iir_Int32, + Type_Iir_Int64, + Type_Iir_Lexical_Layout_Type, + Type_Iir_List, + Type_Iir_Mode, + Type_Iir_Predefined_Functions, + Type_Iir_Pure_State, + Type_Iir_Signal_Kind, + Type_Iir_Staticness, + Type_Int32, + Type_Location_Type, + Type_Name_Id, + Type_PSL_NFA, + Type_PSL_Node, + Type_Source_Ptr, + Type_String_Id, + Type_Time_Stamp_Id, + Type_Token_Type, + Type_Tri_State_Type + ); + + -- The enumeration of all fields defined in iirs. + type Fields_Enum is + ( + Field_First_Design_Unit, + Field_Last_Design_Unit, + Field_Library_Declaration, + Field_File_Time_Stamp, + Field_Analysis_Time_Stamp, + Field_Library, + Field_File_Dependence_List, + Field_Design_File_Filename, + Field_Design_File_Directory, + Field_Design_File, + Field_Design_File_Chain, + Field_Library_Directory, + Field_Date, + Field_Context_Items, + Field_Dependence_List, + Field_Analysis_Checks_List, + Field_Date_State, + Field_Guarded_Target_State, + Field_Library_Unit, + Field_Hash_Chain, + Field_Design_Unit_Source_Pos, + Field_Design_Unit_Source_Line, + Field_Design_Unit_Source_Col, + Field_Value, + Field_Enum_Pos, + Field_Physical_Literal, + Field_Physical_Unit_Value, + Field_Fp_Value, + Field_Enumeration_Decl, + Field_Simple_Aggregate_List, + Field_Bit_String_Base, + Field_Bit_String_0, + Field_Bit_String_1, + Field_Literal_Origin, + Field_Range_Origin, + Field_Literal_Subtype, + Field_Entity_Class, + Field_Entity_Name_List, + Field_Attribute_Designator, + Field_Attribute_Specification_Chain, + Field_Attribute_Specification, + Field_Signal_List, + Field_Designated_Entity, + Field_Formal, + Field_Actual, + Field_In_Conversion, + Field_Out_Conversion, + Field_Whole_Association_Flag, + Field_Collapse_Signal_Flag, + Field_Artificial_Flag, + Field_Open_Flag, + Field_After_Drivers_Flag, + Field_We_Value, + Field_Time, + Field_Associated_Expr, + Field_Associated_Chain, + Field_Choice_Name, + Field_Choice_Expression, + Field_Choice_Range, + Field_Same_Alternative_Flag, + Field_Architecture, + Field_Block_Specification, + Field_Prev_Block_Configuration, + Field_Configuration_Item_Chain, + Field_Attribute_Value_Chain, + Field_Spec_Chain, + Field_Attribute_Value_Spec_Chain, + Field_Entity_Name, + Field_Package, + Field_Package_Body, + Field_Need_Body, + Field_Block_Configuration, + Field_Concurrent_Statement_Chain, + Field_Chain, + Field_Port_Chain, + Field_Generic_Chain, + Field_Type, + Field_Subtype_Indication, + Field_Discrete_Range, + Field_Type_Definition, + Field_Subtype_Definition, + Field_Nature, + Field_Mode, + Field_Signal_Kind, + Field_Base_Name, + Field_Interface_Declaration_Chain, + Field_Subprogram_Specification, + Field_Sequential_Statement_Chain, + Field_Subprogram_Body, + Field_Overload_Number, + Field_Subprogram_Depth, + Field_Subprogram_Hash, + Field_Impure_Depth, + Field_Return_Type, + Field_Implicit_Definition, + Field_Type_Reference, + Field_Default_Value, + Field_Deferred_Declaration, + Field_Deferred_Declaration_Flag, + Field_Shared_Flag, + Field_Design_Unit, + Field_Block_Statement, + Field_Signal_Driver, + Field_Declaration_Chain, + Field_File_Logical_Name, + Field_File_Open_Kind, + Field_Element_Position, + Field_Element_Declaration, + Field_Selected_Element, + Field_Use_Clause_Chain, + Field_Selected_Name, + Field_Type_Declarator, + Field_Enumeration_Literal_List, + Field_Entity_Class_Entry_Chain, + Field_Group_Constituent_List, + Field_Unit_Chain, + Field_Primary_Unit, + Field_Identifier, + Field_Label, + Field_Visible_Flag, + Field_Range_Constraint, + Field_Direction, + Field_Left_Limit, + Field_Right_Limit, + Field_Base_Type, + Field_Resolution_Indication, + Field_Record_Element_Resolution_Chain, + Field_Tolerance, + Field_Plus_Terminal, + Field_Minus_Terminal, + Field_Simultaneous_Left, + Field_Simultaneous_Right, + Field_Text_File_Flag, + Field_Only_Characters_Flag, + Field_Type_Staticness, + Field_Constraint_State, + Field_Index_Subtype_List, + Field_Index_Subtype_Definition_List, + Field_Element_Subtype_Indication, + Field_Element_Subtype, + Field_Index_Constraint_List, + Field_Array_Element_Constraint, + Field_Elements_Declaration_List, + Field_Designated_Type, + Field_Designated_Subtype_Indication, + Field_Index_List, + Field_Reference, + Field_Nature_Declarator, + Field_Across_Type, + Field_Through_Type, + Field_Target, + Field_Waveform_Chain, + Field_Guard, + Field_Delay_Mechanism, + Field_Reject_Time_Expression, + Field_Sensitivity_List, + Field_Process_Origin, + Field_Condition_Clause, + Field_Timeout_Clause, + Field_Postponed_Flag, + Field_Callees_List, + Field_Passive_Flag, + Field_Resolution_Function_Flag, + Field_Wait_State, + Field_All_Sensitized_State, + Field_Seen_Flag, + Field_Pure_Flag, + Field_Foreign_Flag, + Field_Resolved_Flag, + Field_Signal_Type_Flag, + Field_Has_Signal_Flag, + Field_Purity_State, + Field_Elab_Flag, + Field_Index_Constraint_Flag, + Field_Assertion_Condition, + Field_Report_Expression, + Field_Severity_Expression, + Field_Instantiated_Unit, + Field_Generic_Map_Aspect_Chain, + Field_Port_Map_Aspect_Chain, + Field_Configuration_Name, + Field_Component_Configuration, + Field_Configuration_Specification, + Field_Default_Binding_Indication, + Field_Default_Configuration_Declaration, + Field_Expression, + Field_Allocator_Designated_Type, + Field_Selected_Waveform_Chain, + Field_Conditional_Waveform_Chain, + Field_Guard_Expression, + Field_Guard_Decl, + Field_Guard_Sensitivity_List, + Field_Block_Block_Configuration, + Field_Package_Header, + Field_Block_Header, + Field_Uninstantiated_Package_Name, + Field_Generate_Block_Configuration, + Field_Generation_Scheme, + Field_Condition, + Field_Else_Clause, + Field_Parameter_Specification, + Field_Parent, + Field_Loop_Label, + Field_Component_Name, + Field_Instantiation_List, + Field_Entity_Aspect, + Field_Default_Entity_Aspect, + Field_Default_Generic_Map_Aspect_Chain, + Field_Default_Port_Map_Aspect_Chain, + Field_Binding_Indication, + Field_Named_Entity, + Field_Alias_Declaration, + Field_Expr_Staticness, + Field_Error_Origin, + Field_Operand, + Field_Left, + Field_Right, + Field_Unit_Name, + Field_Name, + Field_Group_Template_Name, + Field_Name_Staticness, + Field_Prefix, + Field_Signature_Prefix, + Field_Slice_Subtype, + Field_Suffix, + Field_Index_Subtype, + Field_Parameter, + Field_Actual_Type, + Field_Associated_Interface, + Field_Association_Chain, + Field_Individual_Association_Chain, + Field_Aggregate_Info, + Field_Sub_Aggregate_Info, + Field_Aggr_Dynamic_Flag, + Field_Aggr_Min_Length, + Field_Aggr_Low_Limit, + Field_Aggr_High_Limit, + Field_Aggr_Others_Flag, + Field_Aggr_Named_Flag, + Field_Value_Staticness, + Field_Association_Choices_Chain, + Field_Case_Statement_Alternative_Chain, + Field_Choice_Staticness, + Field_Procedure_Call, + Field_Implementation, + Field_Parameter_Association_Chain, + Field_Method_Object, + Field_Subtype_Type_Mark, + Field_Type_Conversion_Subtype, + Field_Type_Mark, + Field_File_Type_Mark, + Field_Return_Type_Mark, + Field_Lexical_Layout, + Field_Incomplete_Type_List, + Field_Has_Disconnect_Flag, + Field_Has_Active_Flag, + Field_Is_Within_Flag, + Field_Type_Marks_List, + Field_Implicit_Alias_Flag, + Field_Alias_Signature, + Field_Attribute_Signature, + Field_Overload_List, + Field_Simple_Name_Identifier, + Field_Simple_Name_Subtype, + Field_Protected_Type_Body, + Field_Protected_Type_Declaration, + Field_End_Location, + Field_String_Id, + Field_String_Length, + Field_Use_Flag, + Field_End_Has_Reserved_Id, + Field_End_Has_Identifier, + Field_End_Has_Postponed, + Field_Has_Begin, + Field_Has_Is, + Field_Has_Pure, + Field_Has_Body, + Field_Has_Identifier_List, + Field_Has_Mode, + Field_Is_Ref, + Field_Psl_Property, + Field_Psl_Declaration, + Field_Psl_Expression, + Field_Psl_Boolean, + Field_PSL_Clock, + Field_PSL_NFA + ); + pragma Discard_Names (Fields_Enum); + + -- Return the type of field F. + function Get_Field_Type (F : Fields_Enum) return Types_Enum; + + -- Get the name of a field. + function Get_Field_Image (F : Fields_Enum) return String; + + -- Get the name of a kind. + function Get_Iir_Image (K : Iir_Kind) return String; + + -- Possible attributes of a field. + type Field_Attribute is + ( + Attr_None, + Attr_Ref, Attr_Maybe_Ref, Attr_Of_Ref, + Attr_Chain, Attr_Chain_Next + ); + + -- Get the attribute of a field. + function Get_Field_Attribute (F : Fields_Enum) return Field_Attribute; + + type Fields_Array is array (Natural range <>) of Fields_Enum; + + -- Return the list of fields for node K. The fields are sorted: first + -- the non nodes/list of nodes, then the nodes/lists that aren't reference, + -- and then the reference. + function Get_Fields (K : Iir_Kind) return Fields_Array; + + -- Get/Set a field. + function Get_Base_Type + (N : Iir; F : Fields_Enum) return Base_Type; + procedure Set_Base_Type + (N : Iir; F : Fields_Enum; V: Base_Type); + + function Get_Boolean + (N : Iir; F : Fields_Enum) return Boolean; + procedure Set_Boolean + (N : Iir; F : Fields_Enum; V: Boolean); + + function Get_Date_State_Type + (N : Iir; F : Fields_Enum) return Date_State_Type; + procedure Set_Date_State_Type + (N : Iir; F : Fields_Enum; V: Date_State_Type); + + function Get_Date_Type + (N : Iir; F : Fields_Enum) return Date_Type; + procedure Set_Date_Type + (N : Iir; F : Fields_Enum; V: Date_Type); + + function Get_Iir + (N : Iir; F : Fields_Enum) return Iir; + procedure Set_Iir + (N : Iir; F : Fields_Enum; V: Iir); + + function Get_Iir_All_Sensitized + (N : Iir; F : Fields_Enum) return Iir_All_Sensitized; + procedure Set_Iir_All_Sensitized + (N : Iir; F : Fields_Enum; V: Iir_All_Sensitized); + + function Get_Iir_Constraint + (N : Iir; F : Fields_Enum) return Iir_Constraint; + procedure Set_Iir_Constraint + (N : Iir; F : Fields_Enum; V: Iir_Constraint); + + function Get_Iir_Delay_Mechanism + (N : Iir; F : Fields_Enum) return Iir_Delay_Mechanism; + procedure Set_Iir_Delay_Mechanism + (N : Iir; F : Fields_Enum; V: Iir_Delay_Mechanism); + + function Get_Iir_Direction + (N : Iir; F : Fields_Enum) return Iir_Direction; + procedure Set_Iir_Direction + (N : Iir; F : Fields_Enum; V: Iir_Direction); + + function Get_Iir_Fp64 + (N : Iir; F : Fields_Enum) return Iir_Fp64; + procedure Set_Iir_Fp64 + (N : Iir; F : Fields_Enum; V: Iir_Fp64); + + function Get_Iir_Index32 + (N : Iir; F : Fields_Enum) return Iir_Index32; + procedure Set_Iir_Index32 + (N : Iir; F : Fields_Enum; V: Iir_Index32); + + function Get_Iir_Int32 + (N : Iir; F : Fields_Enum) return Iir_Int32; + procedure Set_Iir_Int32 + (N : Iir; F : Fields_Enum; V: Iir_Int32); + + function Get_Iir_Int64 + (N : Iir; F : Fields_Enum) return Iir_Int64; + procedure Set_Iir_Int64 + (N : Iir; F : Fields_Enum; V: Iir_Int64); + + function Get_Iir_Lexical_Layout_Type + (N : Iir; F : Fields_Enum) return Iir_Lexical_Layout_Type; + procedure Set_Iir_Lexical_Layout_Type + (N : Iir; F : Fields_Enum; V: Iir_Lexical_Layout_Type); + + function Get_Iir_List + (N : Iir; F : Fields_Enum) return Iir_List; + procedure Set_Iir_List + (N : Iir; F : Fields_Enum; V: Iir_List); + + function Get_Iir_Mode + (N : Iir; F : Fields_Enum) return Iir_Mode; + procedure Set_Iir_Mode + (N : Iir; F : Fields_Enum; V: Iir_Mode); + + function Get_Iir_Predefined_Functions + (N : Iir; F : Fields_Enum) return Iir_Predefined_Functions; + procedure Set_Iir_Predefined_Functions + (N : Iir; F : Fields_Enum; V: Iir_Predefined_Functions); + + function Get_Iir_Pure_State + (N : Iir; F : Fields_Enum) return Iir_Pure_State; + procedure Set_Iir_Pure_State + (N : Iir; F : Fields_Enum; V: Iir_Pure_State); + + function Get_Iir_Signal_Kind + (N : Iir; F : Fields_Enum) return Iir_Signal_Kind; + procedure Set_Iir_Signal_Kind + (N : Iir; F : Fields_Enum; V: Iir_Signal_Kind); + + function Get_Iir_Staticness + (N : Iir; F : Fields_Enum) return Iir_Staticness; + procedure Set_Iir_Staticness + (N : Iir; F : Fields_Enum; V: Iir_Staticness); + + function Get_Int32 + (N : Iir; F : Fields_Enum) return Int32; + procedure Set_Int32 + (N : Iir; F : Fields_Enum; V: Int32); + + function Get_Location_Type + (N : Iir; F : Fields_Enum) return Location_Type; + procedure Set_Location_Type + (N : Iir; F : Fields_Enum; V: Location_Type); + + function Get_Name_Id + (N : Iir; F : Fields_Enum) return Name_Id; + procedure Set_Name_Id + (N : Iir; F : Fields_Enum; V: Name_Id); + + function Get_PSL_NFA + (N : Iir; F : Fields_Enum) return PSL_NFA; + procedure Set_PSL_NFA + (N : Iir; F : Fields_Enum; V: PSL_NFA); + + function Get_PSL_Node + (N : Iir; F : Fields_Enum) return PSL_Node; + procedure Set_PSL_Node + (N : Iir; F : Fields_Enum; V: PSL_Node); + + function Get_Source_Ptr + (N : Iir; F : Fields_Enum) return Source_Ptr; + procedure Set_Source_Ptr + (N : Iir; F : Fields_Enum; V: Source_Ptr); + + function Get_String_Id + (N : Iir; F : Fields_Enum) return String_Id; + procedure Set_String_Id + (N : Iir; F : Fields_Enum; V: String_Id); + + function Get_Time_Stamp_Id + (N : Iir; F : Fields_Enum) return Time_Stamp_Id; + procedure Set_Time_Stamp_Id + (N : Iir; F : Fields_Enum; V: Time_Stamp_Id); + + function Get_Token_Type + (N : Iir; F : Fields_Enum) return Token_Type; + procedure Set_Token_Type + (N : Iir; F : Fields_Enum; V: Token_Type); + + function Get_Tri_State_Type + (N : Iir; F : Fields_Enum) return Tri_State_Type; + procedure Set_Tri_State_Type + (N : Iir; F : Fields_Enum; V: Tri_State_Type); + + function Has_First_Design_Unit (K : Iir_Kind) return Boolean; + function Has_Last_Design_Unit (K : Iir_Kind) return Boolean; + function Has_Library_Declaration (K : Iir_Kind) return Boolean; + function Has_File_Time_Stamp (K : Iir_Kind) return Boolean; + function Has_Analysis_Time_Stamp (K : Iir_Kind) return Boolean; + function Has_Library (K : Iir_Kind) return Boolean; + function Has_File_Dependence_List (K : Iir_Kind) return Boolean; + function Has_Design_File_Filename (K : Iir_Kind) return Boolean; + function Has_Design_File_Directory (K : Iir_Kind) return Boolean; + function Has_Design_File (K : Iir_Kind) return Boolean; + function Has_Design_File_Chain (K : Iir_Kind) return Boolean; + function Has_Library_Directory (K : Iir_Kind) return Boolean; + function Has_Date (K : Iir_Kind) return Boolean; + function Has_Context_Items (K : Iir_Kind) return Boolean; + function Has_Dependence_List (K : Iir_Kind) return Boolean; + function Has_Analysis_Checks_List (K : Iir_Kind) return Boolean; + function Has_Date_State (K : Iir_Kind) return Boolean; + function Has_Guarded_Target_State (K : Iir_Kind) return Boolean; + function Has_Library_Unit (K : Iir_Kind) return Boolean; + function Has_Hash_Chain (K : Iir_Kind) return Boolean; + function Has_Design_Unit_Source_Pos (K : Iir_Kind) return Boolean; + function Has_Design_Unit_Source_Line (K : Iir_Kind) return Boolean; + function Has_Design_Unit_Source_Col (K : Iir_Kind) return Boolean; + function Has_Value (K : Iir_Kind) return Boolean; + function Has_Enum_Pos (K : Iir_Kind) return Boolean; + function Has_Physical_Literal (K : Iir_Kind) return Boolean; + function Has_Physical_Unit_Value (K : Iir_Kind) return Boolean; + function Has_Fp_Value (K : Iir_Kind) return Boolean; + function Has_Enumeration_Decl (K : Iir_Kind) return Boolean; + function Has_Simple_Aggregate_List (K : Iir_Kind) return Boolean; + function Has_Bit_String_Base (K : Iir_Kind) return Boolean; + function Has_Bit_String_0 (K : Iir_Kind) return Boolean; + function Has_Bit_String_1 (K : Iir_Kind) return Boolean; + function Has_Literal_Origin (K : Iir_Kind) return Boolean; + function Has_Range_Origin (K : Iir_Kind) return Boolean; + function Has_Literal_Subtype (K : Iir_Kind) return Boolean; + function Has_Entity_Class (K : Iir_Kind) return Boolean; + function Has_Entity_Name_List (K : Iir_Kind) return Boolean; + function Has_Attribute_Designator (K : Iir_Kind) return Boolean; + function Has_Attribute_Specification_Chain (K : Iir_Kind) + return Boolean; + function Has_Attribute_Specification (K : Iir_Kind) return Boolean; + function Has_Signal_List (K : Iir_Kind) return Boolean; + function Has_Designated_Entity (K : Iir_Kind) return Boolean; + function Has_Formal (K : Iir_Kind) return Boolean; + function Has_Actual (K : Iir_Kind) return Boolean; + function Has_In_Conversion (K : Iir_Kind) return Boolean; + function Has_Out_Conversion (K : Iir_Kind) return Boolean; + function Has_Whole_Association_Flag (K : Iir_Kind) return Boolean; + function Has_Collapse_Signal_Flag (K : Iir_Kind) return Boolean; + function Has_Artificial_Flag (K : Iir_Kind) return Boolean; + function Has_Open_Flag (K : Iir_Kind) return Boolean; + function Has_After_Drivers_Flag (K : Iir_Kind) return Boolean; + function Has_We_Value (K : Iir_Kind) return Boolean; + function Has_Time (K : Iir_Kind) return Boolean; + function Has_Associated_Expr (K : Iir_Kind) return Boolean; + function Has_Associated_Chain (K : Iir_Kind) return Boolean; + function Has_Choice_Name (K : Iir_Kind) return Boolean; + function Has_Choice_Expression (K : Iir_Kind) return Boolean; + function Has_Choice_Range (K : Iir_Kind) return Boolean; + function Has_Same_Alternative_Flag (K : Iir_Kind) return Boolean; + function Has_Architecture (K : Iir_Kind) return Boolean; + function Has_Block_Specification (K : Iir_Kind) return Boolean; + function Has_Prev_Block_Configuration (K : Iir_Kind) return Boolean; + function Has_Configuration_Item_Chain (K : Iir_Kind) return Boolean; + function Has_Attribute_Value_Chain (K : Iir_Kind) return Boolean; + function Has_Spec_Chain (K : Iir_Kind) return Boolean; + function Has_Attribute_Value_Spec_Chain (K : Iir_Kind) return Boolean; + function Has_Entity_Name (K : Iir_Kind) return Boolean; + function Has_Package (K : Iir_Kind) return Boolean; + function Has_Package_Body (K : Iir_Kind) return Boolean; + function Has_Need_Body (K : Iir_Kind) return Boolean; + function Has_Block_Configuration (K : Iir_Kind) return Boolean; + function Has_Concurrent_Statement_Chain (K : Iir_Kind) return Boolean; + function Has_Chain (K : Iir_Kind) return Boolean; + function Has_Port_Chain (K : Iir_Kind) return Boolean; + function Has_Generic_Chain (K : Iir_Kind) return Boolean; + function Has_Type (K : Iir_Kind) return Boolean; + function Has_Subtype_Indication (K : Iir_Kind) return Boolean; + function Has_Discrete_Range (K : Iir_Kind) return Boolean; + function Has_Type_Definition (K : Iir_Kind) return Boolean; + function Has_Subtype_Definition (K : Iir_Kind) return Boolean; + function Has_Nature (K : Iir_Kind) return Boolean; + function Has_Mode (K : Iir_Kind) return Boolean; + function Has_Signal_Kind (K : Iir_Kind) return Boolean; + function Has_Base_Name (K : Iir_Kind) return Boolean; + function Has_Interface_Declaration_Chain (K : Iir_Kind) return Boolean; + function Has_Subprogram_Specification (K : Iir_Kind) return Boolean; + function Has_Sequential_Statement_Chain (K : Iir_Kind) return Boolean; + function Has_Subprogram_Body (K : Iir_Kind) return Boolean; + function Has_Overload_Number (K : Iir_Kind) return Boolean; + function Has_Subprogram_Depth (K : Iir_Kind) return Boolean; + function Has_Subprogram_Hash (K : Iir_Kind) return Boolean; + function Has_Impure_Depth (K : Iir_Kind) return Boolean; + function Has_Return_Type (K : Iir_Kind) return Boolean; + function Has_Implicit_Definition (K : Iir_Kind) return Boolean; + function Has_Type_Reference (K : Iir_Kind) return Boolean; + function Has_Default_Value (K : Iir_Kind) return Boolean; + function Has_Deferred_Declaration (K : Iir_Kind) return Boolean; + function Has_Deferred_Declaration_Flag (K : Iir_Kind) return Boolean; + function Has_Shared_Flag (K : Iir_Kind) return Boolean; + function Has_Design_Unit (K : Iir_Kind) return Boolean; + function Has_Block_Statement (K : Iir_Kind) return Boolean; + function Has_Signal_Driver (K : Iir_Kind) return Boolean; + function Has_Declaration_Chain (K : Iir_Kind) return Boolean; + function Has_File_Logical_Name (K : Iir_Kind) return Boolean; + function Has_File_Open_Kind (K : Iir_Kind) return Boolean; + function Has_Element_Position (K : Iir_Kind) return Boolean; + function Has_Element_Declaration (K : Iir_Kind) return Boolean; + function Has_Selected_Element (K : Iir_Kind) return Boolean; + function Has_Use_Clause_Chain (K : Iir_Kind) return Boolean; + function Has_Selected_Name (K : Iir_Kind) return Boolean; + function Has_Type_Declarator (K : Iir_Kind) return Boolean; + function Has_Enumeration_Literal_List (K : Iir_Kind) return Boolean; + function Has_Entity_Class_Entry_Chain (K : Iir_Kind) return Boolean; + function Has_Group_Constituent_List (K : Iir_Kind) return Boolean; + function Has_Unit_Chain (K : Iir_Kind) return Boolean; + function Has_Primary_Unit (K : Iir_Kind) return Boolean; + function Has_Identifier (K : Iir_Kind) return Boolean; + function Has_Label (K : Iir_Kind) return Boolean; + function Has_Visible_Flag (K : Iir_Kind) return Boolean; + function Has_Range_Constraint (K : Iir_Kind) return Boolean; + function Has_Direction (K : Iir_Kind) return Boolean; + function Has_Left_Limit (K : Iir_Kind) return Boolean; + function Has_Right_Limit (K : Iir_Kind) return Boolean; + function Has_Base_Type (K : Iir_Kind) return Boolean; + function Has_Resolution_Indication (K : Iir_Kind) return Boolean; + function Has_Record_Element_Resolution_Chain (K : Iir_Kind) + return Boolean; + function Has_Tolerance (K : Iir_Kind) return Boolean; + function Has_Plus_Terminal (K : Iir_Kind) return Boolean; + function Has_Minus_Terminal (K : Iir_Kind) return Boolean; + function Has_Simultaneous_Left (K : Iir_Kind) return Boolean; + function Has_Simultaneous_Right (K : Iir_Kind) return Boolean; + function Has_Text_File_Flag (K : Iir_Kind) return Boolean; + function Has_Only_Characters_Flag (K : Iir_Kind) return Boolean; + function Has_Type_Staticness (K : Iir_Kind) return Boolean; + function Has_Constraint_State (K : Iir_Kind) return Boolean; + function Has_Index_Subtype_List (K : Iir_Kind) return Boolean; + function Has_Index_Subtype_Definition_List (K : Iir_Kind) + return Boolean; + function Has_Element_Subtype_Indication (K : Iir_Kind) return Boolean; + function Has_Element_Subtype (K : Iir_Kind) return Boolean; + function Has_Index_Constraint_List (K : Iir_Kind) return Boolean; + function Has_Array_Element_Constraint (K : Iir_Kind) return Boolean; + function Has_Elements_Declaration_List (K : Iir_Kind) return Boolean; + function Has_Designated_Type (K : Iir_Kind) return Boolean; + function Has_Designated_Subtype_Indication (K : Iir_Kind) + return Boolean; + function Has_Index_List (K : Iir_Kind) return Boolean; + function Has_Reference (K : Iir_Kind) return Boolean; + function Has_Nature_Declarator (K : Iir_Kind) return Boolean; + function Has_Across_Type (K : Iir_Kind) return Boolean; + function Has_Through_Type (K : Iir_Kind) return Boolean; + function Has_Target (K : Iir_Kind) return Boolean; + function Has_Waveform_Chain (K : Iir_Kind) return Boolean; + function Has_Guard (K : Iir_Kind) return Boolean; + function Has_Delay_Mechanism (K : Iir_Kind) return Boolean; + function Has_Reject_Time_Expression (K : Iir_Kind) return Boolean; + function Has_Sensitivity_List (K : Iir_Kind) return Boolean; + function Has_Process_Origin (K : Iir_Kind) return Boolean; + function Has_Condition_Clause (K : Iir_Kind) return Boolean; + function Has_Timeout_Clause (K : Iir_Kind) return Boolean; + function Has_Postponed_Flag (K : Iir_Kind) return Boolean; + function Has_Callees_List (K : Iir_Kind) return Boolean; + function Has_Passive_Flag (K : Iir_Kind) return Boolean; + function Has_Resolution_Function_Flag (K : Iir_Kind) return Boolean; + function Has_Wait_State (K : Iir_Kind) return Boolean; + function Has_All_Sensitized_State (K : Iir_Kind) return Boolean; + function Has_Seen_Flag (K : Iir_Kind) return Boolean; + function Has_Pure_Flag (K : Iir_Kind) return Boolean; + function Has_Foreign_Flag (K : Iir_Kind) return Boolean; + function Has_Resolved_Flag (K : Iir_Kind) return Boolean; + function Has_Signal_Type_Flag (K : Iir_Kind) return Boolean; + function Has_Has_Signal_Flag (K : Iir_Kind) return Boolean; + function Has_Purity_State (K : Iir_Kind) return Boolean; + function Has_Elab_Flag (K : Iir_Kind) return Boolean; + function Has_Index_Constraint_Flag (K : Iir_Kind) return Boolean; + function Has_Assertion_Condition (K : Iir_Kind) return Boolean; + function Has_Report_Expression (K : Iir_Kind) return Boolean; + function Has_Severity_Expression (K : Iir_Kind) return Boolean; + function Has_Instantiated_Unit (K : Iir_Kind) return Boolean; + function Has_Generic_Map_Aspect_Chain (K : Iir_Kind) return Boolean; + function Has_Port_Map_Aspect_Chain (K : Iir_Kind) return Boolean; + function Has_Configuration_Name (K : Iir_Kind) return Boolean; + function Has_Component_Configuration (K : Iir_Kind) return Boolean; + function Has_Configuration_Specification (K : Iir_Kind) return Boolean; + function Has_Default_Binding_Indication (K : Iir_Kind) return Boolean; + function Has_Default_Configuration_Declaration (K : Iir_Kind) + return Boolean; + function Has_Expression (K : Iir_Kind) return Boolean; + function Has_Allocator_Designated_Type (K : Iir_Kind) return Boolean; + function Has_Selected_Waveform_Chain (K : Iir_Kind) return Boolean; + function Has_Conditional_Waveform_Chain (K : Iir_Kind) return Boolean; + function Has_Guard_Expression (K : Iir_Kind) return Boolean; + function Has_Guard_Decl (K : Iir_Kind) return Boolean; + function Has_Guard_Sensitivity_List (K : Iir_Kind) return Boolean; + function Has_Block_Block_Configuration (K : Iir_Kind) return Boolean; + function Has_Package_Header (K : Iir_Kind) return Boolean; + function Has_Block_Header (K : Iir_Kind) return Boolean; + function Has_Uninstantiated_Package_Name (K : Iir_Kind) return Boolean; + function Has_Generate_Block_Configuration (K : Iir_Kind) return Boolean; + function Has_Generation_Scheme (K : Iir_Kind) return Boolean; + function Has_Condition (K : Iir_Kind) return Boolean; + function Has_Else_Clause (K : Iir_Kind) return Boolean; + function Has_Parameter_Specification (K : Iir_Kind) return Boolean; + function Has_Parent (K : Iir_Kind) return Boolean; + function Has_Loop_Label (K : Iir_Kind) return Boolean; + function Has_Component_Name (K : Iir_Kind) return Boolean; + function Has_Instantiation_List (K : Iir_Kind) return Boolean; + function Has_Entity_Aspect (K : Iir_Kind) return Boolean; + function Has_Default_Entity_Aspect (K : Iir_Kind) return Boolean; + function Has_Default_Generic_Map_Aspect_Chain (K : Iir_Kind) + return Boolean; + function Has_Default_Port_Map_Aspect_Chain (K : Iir_Kind) + return Boolean; + function Has_Binding_Indication (K : Iir_Kind) return Boolean; + function Has_Named_Entity (K : Iir_Kind) return Boolean; + function Has_Alias_Declaration (K : Iir_Kind) return Boolean; + function Has_Expr_Staticness (K : Iir_Kind) return Boolean; + function Has_Error_Origin (K : Iir_Kind) return Boolean; + function Has_Operand (K : Iir_Kind) return Boolean; + function Has_Left (K : Iir_Kind) return Boolean; + function Has_Right (K : Iir_Kind) return Boolean; + function Has_Unit_Name (K : Iir_Kind) return Boolean; + function Has_Name (K : Iir_Kind) return Boolean; + function Has_Group_Template_Name (K : Iir_Kind) return Boolean; + function Has_Name_Staticness (K : Iir_Kind) return Boolean; + function Has_Prefix (K : Iir_Kind) return Boolean; + function Has_Signature_Prefix (K : Iir_Kind) return Boolean; + function Has_Slice_Subtype (K : Iir_Kind) return Boolean; + function Has_Suffix (K : Iir_Kind) return Boolean; + function Has_Index_Subtype (K : Iir_Kind) return Boolean; + function Has_Parameter (K : Iir_Kind) return Boolean; + function Has_Actual_Type (K : Iir_Kind) return Boolean; + function Has_Associated_Interface (K : Iir_Kind) return Boolean; + function Has_Association_Chain (K : Iir_Kind) return Boolean; + function Has_Individual_Association_Chain (K : Iir_Kind) return Boolean; + function Has_Aggregate_Info (K : Iir_Kind) return Boolean; + function Has_Sub_Aggregate_Info (K : Iir_Kind) return Boolean; + function Has_Aggr_Dynamic_Flag (K : Iir_Kind) return Boolean; + function Has_Aggr_Min_Length (K : Iir_Kind) return Boolean; + function Has_Aggr_Low_Limit (K : Iir_Kind) return Boolean; + function Has_Aggr_High_Limit (K : Iir_Kind) return Boolean; + function Has_Aggr_Others_Flag (K : Iir_Kind) return Boolean; + function Has_Aggr_Named_Flag (K : Iir_Kind) return Boolean; + function Has_Value_Staticness (K : Iir_Kind) return Boolean; + function Has_Association_Choices_Chain (K : Iir_Kind) return Boolean; + function Has_Case_Statement_Alternative_Chain (K : Iir_Kind) + return Boolean; + function Has_Choice_Staticness (K : Iir_Kind) return Boolean; + function Has_Procedure_Call (K : Iir_Kind) return Boolean; + function Has_Implementation (K : Iir_Kind) return Boolean; + function Has_Parameter_Association_Chain (K : Iir_Kind) return Boolean; + function Has_Method_Object (K : Iir_Kind) return Boolean; + function Has_Subtype_Type_Mark (K : Iir_Kind) return Boolean; + function Has_Type_Conversion_Subtype (K : Iir_Kind) return Boolean; + function Has_Type_Mark (K : Iir_Kind) return Boolean; + function Has_File_Type_Mark (K : Iir_Kind) return Boolean; + function Has_Return_Type_Mark (K : Iir_Kind) return Boolean; + function Has_Lexical_Layout (K : Iir_Kind) return Boolean; + function Has_Incomplete_Type_List (K : Iir_Kind) return Boolean; + function Has_Has_Disconnect_Flag (K : Iir_Kind) return Boolean; + function Has_Has_Active_Flag (K : Iir_Kind) return Boolean; + function Has_Is_Within_Flag (K : Iir_Kind) return Boolean; + function Has_Type_Marks_List (K : Iir_Kind) return Boolean; + function Has_Implicit_Alias_Flag (K : Iir_Kind) return Boolean; + function Has_Alias_Signature (K : Iir_Kind) return Boolean; + function Has_Attribute_Signature (K : Iir_Kind) return Boolean; + function Has_Overload_List (K : Iir_Kind) return Boolean; + function Has_Simple_Name_Identifier (K : Iir_Kind) return Boolean; + function Has_Simple_Name_Subtype (K : Iir_Kind) return Boolean; + function Has_Protected_Type_Body (K : Iir_Kind) return Boolean; + function Has_Protected_Type_Declaration (K : Iir_Kind) return Boolean; + function Has_End_Location (K : Iir_Kind) return Boolean; + function Has_String_Id (K : Iir_Kind) return Boolean; + function Has_String_Length (K : Iir_Kind) return Boolean; + function Has_Use_Flag (K : Iir_Kind) return Boolean; + function Has_End_Has_Reserved_Id (K : Iir_Kind) return Boolean; + function Has_End_Has_Identifier (K : Iir_Kind) return Boolean; + function Has_End_Has_Postponed (K : Iir_Kind) return Boolean; + function Has_Has_Begin (K : Iir_Kind) return Boolean; + function Has_Has_Is (K : Iir_Kind) return Boolean; + function Has_Has_Pure (K : Iir_Kind) return Boolean; + function Has_Has_Body (K : Iir_Kind) return Boolean; + function Has_Has_Identifier_List (K : Iir_Kind) return Boolean; + function Has_Has_Mode (K : Iir_Kind) return Boolean; + function Has_Is_Ref (K : Iir_Kind) return Boolean; + function Has_Psl_Property (K : Iir_Kind) return Boolean; + function Has_Psl_Declaration (K : Iir_Kind) return Boolean; + function Has_Psl_Expression (K : Iir_Kind) return Boolean; + function Has_Psl_Boolean (K : Iir_Kind) return Boolean; + function Has_PSL_Clock (K : Iir_Kind) return Boolean; + function Has_PSL_NFA (K : Iir_Kind) return Boolean; +end Nodes_Meta; diff --git a/src/vhdl/nodes_meta.ads.in b/src/vhdl/nodes_meta.ads.in new file mode 100644 index 000000000..8e1dceca9 --- /dev/null +++ b/src/vhdl/nodes_meta.ads.in @@ -0,0 +1,66 @@ +-- Meta description of nodes. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with Iirs; use Iirs; +with Tokens; use Tokens; + +package Nodes_Meta is + -- The enumeration of all possible types in the nodes. + type Types_Enum is + ( + -- TYPES + ); + + -- The enumeration of all fields defined in iirs. + type Fields_Enum is + ( + -- FIELDS + ); + pragma Discard_Names (Fields_Enum); + + -- Return the type of field F. + function Get_Field_Type (F : Fields_Enum) return Types_Enum; + + -- Get the name of a field. + function Get_Field_Image (F : Fields_Enum) return String; + + -- Get the name of a kind. + function Get_Iir_Image (K : Iir_Kind) return String; + + -- Possible attributes of a field. + type Field_Attribute is + ( + Attr_None, + Attr_Ref, Attr_Maybe_Ref, Attr_Of_Ref, + Attr_Chain, Attr_Chain_Next + ); + + -- Get the attribute of a field. + function Get_Field_Attribute (F : Fields_Enum) return Field_Attribute; + + type Fields_Array is array (Natural range <>) of Fields_Enum; + + -- Return the list of fields for node K. The fields are sorted: first + -- the non nodes/list of nodes, then the nodes/lists that aren't reference, + -- and then the reference. + function Get_Fields (K : Iir_Kind) return Fields_Array; + + -- Get/Set a field. + -- FUNCS +end Nodes_Meta; diff --git a/src/vhdl/parse.adb b/src/vhdl/parse.adb new file mode 100644 index 000000000..97ff87691 --- /dev/null +++ b/src/vhdl/parse.adb @@ -0,0 +1,7143 @@ +-- VHDL parser. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iir_Chains; use Iir_Chains; +with Ada.Text_IO; use Ada.Text_IO; +with Types; use Types; +with Tokens; use Tokens; +with Scanner; use Scanner; +with Iirs_Utils; use Iirs_Utils; +with Errorout; use Errorout; +with Std_Names; use Std_Names; +with Flags; use Flags; +with Parse_Psl; +with Name_Table; +with Str_Table; +with Xrefs; + +-- Recursive descendant parser. +-- Each subprogram (should) parse one production rules. +-- Rules are written in a comment just before the subprogram. +-- terminals are written in upper case. +-- non-terminal are written in lower case. +-- syntaxic category of a non-terminal are written in upper case. +-- eg: next_statement ::= [ label : ] NEXT [ LOOP_label ] [ WHEN condition ] ; +-- Or (|) must be aligned by the previous or, or with the '=' character. +-- Indentation is 4. +-- +-- To document what is expected for input and what is left as an output +-- concerning token stream, a precond and a postcond comment shoud be +-- added before the above rules. +-- a token (such as IF or ';') means the current token is this token. +-- 'a token' means the current token was analysed. +-- 'next token' means the current token is to be analysed. + + +package body Parse is + + -- current_token must be valid. + -- Leaves a token. + function Parse_Simple_Expression (Primary : Iir := Null_Iir) + return Iir_Expression; + function Parse_Primary return Iir_Expression; + function Parse_Use_Clause return Iir_Use_Clause; + + function Parse_Association_List return Iir; + function Parse_Association_List_In_Parenthesis return Iir; + + function Parse_Sequential_Statements (Parent : Iir) return Iir; + function Parse_Configuration_Item return Iir; + function Parse_Block_Configuration return Iir_Block_Configuration; + procedure Parse_Concurrent_Statements (Parent : Iir); + function Parse_Subprogram_Declaration (Parent : Iir) return Iir; + function Parse_Subtype_Indication (Name : Iir := Null_Iir) return Iir; + procedure Parse_Component_Specification (Res : Iir); + function Parse_Binding_Indication return Iir_Binding_Indication; + function Parse_Aggregate return Iir; + function Parse_Signature return Iir_Signature; + procedure Parse_Declarative_Part (Parent : Iir); + function Parse_Tolerance_Aspect_Opt return Iir; + + Expect_Error: exception; + + -- Copy the current location into an iir. + procedure Set_Location (Node : Iir) is + begin + Set_Location (Node, Get_Token_Location); + end Set_Location; + + procedure Set_End_Location (Node : Iir) is + begin + Set_End_Location (Node, Get_Token_Location); + end Set_End_Location; + + procedure Unexpected (Where: String) is + begin + Error_Msg_Parse + ("unexpected token '" & Image (Current_Token) & "' in a " & Where); + end Unexpected; + +-- procedure Unexpected_Eof is +-- begin +-- Error_Msg_Parse ("unexpected end of file"); +-- end Unexpected_Eof; + + -- Emit an error if the current_token if different from TOKEN. + -- Otherwise, accept the current_token (ie set it to tok_invalid, unless + -- TOKEN is Tok_Identifier). + procedure Expect (Token: Token_Type; Msg: String := "") is + begin + if Current_Token /= Token then + if Msg'Length > 0 then + Error_Msg_Parse (Msg); + Error_Msg_Parse ("(found: " & Image (Current_Token) & ")"); + else + Error_Msg_Parse + (''' & Image(Token) & "' is expected instead of '" + & Image (Current_Token) & '''); + end if; + raise Expect_Error; + end if; + + -- Accept the current_token. + if Current_Token /= Tok_Identifier then + Invalidate_Current_Token; + end if; + exception + when Parse_Error => + Put_Line ("found " & Token_Type'Image (Current_Token)); + if Current_Token = Tok_Identifier then + Put_Line ("identifier: " & Name_Table.Image (Current_Identifier)); + end if; + raise; + end Expect; + + -- Scan a token and expect it. + procedure Scan_Expect (Token: Token_Type; Msg: String := "") is + begin + Scan; + Expect (Token, Msg); + end Scan_Expect; + + -- If the current_token is an identifier, it must be equal to name. + -- In this case, a token is eaten. + -- If the current_token is not an identifier, this is a noop. + procedure Check_End_Name (Name : Name_Id; Decl : Iir) is + begin + if Current_Token /= Tok_Identifier then + return; + end if; + if Name = Null_Identifier then + Error_Msg_Parse + ("end label for an unlabeled declaration or statement"); + else + if Current_Identifier /= Name then + Error_Msg_Parse + ("mispelling, """ & Name_Table.Image (Name) & """ expected"); + else + Set_End_Has_Identifier (Decl, True); + Xrefs.Xref_End (Get_Token_Location, Decl); + end if; + end if; + Scan; + end Check_End_Name; + + procedure Check_End_Name (Decl : Iir) is + begin + Check_End_Name (Get_Identifier (Decl), Decl); + end Check_End_Name; + + + -- Expect ' END tok [ name ] ; ' + procedure Check_End_Name (Tok : Token_Type; Decl : Iir) is + begin + if Current_Token /= Tok_End then + Error_Msg_Parse ("""end " & Image (Tok) & ";"" expected"); + else + Scan; + if Current_Token /= Tok then + Error_Msg_Parse + ("""end"" must be followed by """ & Image (Tok) & """"); + else + Set_End_Has_Reserved_Id (Decl, True); + Scan; + end if; + Check_End_Name (Decl); + Expect (Tok_Semi_Colon); + end if; + end Check_End_Name; + + procedure Eat_Tokens_Until_Semi_Colon is + begin + loop + case Current_Token is + when Tok_Semi_Colon + | Tok_Eof => + exit; + when others => + Scan; + end case; + end loop; + end Eat_Tokens_Until_Semi_Colon; + + -- Expect and scan ';' emit an error message using MSG if not present. + procedure Scan_Semi_Colon (Msg : String) is + begin + if Current_Token /= Tok_Semi_Colon then + Error_Msg_Parse ("missing "";"" at end of " & Msg); + else + Scan; + end if; + end Scan_Semi_Colon; + + -- precond : next token + -- postcond: next token. + -- + -- [§ 4.3.2 ] + -- mode ::= IN | OUT | INOUT | BUFFER | LINKAGE + -- + -- If there is no mode, DEFAULT is returned. + function Parse_Mode (Default: Iir_Mode) return Iir_Mode is + begin + case Current_Token is + when Tok_Identifier => + return Default; + when Tok_In => + Scan; + if Current_Token = Tok_Out then + -- Nice message for Ada users... + Error_Msg_Parse ("typo error, in out must be 'inout' in vhdl"); + Scan; + return Iir_Inout_Mode; + end if; + return Iir_In_Mode; + when Tok_Out => + Scan; + return Iir_Out_Mode; + when Tok_Inout => + Scan; + return Iir_Inout_Mode; + when Tok_Linkage => + Scan; + return Iir_Linkage_Mode; + when Tok_Buffer => + Scan; + return Iir_Buffer_Mode; + when others => + Error_Msg_Parse + ("mode is 'in', 'out', 'inout', 'buffer' or 'linkage'"); + return Iir_In_Mode; + end case; + end Parse_Mode; + + -- precond : next token + -- postcond: next token + -- + -- [ §4.3.1.2 ] + -- signal_kind ::= REGISTER | BUS + -- + -- If there is no signal_kind, then no_signal_kind is returned. + function Parse_Signal_Kind return Iir_Signal_Kind is + begin + if Current_Token = Tok_Bus then + Scan; + return Iir_Bus_Kind; + elsif Current_Token = Tok_Register then + Scan; + return Iir_Register_Kind; + else + return Iir_No_Signal_Kind; + end if; + end Parse_Signal_Kind; + + -- precond : next token + -- postcond: next token + -- + -- Parse a range. + -- If LEFT is not null_iir, then it must be an expression corresponding to + -- the left limit of the range, and the current_token must be either + -- tok_to or tok_downto. + -- If left is null_iir, the current token is used to create the left limit + -- expression. + -- + -- [3.1] + -- range ::= RANGE_attribute_name + -- | simple_expression direction simple_expression + function Parse_Range_Expression (Left: Iir; Discrete: Boolean := False) + return Iir + is + Res : Iir; + Left1: Iir; + begin + if Left /= Null_Iir then + Left1 := Left; + else + Left1 := Parse_Simple_Expression; + end if; + + case Current_Token is + when Tok_To => + Res := Create_Iir (Iir_Kind_Range_Expression); + Set_Direction (Res, Iir_To); + when Tok_Downto => + Res := Create_Iir (Iir_Kind_Range_Expression); + Set_Direction (Res, Iir_Downto); + when Tok_Range => + if not Discrete then + Unexpected ("range definition"); + end if; + Scan; + if Current_Token = Tok_Box then + Unexpected ("range expression expected"); + Scan; + return Null_Iir; + end if; + Res := Parse_Range_Expression (Null_Iir, False); + if Res /= Null_Iir then + Set_Type (Res, Left1); + end if; + return Res; + when others => + if Left1 = Null_Iir then + return Null_Iir; + end if; + if Is_Range_Attribute_Name (Left1) then + return Left1; + end if; + if Discrete + and then Get_Kind (Left1) in Iir_Kinds_Denoting_Name + then + return Left1; + end if; + Error_Msg_Parse ("'to' or 'downto' expected"); + return Null_Iir; + end case; + Set_Left_Limit (Res, Left1); + Location_Copy (Res, Left1); + + Scan; + Set_Right_Limit (Res, Parse_Simple_Expression); + return Res; + end Parse_Range_Expression; + + -- [ 3.1 ] + -- range_constraint ::= RANGE range + -- + -- [ 3.1 ] + -- range ::= range_attribute_name + -- | simple_expression direction simple_expression + -- + -- [ 3.1 ] + -- direction ::= TO | DOWNTO + + -- precond: TO or DOWNTO + -- postcond: next token + function Parse_Range_Right (Left : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Range_Expression); + Set_Location (Res); + Set_Left_Limit (Res, Left); + + case Current_Token is + when Tok_To => + Set_Direction (Res, Iir_To); + when Tok_Downto => + Set_Direction (Res, Iir_Downto); + when others => + raise Internal_Error; + end case; + + Scan; + Set_Right_Limit (Res, Parse_Simple_Expression); + return Res; + end Parse_Range_Right; + + -- precond: next token + -- postcond: next token + function Parse_Range return Iir + is + Left: Iir; + begin + Left := Parse_Simple_Expression; + + case Current_Token is + when Tok_To + | Tok_Downto => + return Parse_Range_Right (Left); + when others => + if Left /= Null_Iir then + if Is_Range_Attribute_Name (Left) then + return Left; + end if; + Error_Msg_Parse ("'to' or 'downto' expected"); + end if; + return Null_Iir; + end case; + end Parse_Range; + + -- precond: next token (after RANGE) + -- postcond: next token + function Parse_Range_Constraint return Iir is + begin + if Current_Token = Tok_Box then + Error_Msg_Parse ("range constraint required"); + Scan; + return Null_Iir; + end if; + + return Parse_Range; + end Parse_Range_Constraint; + + -- precond: next token (after RANGE) + -- postcond: next token + function Parse_Range_Constraint_Of_Subtype_Indication + (Type_Mark : Iir; + Resolution_Indication : Iir := Null_Iir) + return Iir + is + Def : Iir; + begin + Def := Create_Iir (Iir_Kind_Subtype_Definition); + Location_Copy (Def, Type_Mark); + Set_Subtype_Type_Mark (Def, Type_Mark); + Set_Range_Constraint (Def, Parse_Range_Constraint); + Set_Resolution_Indication (Def, Resolution_Indication); + Set_Tolerance (Def, Parse_Tolerance_Aspect_Opt); + + return Def; + end Parse_Range_Constraint_Of_Subtype_Indication; + + -- precond: next token + -- postcond: next token + -- + -- [ 3.2.1 ] + -- discrete_range ::= discrete_subtype_indication | range + function Parse_Discrete_Range return Iir + is + Left: Iir; + begin + Left := Parse_Simple_Expression; + + case Current_Token is + when Tok_To + | Tok_Downto => + return Parse_Range_Right (Left); + when Tok_Range => + return Parse_Subtype_Indication (Left); + when others => + -- Either a /range/_attribute_name or a type_mark. + return Left; + end case; + end Parse_Discrete_Range; + + -- Convert the STR (0 .. LEN - 1) into a operator symbol identifier. + -- Emit an error message if the name is not an operator name. + function Str_To_Operator_Name (Str : String_Fat_Acc; + Len : Nat32; + Loc : Location_Type) return Name_Id + is + -- LRM93 2.1 + -- Extra spaces are not allowed in an operator symbol, and the + -- case of letters is not signifiant. + + -- LRM93 2.1 + -- The sequence of characters represented by an operator symbol + -- must be an operator belonging to one of classes of operators + -- defined in section 7.2. + + procedure Bad_Operator_Symbol is + begin + Error_Msg_Parse ("""" & String (Str (1 .. Len)) + & """ is not an operator symbol", Loc); + end Bad_Operator_Symbol; + + procedure Check_Vhdl93 is + begin + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("""" & String (Str (1 .. Len)) + & """ is not a vhdl87 operator symbol", Loc); + end if; + end Check_Vhdl93; + + Id : Name_Id; + C1, C2, C3, C4 : Character; + begin + C1 := Str (1); + case Len is + when 1 => + -- =, <, >, +, -, *, /, & + case C1 is + when '=' => + Id := Name_Op_Equality; + when '>' => + Id := Name_Op_Greater; + when '<' => + Id := Name_Op_Less; + when '+' => + Id := Name_Op_Plus; + when '-' => + Id := Name_Op_Minus; + when '*' => + Id := Name_Op_Mul; + when '/' => + Id := Name_Op_Div; + when '&' => + Id := Name_Op_Concatenation; + when others => + Bad_Operator_Symbol; + Id := Name_Op_Plus; + end case; + when 2 => + -- or, /=, <=, >=, ** + C2 := Str (2); + case C1 is + when 'o' | 'O' => + Id := Name_Or; + if C2 /= 'r' and C2 /= 'R' then + Bad_Operator_Symbol; + end if; + when '/' => + Id := Name_Op_Inequality; + if C2 /= '=' then + Bad_Operator_Symbol; + end if; + when '<' => + Id := Name_Op_Less_Equal; + if C2 /= '=' then + Bad_Operator_Symbol; + end if; + when '>' => + Id := Name_Op_Greater_Equal; + if C2 /= '=' then + Bad_Operator_Symbol; + end if; + when '*' => + Id := Name_Op_Exp; + if C2 /= '*' then + Bad_Operator_Symbol; + end if; + when '?' => + if Vhdl_Std < Vhdl_08 then + Bad_Operator_Symbol; + Id := Name_Op_Condition; + elsif C2 = '?' then + Id := Name_Op_Condition; + elsif C2 = '=' then + Id := Name_Op_Match_Equality; + elsif C2 = '<' then + Id := Name_Op_Match_Less; + elsif C2 = '>' then + Id := Name_Op_Match_Greater; + else + Bad_Operator_Symbol; + Id := Name_Op_Condition; + end if; + when others => + Bad_Operator_Symbol; + Id := Name_Op_Equality; + end case; + when 3 => + -- mod, rem, and, xor, nor, abs, not, sll, sla, sra, srl, rol + -- ror + C2 := Str (2); + C3 := Str (3); + case C1 is + when 'm' | 'M' => + Id := Name_Mod; + if (C2 /= 'o' and C2 /= 'O') or (C3 /= 'd' and C3 /= 'D') + then + Bad_Operator_Symbol; + end if; + when 'a' | 'A' => + if (C2 = 'n' or C2 = 'N') and (C3 = 'd' or C3 = 'D') then + Id := Name_And; + elsif (C2 = 'b' or C2 = 'B') and (C3 = 's' or C3 = 'S') then + Id := Name_Abs; + else + Id := Name_And; + Bad_Operator_Symbol; + end if; + when 'x' | 'X' => + Id := Name_Xor; + if (C2 /= 'o' and C2 /= 'O') or (C3 /= 'r' and C3 /= 'R') + then + Bad_Operator_Symbol; + end if; + when 'n' | 'N' => + if C2 = 'o' or C2 = 'O' then + if C3 = 'r' or C3 = 'R' then + Id := Name_Nor; + elsif C3 = 't' or C3 = 'T' then + Id := Name_Not; + else + Id := Name_Not; + Bad_Operator_Symbol; + end if; + else + Id := Name_Not; + Bad_Operator_Symbol; + end if; + when 's' | 'S' => + if C2 = 'l' or C2 = 'L' then + if C3 = 'l' or C3 = 'L' then + Check_Vhdl93; + Id := Name_Sll; + elsif C3 = 'a' or C3 = 'A' then + Check_Vhdl93; + Id := Name_Sla; + else + Id := Name_Sll; + Bad_Operator_Symbol; + end if; + elsif C2 = 'r' or C2 = 'R' then + if C3 = 'l' or C3 = 'L' then + Check_Vhdl93; + Id := Name_Srl; + elsif C3 = 'a' or C3 = 'A' then + Check_Vhdl93; + Id := Name_Sra; + else + Id := Name_Srl; + Bad_Operator_Symbol; + end if; + else + Id := Name_Sll; + Bad_Operator_Symbol; + end if; + when 'r' | 'R' => + if C2 = 'e' or C2 = 'E' then + if C3 = 'm' or C3 = 'M' then + Id := Name_Rem; + else + Id := Name_Rem; + Bad_Operator_Symbol; + end if; + elsif C2 = 'o' or C2 = 'O' then + if C3 = 'l' or C3 = 'L' then + Check_Vhdl93; + Id := Name_Rol; + elsif C3 = 'r' or C3 = 'R' then + Check_Vhdl93; + Id := Name_Ror; + else + Id := Name_Rol; + Bad_Operator_Symbol; + end if; + else + Id := Name_Rem; + Bad_Operator_Symbol; + end if; + when '?' => + if Vhdl_Std < Vhdl_08 then + Bad_Operator_Symbol; + Id := Name_Op_Match_Less_Equal; + else + if C2 = '<' and C3 = '=' then + Id := Name_Op_Match_Less_Equal; + elsif C2 = '>' and C3 = '=' then + Id := Name_Op_Match_Greater_Equal; + elsif C2 = '/' and C3 = '=' then + Id := Name_Op_Match_Inequality; + else + Bad_Operator_Symbol; + Id := Name_Op_Match_Less_Equal; + end if; + end if; + when others => + Id := Name_And; + Bad_Operator_Symbol; + end case; + when 4 => + -- nand, xnor + C2 := Str (2); + C3 := Str (3); + C4 := Str (4); + if (C1 = 'n' or C1 = 'N') + and (C2 = 'a' or C2 = 'A') + and (C3 = 'n' or C3 = 'N') + and (C4 = 'd' or C4 = 'D') + then + Id := Name_Nand; + elsif (C1 = 'x' or C1 = 'X') + and (C2 = 'n' or C2 = 'N') + and (C3 = 'o' or C3 = 'O') + and (C4 = 'r' or C4 = 'R') + then + Check_Vhdl93; + Id := Name_Xnor; + else + Id := Name_Nand; + Bad_Operator_Symbol; + end if; + when others => + Id := Name_Op_Plus; + Bad_Operator_Symbol; + end case; + return Id; + end Str_To_Operator_Name; + + function Scan_To_Operator_Name (Loc : Location_Type) return Name_Id is + begin + return Str_To_Operator_Name + (Str_Table.Get_String_Fat_Acc (Current_String_Id), + Current_String_Length, + Loc); + end Scan_To_Operator_Name; + pragma Inline (Scan_To_Operator_Name); + + -- Convert string literal STR to an operator symbol. + -- Emit an error message if the string is not an operator name. + function String_To_Operator_Symbol (Str : Iir_String_Literal) + return Iir + is + Id : Name_Id; + Res : Iir; + begin + Id := Str_To_Operator_Name + (Str_Table.Get_String_Fat_Acc (Get_String_Id (Str)), + Get_String_Length (Str), + Get_Location (Str)); + Res := Create_Iir (Iir_Kind_Operator_Symbol); + Location_Copy (Res, Str); + Set_Identifier (Res, Id); + Free_Iir (Str); + return Res; + end String_To_Operator_Symbol; + + -- precond : next token + -- postcond: next token + -- + -- [ §6.1 ] + -- name ::= simple_name + -- | operator_symbol + -- | selected_name + -- | indexed_name + -- | slice_name + -- | attribute_name + -- + -- [ §6.2 ] + -- simple_name ::= identifier + -- + -- [ §6.5 ] + -- slice_name ::= prefix ( discrete_range ) + -- + -- [ §6.3 ] + -- selected_name ::= prefix . suffix + -- + -- [ §6.1 ] + -- prefix ::= name + -- | function_call + -- + -- [ §6.3 ] + -- suffix ::= simple_name + -- | character_literal + -- | operator_symbol + -- | ALL + -- + -- [ §3.2.1 ] + -- discrete_range ::= DISCRETE_subtype_indication | range + -- + -- [ §3.1 ] + -- range ::= RANGE_attribute_name + -- | simple_expression direction simple_expression + -- + -- [ §3.1 ] + -- direction ::= TO | DOWNTO + -- + -- [ §6.6 ] + -- attribute_name ::= + -- prefix [ signature ] ' attribute_designator [ ( expression ) ] + -- + -- [ §6.6 ] + -- attribute_designator ::= ATTRIBUTE_simple_name + -- + -- Note: in order to simplify the parsing, this function may return a + -- signature without attribute designator. Signatures may appear at 3 + -- places: + -- - in attribute name + -- - in alias declaration + -- - in entity designator + function Parse_Name_Suffix (Pfx : Iir; Allow_Indexes: Boolean := True) + return Iir + is + Res: Iir; + Prefix: Iir; + begin + Res := Pfx; + loop + Prefix := Res; + + case Current_Token is + when Tok_Left_Bracket => + if Get_Kind (Prefix) = Iir_Kind_String_Literal then + Prefix := String_To_Operator_Symbol (Prefix); + end if; + + -- There is a signature. They are normally followed by an + -- attribute. + Res := Parse_Signature; + Set_Signature_Prefix (Res, Prefix); + + when Tok_Tick => + -- There is an attribute. + if Get_Kind (Prefix) = Iir_Kind_String_Literal then + Prefix := String_To_Operator_Symbol (Prefix); + end if; + + Scan; + if Current_Token = Tok_Left_Paren then + -- A qualified expression. + Res := Create_Iir (Iir_Kind_Qualified_Expression); + Set_Type_Mark (Res, Prefix); + Location_Copy (Res, Prefix); + Set_Expression (Res, Parse_Aggregate); + return Res; + elsif Current_Token /= Tok_Range + and then Current_Token /= Tok_Identifier + then + Expect (Tok_Identifier, "required for an attribute name"); + return Null_Iir; + end if; + Res := Create_Iir (Iir_Kind_Attribute_Name); + Set_Identifier (Res, Current_Identifier); + Set_Location (Res); + if Get_Kind (Prefix) = Iir_Kind_Signature then + Set_Attribute_Signature (Res, Prefix); + Set_Prefix (Res, Get_Signature_Prefix (Prefix)); + else + Set_Prefix (Res, Prefix); + end if; + + -- accept the identifier. + Scan; + + when Tok_Left_Paren => + if not Allow_Indexes then + return Res; + end if; + + if Get_Kind (Prefix) = Iir_Kind_String_Literal then + Prefix := String_To_Operator_Symbol (Prefix); + end if; + + Res := Create_Iir (Iir_Kind_Parenthesis_Name); + Set_Location (Res); + Set_Prefix (Res, Prefix); + Set_Association_Chain + (Res, Parse_Association_List_In_Parenthesis); + + when Tok_Dot => + if Get_Kind (Prefix) = Iir_Kind_String_Literal then + Prefix := String_To_Operator_Symbol (Prefix); + end if; + + Scan; + case Current_Token is + when Tok_All => + Res := Create_Iir (Iir_Kind_Selected_By_All_Name); + Set_Location (Res); + Set_Prefix (Res, Prefix); + when Tok_Identifier + | Tok_Character => + Res := Create_Iir (Iir_Kind_Selected_Name); + Set_Location (Res); + Set_Prefix (Res, Prefix); + Set_Identifier (Res, Current_Identifier); + when Tok_String => + Res := Create_Iir (Iir_Kind_Selected_Name); + Set_Location (Res); + Set_Prefix (Res, Prefix); + Set_Identifier + (Res, Scan_To_Operator_Name (Get_Token_Location)); + when others => + Error_Msg_Parse ("an identifier or all is expected"); + end case; + Scan; + when others => + return Res; + end case; + end loop; + end Parse_Name_Suffix; + + function Parse_Name (Allow_Indexes: Boolean := True) return Iir + is + Res: Iir; + begin + case Current_Token is + when Tok_Identifier => + Res := Create_Iir (Iir_Kind_Simple_Name); + Set_Identifier (Res, Current_Identifier); + Set_Location (Res); + when Tok_String => + Res := Create_Iir (Iir_Kind_String_Literal); + Set_String_Id (Res, Current_String_Id); + Set_String_Length (Res, Current_String_Length); + Set_Location (Res); + when others => + Error_Msg_Parse ("identifier expected here"); + raise Parse_Error; + end case; + + Scan; + + return Parse_Name_Suffix (Res, Allow_Indexes); + end Parse_Name; + + -- Emit an error message if MARK doesn't have the form of a type mark. + procedure Check_Type_Mark (Mark : Iir) is + begin + case Get_Kind (Mark) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + null; + when others => + Error_Msg_Parse ("type mark must be a name of a type", Mark); + end case; + end Check_Type_Mark; + + -- precond : next token + -- postcond: next token + -- + -- [ 4.2 ] + -- type_mark ::= type_name + -- | subtype_name + function Parse_Type_Mark (Check_Paren : Boolean := False) return Iir + is + Res : Iir; + Old : Iir; + pragma Unreferenced (Old); + begin + Res := Parse_Name (Allow_Indexes => False); + Check_Type_Mark (Res); + if Check_Paren and then Current_Token = Tok_Left_Paren then + Error_Msg_Parse ("index constraint not allowed here"); + Old := Parse_Name_Suffix (Res, True); + end if; + return Res; + end Parse_Type_Mark; + + -- precond : CONSTANT, SIGNAL, VARIABLE. FILE or identifier + -- postcond: next token (';' or ')') + -- + -- [ LRM93 4.3.2 ] [ LRM08 6.5.2 ] + -- interface_declaration ::= interface_constant_declaration + -- | interface_signal_declaration + -- | interface_variable_declaration + -- | interface_file_declaration + -- + -- + -- [ LRM93 3.2.2 ] + -- identifier_list ::= identifier { , identifier } + -- + -- [ LRM93 4.3.2 ] + -- interface_constant_declaration ::= + -- [ CONSTANT ] identifier_list : [ IN ] subtype_indication + -- [ := STATIC_expression ] + -- + -- [ LRM93 4.3.2 ] + -- interface_file_declaration ::= FILE identifier_list : subtype_indication + -- + -- [ LRM93 4.3.2 ] + -- interface_signal_declaration ::= + -- [ SIGNAL ] identifier_list : [ mode ] subtype_indication [ BUS ] + -- [ := STATIC_expression ] + -- + -- [ LRM93 4.3.2 ] + -- interface_variable_declaration ::= + -- [ VARIABLE ] identifier_list : [ mode ] subtype_indication + -- [ := STATIC_expression ] + -- + -- The default kind of interface declaration is DEFAULT. + function Parse_Interface_Object_Declaration (Ctxt : Interface_Kind_Type) + return Iir + is + Kind : Iir_Kind; + Res, Last : Iir; + First, Prev_First : Iir; + Inter: Iir; + Is_Default : Boolean; + Interface_Mode: Iir_Mode; + Interface_Type: Iir; + Signal_Kind: Iir_Signal_Kind; + Default_Value: Iir; + Lexical_Layout : Iir_Lexical_Layout_Type; + begin + Res := Null_Iir; + Last := Null_Iir; + + -- LRM08 6.5.2 Interface object declarations + -- Interface obejcts include interface constants that appear as + -- generics of a design entity, a component, a block, a package or + -- a subprogram, or as constant parameter of subprograms; interface + -- signals that appear as ports of a design entity, component or + -- block, or as signal parameters of subprograms; interface variables + -- that appear as variable parameter subprograms; interface files + -- that appear as file parameters of subrograms. + case Current_Token is + when Tok_Identifier => + -- The class of the object is unknown. Select default + -- according to the above rule, assuming the mode is IN. If + -- the mode is not IN, Parse_Interface_Object_Declaration will + -- change the class. + case Ctxt is + when Generic_Interface_List + | Parameter_Interface_List => + Kind := Iir_Kind_Interface_Constant_Declaration; + when Port_Interface_List => + Kind := Iir_Kind_Interface_Signal_Declaration; + end case; + when Tok_Constant => + Kind := Iir_Kind_Interface_Constant_Declaration; + when Tok_Signal => + if Ctxt = Generic_Interface_List then + Error_Msg_Parse + ("signal interface not allowed in generic clause"); + end if; + Kind := Iir_Kind_Interface_Signal_Declaration; + when Tok_Variable => + if Ctxt not in Parameter_Interface_List then + Error_Msg_Parse + ("variable interface not allowed in generic or port clause"); + end if; + Kind := Iir_Kind_Interface_Variable_Declaration; + when Tok_File => + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("file interface not allowed in vhdl 87"); + end if; + if Ctxt not in Parameter_Interface_List then + Error_Msg_Parse + ("variable interface not allowed in generic or port clause"); + end if; + Kind := Iir_Kind_Interface_File_Declaration; + when others => + -- Fall back in case of parse error. + Kind := Iir_Kind_Interface_Variable_Declaration; + end case; + + Inter := Create_Iir (Kind); + + if Current_Token = Tok_Identifier then + Is_Default := True; + Lexical_Layout := 0; + else + Is_Default := False; + Lexical_Layout := Iir_Lexical_Has_Class; + + -- Skip 'signal', 'variable', 'constant' or 'file'. + Scan; + end if; + + Prev_First := Last; + First := Inter; + loop + if Current_Token /= Tok_Identifier then + Expect (Tok_Identifier); + end if; + Set_Identifier (Inter, Current_Identifier); + Set_Location (Inter); + + if Res = Null_Iir then + Res := Inter; + else + Set_Chain (Last, Inter); + end if; + Last := Inter; + + -- Skip identifier + Scan; + + exit when Current_Token = Tok_Colon; + Expect (Tok_Comma, "',' or ':' expected after identifier"); + + -- Skip ',' + Scan; + + Inter := Create_Iir (Kind); + end loop; + + Expect (Tok_Colon, "':' must follow the interface element identifier"); + + -- Skip ':' + Scan; + + -- LRM93 2.1.1 LRM08 4.2.2.1 + -- If the mode is INOUT or OUT, and no object class is explicitly + -- specified, variable is assumed. + if Is_Default + and then Ctxt in Parameter_Interface_List + and then (Current_Token = Tok_Inout or else Current_Token = Tok_Out) + then + -- Convert into variable. + declare + O_Interface : Iir_Interface_Constant_Declaration; + N_Interface : Iir_Interface_Variable_Declaration; + begin + O_Interface := First; + while O_Interface /= Null_Iir loop + N_Interface := + Create_Iir (Iir_Kind_Interface_Variable_Declaration); + Location_Copy (N_Interface, O_Interface); + Set_Identifier (N_Interface, + Get_Identifier (O_Interface)); + if Prev_First = Null_Iir then + Res := N_Interface; + else + Set_Chain (Prev_First, N_Interface); + end if; + Prev_First := N_Interface; + if O_Interface = First then + First := N_Interface; + end if; + Last := N_Interface; + Inter := Get_Chain (O_Interface); + Free_Iir (O_Interface); + O_Interface := Inter; + end loop; + Inter := First; + end; + end if; + + -- Update lexical layout if mode is present. + case Current_Token is + when Tok_In + | Tok_Out + | Tok_Inout + | Tok_Linkage + | Tok_Buffer => + Lexical_Layout := Lexical_Layout or Iir_Lexical_Has_Mode; + when others => + null; + end case; + + -- Parse mode (and handle default mode). + case Get_Kind (Inter) is + when Iir_Kind_Interface_File_Declaration => + if Parse_Mode (Iir_Unknown_Mode) /= Iir_Unknown_Mode then + Error_Msg_Parse + ("mode can't be specified for a file interface"); + end if; + Interface_Mode := Iir_Inout_Mode; + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Variable_Declaration => + -- LRM93 4.3.2 + -- If no mode is explicitly given in an interface declaration + -- other than an interface file declaration, mode IN is + -- assumed. + Interface_Mode := Parse_Mode (Iir_In_Mode); + when Iir_Kind_Interface_Constant_Declaration => + Interface_Mode := Parse_Mode (Iir_In_Mode); + if Interface_Mode /= Iir_In_Mode then + Error_Msg_Parse ("mode must be 'in' for a constant"); + end if; + when others => + raise Internal_Error; + end case; + + Interface_Type := Parse_Subtype_Indication; + + -- Signal kind (but only for signal). + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then + Signal_Kind := Parse_Signal_Kind; + else + Signal_Kind := Iir_No_Signal_Kind; + end if; + + if Current_Token = Tok_Assign then + if Get_Kind (Inter) = Iir_Kind_Interface_File_Declaration then + Error_Msg_Parse + ("default expression not allowed for an interface file"); + end if; + + -- Skip ':=' + Scan; + + Default_Value := Parse_Expression; + else + Default_Value := Null_Iir; + end if; + + -- Subtype_Indication and Default_Value are set only on the first + -- interface. + Set_Subtype_Indication (First, Interface_Type); + if Get_Kind (First) /= Iir_Kind_Interface_File_Declaration then + Set_Default_Value (First, Default_Value); + end if; + + Inter := First; + while Inter /= Null_Iir loop + Set_Mode (Inter, Interface_Mode); + Set_Is_Ref (Inter, Inter /= First); + if Inter = Last then + Set_Lexical_Layout (Inter, + Lexical_Layout or Iir_Lexical_Has_Type); + else + Set_Lexical_Layout (Inter, Lexical_Layout); + end if; + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then + Set_Signal_Kind (Inter, Signal_Kind); + end if; + Inter := Get_Chain (Inter); + end loop; + + return Res; + end Parse_Interface_Object_Declaration; + + -- Precond : 'package' + -- Postcond: next token + -- + -- LRM08 6.5.5 Interface package declarations + -- interface_package_declaration ::= + -- PACKAGE identifier IS NEW uninstantiated_package name + -- interface_package_generic_map_aspect + -- + -- interface_package_generic_map_aspect ::= + -- generic_map_aspect + -- | GENERIC MAP ( <> ) + -- | GENERIC MAP ( DEFAULT ) + function Parse_Interface_Package_Declaration return Iir + is + Inter : Iir; + Map : Iir; + begin + Inter := Create_Iir (Iir_Kind_Interface_Package_Declaration); + + -- Skip 'package' + Scan_Expect (Tok_Identifier, + "an identifier is expected after ""package"""); + Set_Identifier (Inter, Current_Identifier); + Set_Location (Inter); + + -- Skip identifier + Scan_Expect (Tok_Is); + + -- Skip 'is' + Scan_Expect (Tok_New); + + -- Skip 'new' + Scan; + + Set_Uninstantiated_Package_Name (Inter, Parse_Name (False)); + + Expect (Tok_Generic); + + -- Skip 'generic' + Scan_Expect (Tok_Map); + + -- Skip 'map' + Scan_Expect (Tok_Left_Paren); + + -- Skip '(' + Scan; + + case Current_Token is + when Tok_Box => + Map := Null_Iir; + -- Skip '<>' + Scan; + when others => + Map := Parse_Association_List; + end case; + Set_Generic_Map_Aspect_Chain (Inter, Map); + + Expect (Tok_Right_Paren); + + -- Skip ')' + Scan; + + return Inter; + end Parse_Interface_Package_Declaration; + + -- Precond : '(' + -- Postcond: next token + -- + -- LRM08 6.5.6 Interface lists + -- interface_list ::= interface_element { ';' interface_element } + -- + -- interface_element ::= interface_declaration + function Parse_Interface_List (Ctxt : Interface_Kind_Type; Parent : Iir) + return Iir + is + Res, Last : Iir; + Inters : Iir; + Next : Iir; + Prev_Loc : Location_Type; + begin + Expect (Tok_Left_Paren); + + Res := Null_Iir; + Last := Null_Iir; + loop + Prev_Loc := Get_Token_Location; + + -- Skip '(' or ';' + Scan; + + case Current_Token is + when Tok_Identifier + | Tok_Signal + | Tok_Variable + | Tok_Constant + | Tok_File => + -- An inteface object. + Inters := Parse_Interface_Object_Declaration (Ctxt); + when Tok_Package => + if Ctxt /= Generic_Interface_List then + Error_Msg_Parse + ("package interface only allowed in generic interface"); + elsif Flags.Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("package interface not allowed before vhdl 08"); + end if; + Inters := Parse_Interface_Package_Declaration; + when Tok_Right_Paren => + if Res = Null_Iir then + Error_Msg_Parse + ("empty interface list not allowed", Prev_Loc); + else + Error_Msg_Parse + ("extra ';' at end of interface list", Prev_Loc); + end if; + exit; + when others => + Error_Msg_Parse + ("'signal', 'constant', 'variable', 'file' " + & "or identifier expected"); + -- Use a variable interface as a fall-back. + Inters := Parse_Interface_Object_Declaration (Ctxt); + end case; + + -- Chain + if Last = Null_Iir then + Res := Inters; + else + Set_Chain (Last, Inters); + end if; + + -- Set parent and set Last to the last interface. + Last := Inters; + loop + Set_Parent (Last, Parent); + Next := Get_Chain (Last); + exit when Next = Null_Iir; + Last := Next; + end loop; + + exit when Current_Token /= Tok_Semi_Colon; + end loop; + + if Current_Token /= Tok_Right_Paren then + Error_Msg_Parse ("')' expected at end of interface list"); + end if; + + -- Skip ')' + Scan; + + return Res; + end Parse_Interface_List; + + -- precond : PORT + -- postcond: next token + -- + -- [ §1.1.1 ] + -- port_clause ::= PORT ( port_list ) ; + -- + -- [ §1.1.1.2 ] + -- port_list ::= PORT_interface_list + procedure Parse_Port_Clause (Parent : Iir) + is + Res: Iir; + El : Iir; + begin + -- Skip 'port' + pragma Assert (Current_Token = Tok_Port); + Scan; + + Res := Parse_Interface_List (Port_Interface_List, Parent); + + -- Check the interface are signal interfaces. + El := Res; + while El /= Null_Iir loop + if Get_Kind (El) /= Iir_Kind_Interface_Signal_Declaration then + Error_Msg_Parse ("port must be a signal", El); + end if; + El := Get_Chain (El); + end loop; + + Scan_Semi_Colon ("port clause"); + Set_Port_Chain (Parent, Res); + end Parse_Port_Clause; + + -- precond : GENERIC + -- postcond: next token + -- + -- [ LRM93 1.1.1, LRM08 6.5.6.2 ] + -- generic_clause ::= GENERIC ( generic_list ) ; + -- + -- [ LRM93 1.1.1.1, LRM08 6.5.6.2] + -- generic_list ::= GENERIC_interface_list + procedure Parse_Generic_Clause (Parent : Iir) + is + Res: Iir; + begin + -- Skip 'generic' + pragma Assert (Current_Token = Tok_Generic); + Scan; + + Res := Parse_Interface_List (Generic_Interface_List, Parent); + Set_Generic_Chain (Parent, Res); + + Scan_Semi_Colon ("generic clause"); + end Parse_Generic_Clause; + + -- precond : a token. + -- postcond: next token + -- + -- [ §1.1.1 ] + -- entity_header ::= + -- [ FORMAL_generic_clause ] + -- [ FORMAL_port_clause ] + -- + -- [ §4.5 ] + -- [ LOCAL_generic_clause ] + -- [ LOCAL_port_clause ] + procedure Parse_Generic_Port_Clauses (Parent : Iir) + is + Has_Port, Has_Generic : Boolean; + begin + Has_Port := False; + Has_Generic := False; + loop + if Current_Token = Tok_Generic then + if Has_Generic then + Error_Msg_Parse ("at most one generic clause is allowed"); + end if; + if Has_Port then + Error_Msg_Parse ("generic clause must precede port clause"); + end if; + Has_Generic := True; + Parse_Generic_Clause (Parent); + elsif Current_Token = Tok_Port then + if Has_Port then + Error_Msg_Parse ("at most one port clause is allowed"); + end if; + Has_Port := True; + Parse_Port_Clause (Parent); + else + exit; + end if; + end loop; + end Parse_Generic_Port_Clauses; + + -- precond : a token + -- postcond: next token + -- + -- [ §3.1.1 ] + -- enumeration_type_definition ::= + -- ( enumeration_literal { , enumeration_literal } ) + -- + -- [ §3.1.1 ] + -- enumeration_literal ::= identifier | character_literal + function Parse_Enumeration_Type_Definition + return Iir_Enumeration_Type_Definition + is + Pos: Iir_Int32; + Enum_Lit: Iir_Enumeration_Literal; + Enum_Type: Iir_Enumeration_Type_Definition; + Enum_List : Iir_List; + begin + -- This is an enumeration. + Enum_Type := Create_Iir (Iir_Kind_Enumeration_Type_Definition); + Set_Location (Enum_Type); + Enum_List := Create_Iir_List; + Set_Enumeration_Literal_List (Enum_Type, Enum_List); + + -- LRM93 3.1.1 + -- The position number of the first listed enumeration literal is zero. + Pos := 0; + -- scan every literal. + Scan; + if Current_Token = Tok_Right_Paren then + Error_Msg_Parse ("at least one literal must be declared"); + Scan; + return Enum_Type; + end if; + loop + if Current_Token /= Tok_Identifier + and then Current_Token /= Tok_Character + then + if Current_Token = Tok_Eof then + Error_Msg_Parse ("unexpected end of file"); + return Enum_Type; + end if; + Error_Msg_Parse ("identifier or character expected"); + end if; + Enum_Lit := Create_Iir (Iir_Kind_Enumeration_Literal); + Set_Identifier (Enum_Lit, Current_Identifier); + Set_Location (Enum_Lit); + Set_Enum_Pos (Enum_Lit, Pos); + + -- LRM93 3.1.1 + -- the position number for each additional enumeration literal is + -- one more than that if its predecessor in the list. + Pos := Pos + 1; + + Append_Element (Enum_List, Enum_Lit); + + -- next token. + Scan; + exit when Current_Token = Tok_Right_Paren; + if Current_Token /= Tok_Comma then + Error_Msg_Parse ("')' or ',' is expected after an enum literal"); + end if; + + -- scan a literal. + Scan; + if Current_Token = Tok_Right_Paren then + Error_Msg_Parse ("extra ',' ignored"); + exit; + end if; + end loop; + Scan; + return Enum_Type; + end Parse_Enumeration_Type_Definition; + + -- precond : ARRAY + -- postcond: ?? + -- + -- [ LRM93 3.2.1 ] + -- array_type_definition ::= unconstrained_array_definition + -- | constrained_array_definition + -- + -- unconstrained_array_definition ::= + -- ARRAY ( index_subtype_definition { , index_subtype_definition } ) + -- OF element_subtype_indication + -- + -- constrained_array_definition ::= + -- ARRAY index_constraint OF element_subtype_indication + -- + -- index_subtype_definition ::= type_mark RANGE <> + -- + -- 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; + Array_Constrained : Boolean; + First : Boolean; + Res_Type: Iir; + Index_List : Iir_List; + + Loc : Location_Type; + Def : Iir; + Type_Mark : Iir; + Element_Subtype : Iir; + begin + Loc := Get_Token_Location; + + -- Skip 'array', scan '(' + Scan_Expect (Tok_Left_Paren); + Scan; + + First := True; + Index_List := Create_Iir_List; + + loop + -- The accepted syntax can be one of: + -- * index_subtype_definition, which is: + -- * type_mark RANGE <> + -- * discrete_range, which is either: + -- * /discrete/_subtype_indication + -- * [ resolution_indication ] type_mark [ range_constraint ] + -- * range_constraint ::= RANGE range + -- * range + -- * /range/_attribute_name + -- * simple_expression direction simple_expression + + -- Parse a simple expression (for the range), which can also parse a + -- name. + Type_Mark := Parse_Simple_Expression; + + case Current_Token is + when Tok_Range => + -- Skip 'range' + Scan; + + if Current_Token = Tok_Box then + -- Parsed 'RANGE <>': this is an index_subtype_definition. + Index_Constrained := False; + Scan; + Def := Type_Mark; + else + -- This is a /discrete/_subtype_indication + Index_Constrained := True; + Def := + Parse_Range_Constraint_Of_Subtype_Indication (Type_Mark); + end if; + when Tok_To + | Tok_Downto => + -- A range + Index_Constrained := True; + Def := Parse_Range_Right (Type_Mark); + when others => + -- For a /range/_attribute_name + Index_Constrained := True; + Def := Type_Mark; + end case; + + Append_Element (Index_List, Def); + + if First then + Array_Constrained := Index_Constrained; + First := False; + else + if Array_Constrained /= Index_Constrained then + Error_Msg_Parse + ("cannot mix constrained and unconstrained index"); + end if; + end if; + exit when Current_Token /= Tok_Comma; + Scan; + end loop; + + -- Skip ')' and 'of' + Expect (Tok_Right_Paren); + Scan_Expect (Tok_Of); + Scan; + + Element_Subtype := Parse_Subtype_Indication; + + if Array_Constrained then + -- Sem_Type will create the array type. + Res_Type := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Element_Subtype (Res_Type, Element_Subtype); + Set_Index_Constraint_List (Res_Type, Index_List); + else + Res_Type := Create_Iir (Iir_Kind_Array_Type_Definition); + Set_Element_Subtype_Indication (Res_Type, Element_Subtype); + Set_Index_Subtype_Definition_List (Res_Type, Index_List); + end if; + Set_Location (Res_Type, Loc); + + return Res_Type; + end Parse_Array_Definition; + + -- precond : UNITS + -- postcond: next token + -- + -- [ LRM93 3.1.3 ] + -- physical_type_definition ::= + -- range_constraint + -- UNITS + -- base_unit_declaration + -- { secondary_unit_declaration } + -- END UNITS [ PHYSICAL_TYPE_simple_name ] + -- + -- [ LRM93 3.1.3 ] + -- base_unit_declaration ::= identifier ; + -- + -- [ LRM93 3.1.3 ] + -- secondary_unit_declaration ::= identifier = physical_literal ; + function Parse_Physical_Type_Definition (Parent : Iir) + return Iir_Physical_Type_Definition + is + use Iir_Chains.Unit_Chain_Handling; + Res: Iir_Physical_Type_Definition; + Unit: Iir_Unit_Declaration; + Last : Iir_Unit_Declaration; + Multiplier : Iir; + begin + Res := Create_Iir (Iir_Kind_Physical_Type_Definition); + Set_Location (Res); + + -- Skip 'units' + Expect (Tok_Units); + Scan; + + -- Parse primary unit. + Expect (Tok_Identifier); + Unit := Create_Iir (Iir_Kind_Unit_Declaration); + Set_Location (Unit); + Set_Parent (Unit, Parent); + Set_Identifier (Unit, Current_Identifier); + + -- Skip identifier + Scan; + + Scan_Semi_Colon ("primary unit"); + + Build_Init (Last); + Append (Last, Res, Unit); + + -- Parse secondary units. + while Current_Token /= Tok_End loop + Unit := Create_Iir (Iir_Kind_Unit_Declaration); + Set_Location (Unit); + Set_Identifier (Unit, Current_Identifier); + + -- Skip identifier. + Scan_Expect (Tok_Equal); + + -- Skip '='. + Scan; + + Multiplier := Parse_Primary; + Set_Physical_Literal (Unit, Multiplier); + case Get_Kind (Multiplier) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Physical_Int_Literal => + null; + when Iir_Kind_Physical_Fp_Literal => + Error_Msg_Parse + ("secondary units may only be defined with integer literals"); + when others => + Error_Msg_Parse ("a physical literal is expected here"); + end case; + Append (Last, Res, Unit); + Scan_Semi_Colon ("secondary unit"); + end loop; + + -- Skip 'end'. + Scan; + + Expect (Tok_Units); + Set_End_Has_Reserved_Id (Res, True); + + -- Skip 'units'. + Scan; + return Res; + end Parse_Physical_Type_Definition; + + -- precond : RECORD + -- postcond: next token + -- + -- [ LRM93 3.2.2 ] + -- record_type_definition ::= + -- RECORD + -- element_declaration + -- { element_declaration } + -- END RECORD [ RECORD_TYPE_simple_name ] + -- + -- element_declaration ::= + -- identifier_list : element_subtype_definition + -- + -- element_subtype_definition ::= subtype_indication + function Parse_Record_Type_Definition return Iir_Record_Type_Definition + is + Res: Iir_Record_Type_Definition; + El_List : Iir_List; + El: Iir_Element_Declaration; + First : Iir; + Pos: Iir_Index32; + Subtype_Indication: Iir; + begin + Res := Create_Iir (Iir_Kind_Record_Type_Definition); + Set_Location (Res); + El_List := Create_Iir_List; + Set_Elements_Declaration_List (Res, El_List); + + -- Skip 'record' + Scan; + + Pos := 0; + First := Null_Iir; + loop + pragma Assert (First = Null_Iir); + -- Parse identifier_list + 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_Element (El_List, El); + Set_Element_Position (El, Pos); + Pos := Pos + 1; + if First = Null_Iir then + First := El; + end if; + + -- Skip identifier + Scan; + + exit when Current_Token /= Tok_Comma; + + Set_Has_Identifier_List (El, True); + + -- Skip ',' + Scan; + end loop; + + -- Scan ':'. + Expect (Tok_Colon); + Scan; + + -- Parse element subtype indication. + Subtype_Indication := Parse_Subtype_Indication; + Set_Subtype_Indication (First, Subtype_Indication); + + First := Null_Iir; + Scan_Semi_Colon ("element declaration"); + exit when Current_Token = Tok_End; + end loop; + + -- Skip 'end' + Scan_Expect (Tok_Record); + Set_End_Has_Reserved_Id (Res, True); + + -- Skip 'record' + Scan; + + return Res; + end Parse_Record_Type_Definition; + + -- precond : ACCESS + -- postcond: ? + -- + -- [ LRM93 3.3] + -- access_type_definition ::= ACCESS subtype_indication. + function Parse_Access_Type_Definition return Iir_Access_Type_Definition + is + Res : Iir_Access_Type_Definition; + begin + Res := Create_Iir (Iir_Kind_Access_Type_Definition); + Set_Location (Res); + + -- Skip 'access' + Expect (Tok_Access); + Scan; + + Set_Designated_Subtype_Indication (Res, Parse_Subtype_Indication); + + return Res; + end Parse_Access_Type_Definition; + + -- precond : FILE + -- postcond: next token + -- + -- [ LRM93 3.4 ] + -- file_type_definition ::= FILE OF type_mark + function Parse_File_Type_Definition return Iir_File_Type_Definition + is + Res : Iir_File_Type_Definition; + Type_Mark: Iir; + begin + Res := Create_Iir (Iir_Kind_File_Type_Definition); + Set_Location (Res); + -- Accept token 'file'. + Scan_Expect (Tok_Of); + Scan; + Type_Mark := Parse_Type_Mark (Check_Paren => True); + if Get_Kind (Type_Mark) not in Iir_Kinds_Denoting_Name then + Error_Msg_Parse ("type mark expected"); + else + Set_File_Type_Mark (Res, Type_Mark); + end if; + return Res; + end Parse_File_Type_Definition; + + -- precond : PROTECTED + -- postcond: ';' + -- + -- [ 3.5 ] + -- protected_type_definition ::= protected_type_declaration + -- | protected_type_body + -- + -- [ 3.5.1 ] + -- protected_type_declaration ::= PROTECTED + -- protected_type_declarative_part + -- END PROTECTED [ simple_name ] + -- + -- protected_type_declarative_part ::= + -- { protected_type_declarative_item } + -- + -- protected_type_declarative_item ::= + -- subprogram_declaration + -- | attribute_specification + -- | use_clause + -- + -- [ 3.5.2 ] + -- protected_type_body ::= PROTECTED BODY + -- protected_type_body_declarative_part + -- END PROTECTED BODY [ simple_name ] + -- + -- protected_type_body_declarative_part ::= + -- { protected_type_body_declarative_item } + -- + -- protected_type_body_declarative_item ::= + -- subprogram_declaration + -- | subprogram_body + -- | type_declaration + -- | subtype_declaration + -- | constant_declaration + -- | variable_declaration + -- | file_declaration + -- | alias_declaration + -- | attribute_declaration + -- | attribute_specification + -- | use_clause + -- | group_template_declaration + -- | group_declaration + function Parse_Protected_Type_Definition + (Ident : Name_Id; Loc : Location_Type) return Iir + is + Res : Iir; + Decl : Iir; + begin + Scan; + if Current_Token = Tok_Body then + Res := Create_Iir (Iir_Kind_Protected_Type_Body); + Scan; + Decl := Res; + else + Decl := Create_Iir (Iir_Kind_Type_Declaration); + Res := Create_Iir (Iir_Kind_Protected_Type_Declaration); + Set_Location (Res, Loc); + Set_Type_Definition (Decl, Res); + end if; + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + + Parse_Declarative_Part (Res); + + Expect (Tok_End); + Scan_Expect (Tok_Protected); + Set_End_Has_Reserved_Id (Res, True); + if Get_Kind (Res) = Iir_Kind_Protected_Type_Body then + Scan_Expect (Tok_Body); + end if; + Scan; + Check_End_Name (Ident, Res); + return Decl; + end Parse_Protected_Type_Definition; + + -- precond : TYPE + -- postcond: a token + -- + -- [ LRM93 4.1 ] + -- type_definition ::= scalar_type_definition + -- | composite_type_definition + -- | access_type_definition + -- | file_type_definition + -- | protected_type_definition + -- + -- [ LRM93 3.1 ] + -- scalar_type_definition ::= enumeration_type_definition + -- | integer_type_definition + -- | floating_type_definition + -- | physical_type_definition + -- + -- [ LRM93 3.2 ] + -- composite_type_definition ::= array_type_definition + -- | record_type_definition + -- + -- [ LRM93 3.1.2 ] + -- integer_type_definition ::= range_constraint + -- + -- [ LRM93 3.1.4 ] + -- floating_type_definition ::= range_constraint + function Parse_Type_Declaration (Parent : Iir) return Iir + is + Def : Iir; + Loc : Location_Type; + Ident : Name_Id; + Decl : Iir; + begin + -- The current token must be type. + pragma Assert (Current_Token = Tok_Type); + + -- Get the identifier + Scan_Expect (Tok_Identifier, + "an identifier is expected after 'type' keyword"); + Loc := Get_Token_Location; + Ident := Current_Identifier; + + -- Skip identifier + Scan; + + if Current_Token = Tok_Semi_Colon then + -- If there is a ';', this is an imcomplete type declaration. + Invalidate_Current_Token; + Decl := Create_Iir (Iir_Kind_Type_Declaration); + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + return Decl; + end if; + + if Current_Token /= Tok_Is then + Error_Msg_Parse ("'is' expected here"); + -- Act as if IS token was forgotten. + else + -- Eat IS token. + Scan; + end if; + + case Current_Token is + when Tok_Left_Paren => + -- This is an enumeration. + Def := Parse_Enumeration_Type_Definition; + Decl := Null_Iir; + + when Tok_Range => + -- This is a range definition. + Decl := Create_Iir (Iir_Kind_Anonymous_Type_Declaration); + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + + -- Skip 'range' + Scan; + + Def := Parse_Range_Constraint; + Set_Type_Definition (Decl, Def); + + if Current_Token = Tok_Units then + -- A physical type definition. + declare + Unit_Def : Iir; + begin + Unit_Def := Parse_Physical_Type_Definition (Parent); + if Current_Token = Tok_Identifier then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("simple_name not allowed here in vhdl87"); + end if; + Check_End_Name (Get_Identifier (Decl), Unit_Def); + end if; + if Def /= Null_Iir then + Set_Type (Def, Unit_Def); + end if; + end; + end if; + + when Tok_Array => + Def := Parse_Array_Definition; + Decl := Null_Iir; + + when Tok_Record => + Decl := Create_Iir (Iir_Kind_Type_Declaration); + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + Def := Parse_Record_Type_Definition; + Set_Type_Definition (Decl, Def); + if Current_Token = Tok_Identifier then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("simple_name not allowed here in vhdl87"); + end if; + Check_End_Name (Get_Identifier (Decl), Def); + end if; + + when Tok_Access => + Def := Parse_Access_Type_Definition; + Decl := Null_Iir; + + when Tok_File => + Def := Parse_File_Type_Definition; + Decl := Null_Iir; + + when Tok_Identifier => + if Current_Identifier = Name_Protected then + Error_Msg_Parse ("protected type not allowed in vhdl87/93"); + Decl := Parse_Protected_Type_Definition (Ident, Loc); + else + Error_Msg_Parse ("type '" & Name_Table.Image (Ident) & + "' cannot be defined from another type"); + Error_Msg_Parse ("(you should declare a subtype)"); + Decl := Create_Iir (Iir_Kind_Type_Declaration); + Eat_Tokens_Until_Semi_Colon; + end if; + + when Tok_Protected => + if Flags.Vhdl_Std < Vhdl_00 then + Error_Msg_Parse ("protected type not allowed in vhdl87/93"); + end if; + Decl := Parse_Protected_Type_Definition (Ident, Loc); + + when others => + Error_Msg_Parse + ("type definition starting with a keyword such as RANGE, ARRAY"); + Error_Msg_Parse + (" FILE, RECORD or '(' is expected here"); + Eat_Tokens_Until_Semi_Colon; + Decl := Create_Iir (Iir_Kind_Type_Declaration); + end case; + + if Decl = Null_Iir then + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_File_Type_Definition => + Decl := Create_Iir (Iir_Kind_Type_Declaration); + when Iir_Kind_Array_Subtype_Definition => + Decl := Create_Iir (Iir_Kind_Anonymous_Type_Declaration); + when others => + Error_Kind ("parse_type_declaration", Def); + end case; + Set_Type_Definition (Decl, Def); + end if; + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + + -- ';' is expected after end of type declaration + Expect (Tok_Semi_Colon); + Invalidate_Current_Token; + return Decl; + end Parse_Type_Declaration; + + -- precond: '(' or identifier + -- postcond: next token + -- + -- [ 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 + Ind : Iir; + Def : Iir; + Loc : Location_Type; + 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; + + -- Eat '(' + Scan; + + Ind := Parse_Resolution_Indication; + if Current_Token = Tok_Identifier + or else Current_Token = Tok_Left_Paren + then + declare + Id : Name_Id; + El : Iir; + First, Last : Iir; + begin + -- This was in fact a record_resolution. + if Get_Kind (Ind) = Iir_Kind_Simple_Name then + Id := Get_Identifier (Ind); + else + Error_Msg_Parse ("element name expected", Ind); + Id := Null_Identifier; + end if; + Free_Iir (Ind); + + Def := Create_Iir (Iir_Kind_Record_Resolution); + Set_Location (Def, Loc); + Sub_Chain_Init (First, Last); + loop + El := Create_Iir (Iir_Kind_Record_Element_Resolution); + Set_Location (El, Loc); + Set_Identifier (El, Id); + Set_Resolution_Indication (El, Parse_Resolution_Indication); + Sub_Chain_Append (First, Last, El); + exit when Current_Token = Tok_Right_Paren; + + -- Eat ',' + Expect (Tok_Comma); + Scan; + + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("record element identifier expected"); + exit; + end if; + Id := Current_Identifier; + Loc := Get_Token_Location; + + -- Eat identifier + Scan; + end loop; + Set_Record_Element_Resolution_Chain (Def, First); + end; + else + Def := Create_Iir (Iir_Kind_Array_Element_Resolution); + Set_Location (Def, Loc); + Set_Resolution_Indication (Def, Ind); + end if; + + -- Eat ')' + Expect (Tok_Right_Paren); + 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; + Index_List : Iir_List; + begin + -- Index_constraint. + Def := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Location (Def); + + -- Eat '('. + Scan; + + if Current_Token = Tok_Open then + -- Eat 'open'. + Scan; + else + Index_List := Create_Iir_List; + Set_Index_Constraint_List (Def, Index_List); + -- index_constraint ::= (discrete_range {, discrete_range} ) + loop + El := Parse_Discrete_Range; + Append_Element (Index_List, El); + + exit when Current_Token = Tok_Right_Paren; + + -- Eat ',' + Expect (Tok_Comma); + Scan; + end loop; + end if; + + -- Eat ')' + Expect (Tok_Right_Paren); + Scan; + + if Current_Token = Tok_Left_Paren then + Set_Element_Subtype (Def, Parse_Element_Constraint); + end if; + return Def; + end Parse_Element_Constraint; + + -- precond : tolerance + -- postcond: next token + -- + -- [ LRM93 4.2 ] + -- tolerance_aspect ::= TOLERANCE string_expression + function Parse_Tolerance_Aspect_Opt return Iir is + begin + if AMS_Vhdl + and then Current_Token = Tok_Tolerance + then + Scan; + return Parse_Expression; + else + return Null_Iir; + end if; + end Parse_Tolerance_Aspect_Opt; + + -- precond : identifier or '(' + -- postcond: next token + -- + -- [ LRM93 4.2 ] + -- subtype_indication ::= + -- [ RESOLUTION_FUNCTION_name ] type_mark [ constraint ] + -- + -- constraint ::= range_constraint | index_constraint + -- + -- [ LRM08 6.3 ] + -- subtype_indication ::= + -- [ resolution_indication ] type_mark [ constraint ] + -- + -- constraint ::= + -- range_constraint | array_constraint | record_constraint + -- + -- NAME is the type_mark when already parsed (in range expression or + -- allocator by type). + function Parse_Subtype_Indication (Name : Iir := Null_Iir) + return Iir + is + Type_Mark : Iir; + Def: Iir; + Resolution_Indication: Iir; + Tolerance : Iir; + begin + -- FIXME: location. + Resolution_Indication := Null_Iir; + Def := Null_Iir; + + if Name /= Null_Iir then + -- The type_mark was already parsed. + Type_Mark := Name; + Check_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_Indication := Parse_Resolution_Indication; + end if; + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("type mark expected in a subtype indication"); + raise Parse_Error; + end if; + Type_Mark := Parse_Type_Mark (Check_Paren => False); + end if; + + if Current_Token = Tok_Identifier then + if Resolution_Indication /= Null_Iir then + Error_Msg_Parse ("resolution function already indicated"); + end if; + Resolution_Indication := Type_Mark; + Type_Mark := Parse_Type_Mark (Check_Paren => False); + end if; + + case Current_Token is + when Tok_Left_Paren => + -- element_constraint. + Def := Parse_Element_Constraint; + Set_Subtype_Type_Mark (Def, Type_Mark); + Set_Resolution_Indication (Def, Resolution_Indication); + Set_Tolerance (Def, Parse_Tolerance_Aspect_Opt); + + when Tok_Range => + -- range_constraint. + -- Skip 'range' + Scan; + + Def := Parse_Range_Constraint_Of_Subtype_Indication + (Type_Mark, Resolution_Indication); + + when others => + Tolerance := Parse_Tolerance_Aspect_Opt; + if Resolution_Indication /= Null_Iir + or else Tolerance /= Null_Iir + then + -- A subtype needs to be created. + Def := Create_Iir (Iir_Kind_Subtype_Definition); + Location_Copy (Def, Type_Mark); + Set_Subtype_Type_Mark (Def, Type_Mark); + Set_Resolution_Indication (Def, Resolution_Indication); + Set_Tolerance (Def, Tolerance); + else + -- This is just an alias. + Def := Type_Mark; + end if; + end case; + return Def; + end Parse_Subtype_Indication; + + -- precond : SUBTYPE + -- postcond: ';' + -- + -- [ §4.2 ] + -- subtype_declaration ::= SUBTYPE identifier IS subtype_indication ; + function Parse_Subtype_Declaration return Iir_Subtype_Declaration + is + Decl: Iir_Subtype_Declaration; + Def: Iir; + begin + Decl := Create_Iir (Iir_Kind_Subtype_Declaration); + + Scan_Expect (Tok_Identifier); + Set_Identifier (Decl, Current_Identifier); + Set_Location (Decl); + + Scan_Expect (Tok_Is); + Scan; + Def := Parse_Subtype_Indication; + Set_Subtype_Indication (Decl, Def); + + Expect (Tok_Semi_Colon); + return Decl; + end Parse_Subtype_Declaration; + + -- precond : NATURE + -- postcond: a token + -- + -- [ §4.8 ] + -- nature_definition ::= scalar_nature_definition + -- | composite_nature_definition + -- + -- [ §3.5.1 ] + -- scalar_nature_definition ::= type_mark ACROSS + -- type_mark THROUGH + -- identifier REFERENCE + -- + -- [ §3.5.2 ] + -- composite_nature_definition ::= array_nature_definition + -- | record_nature_definition + function Parse_Nature_Declaration return Iir + is + Def : Iir; + Ref : Iir; + Loc : Location_Type; + Ident : Name_Id; + Decl : Iir; + begin + -- The current token must be type. + if Current_Token /= Tok_Nature then + raise Program_Error; + end if; + + -- Get the identifier + Scan_Expect (Tok_Identifier, + "an identifier is expected after 'nature'"); + Loc := Get_Token_Location; + Ident := Current_Identifier; + + Scan; + + if Current_Token /= Tok_Is then + Error_Msg_Parse ("'is' expected here"); + -- Act as if IS token was forgotten. + else + -- Eat IS token. + Scan; + end if; + + case Current_Token is + when Tok_Array => + -- TODO + Error_Msg_Parse ("array nature definition not supported"); + Def := Null_Iir; + Eat_Tokens_Until_Semi_Colon; + when Tok_Record => + -- TODO + Error_Msg_Parse ("record nature definition not supported"); + Def := Null_Iir; + Eat_Tokens_Until_Semi_Colon; + when Tok_Identifier => + Def := Create_Iir (Iir_Kind_Scalar_Nature_Definition); + Set_Location (Def, Loc); + Set_Across_Type (Def, Parse_Type_Mark); + if Current_Token = Tok_Across then + Scan; + else + Expect (Tok_Across, "'across' expected after type mark"); + end if; + Set_Through_Type (Def, Parse_Type_Mark); + if Current_Token = Tok_Through then + Scan; + else + Expect (Tok_Across, "'through' expected after type mark"); + end if; + if Current_Token = Tok_Identifier then + Ref := Create_Iir (Iir_Kind_Terminal_Declaration); + Set_Identifier (Ref, Current_Identifier); + Set_Location (Ref); + Set_Reference (Def, Ref); + Scan; + if Current_Token = Tok_Reference then + Scan; + else + Expect (Tok_Reference, "'reference' expected"); + Eat_Tokens_Until_Semi_Colon; + end if; + else + Error_Msg_Parse ("reference identifier expected"); + Eat_Tokens_Until_Semi_Colon; + end if; + when others => + Error_Msg_Parse ("nature definition expected here"); + Eat_Tokens_Until_Semi_Colon; + end case; + + Decl := Create_Iir (Iir_Kind_Nature_Declaration); + Set_Nature (Decl, Def); + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + + -- ';' is expected after end of type declaration + Expect (Tok_Semi_Colon); + Invalidate_Current_Token; + return Decl; + end Parse_Nature_Declaration; + + -- precond : identifier + -- postcond: next token + -- + -- LRM 4.8 Nature declaration + -- + -- subnature_indication ::= + -- nature_mark [ index_constraint ] + -- [ TOLERANCE string_expression ACROSS string_expression THROUGH ] + -- + -- nature_mark ::= + -- nature_name | subnature_name + function Parse_Subnature_Indication return Iir is + Nature_Mark : Iir; + begin + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("nature mark expected in a subnature indication"); + raise Parse_Error; + end if; + Nature_Mark := Parse_Name (Allow_Indexes => False); + + if Current_Token = Tok_Left_Paren then + -- TODO + Error_Msg_Parse + ("index constraint not supported for subnature indication"); + raise Parse_Error; + end if; + + if Current_Token = Tok_Tolerance then + Error_Msg_Parse + ("tolerance not supported for subnature indication"); + raise Parse_Error; + end if; + return Nature_Mark; + end Parse_Subnature_Indication; + + -- precond : TERMINAL + -- postcond: ; + -- + -- [ 4.3.1.5 Terminal declarations ] + -- terminal_declaration ::= + -- TERMINAL identifier_list : subnature_indication + function Parse_Terminal_Declaration (Parent : Iir) return Iir + is + -- First and last element of the chain to be returned. + First, Last : Iir; + Terminal : Iir; + Subnature : Iir; + begin + Sub_Chain_Init (First, Last); + + loop + -- 'terminal' or "," was just scanned. + Terminal := Create_Iir (Iir_Kind_Terminal_Declaration); + Scan_Expect (Tok_Identifier); + Set_Identifier (Terminal, Current_Identifier); + Set_Location (Terminal); + Set_Parent (Terminal, Parent); + + Sub_Chain_Append (First, Last, Terminal); + + Scan; + exit when Current_Token = Tok_Colon; + if Current_Token /= Tok_Comma then + Error_Msg_Parse + ("',' or ':' is expected after " + & "identifier in terminal declaration"); + raise Expect_Error; + end if; + end loop; + + -- The colon was parsed. + Scan; + Subnature := Parse_Subnature_Indication; + + Terminal := First; + while Terminal /= Null_Iir loop + -- Type definitions are factorized. This is OK, but not done by + -- sem. + if Terminal = First then + Set_Nature (Terminal, Subnature); + else + Set_Nature (Terminal, Null_Iir); + end if; + Terminal := Get_Chain (Terminal); + end loop; + Expect (Tok_Semi_Colon); + return First; + end Parse_Terminal_Declaration; + + -- precond : QUANTITY + -- postcond: ; + -- + -- [ 4.3.1.6 Quantity declarations ] + -- quantity_declaration ::= + -- free_quantity_declaration + -- | branch_quantity_declaration + -- | source_quantity_declaration + -- + -- free_quantity_declaration ::= + -- QUANTITY identifier_list : subtype_indication [ := expression ] ; + -- + -- branch_quantity_declaration ::= + -- QUANTITY [ across_aspect ] [ through_aspect ] terminal_aspect ; + -- + -- source_quantity_declaration ::= + -- QUANTITY identifier_list : subtype_indication source_aspect ; + -- + -- across_aspect ::= + -- identifier_list [ tolerance_aspect ] [ := expression ] ACROSS + -- + -- through_aspect ::= + -- identifier_list [ tolerance_aspect ] [ := expression ] THROUGH + -- + -- terminal_aspect ::= + -- plus_terminal_name [ TO minus_terminal_name ] + function Parse_Quantity_Declaration (Parent : Iir) return Iir + is + -- First and last element of the chain to be returned. + First, Last : Iir; + Object : Iir; + New_Object : Iir; + Tolerance : Iir; + Default_Value : Iir; + Kind : Iir_Kind; + Plus_Terminal : Iir; + begin + Sub_Chain_Init (First, Last); + + -- Eat 'quantity' + Scan; + + loop + -- Quantity or "," was just scanned. We assume a free quantity + -- declaration and will change to branch or source quantity if + -- necessary. + Object := Create_Iir (Iir_Kind_Free_Quantity_Declaration); + Expect (Tok_Identifier); + Set_Identifier (Object, Current_Identifier); + Set_Location (Object); + Set_Parent (Object, Parent); + + Sub_Chain_Append (First, Last, Object); + + -- Eat identifier + Scan; + exit when Current_Token /= Tok_Comma; + + -- Eat ',' + Scan; + end loop; + + case Current_Token is + when Tok_Colon => + -- Either a free quantity (or a source quantity) + -- TODO + raise Program_Error; + when Tok_Tolerance + | Tok_Assign + | Tok_Across + | Tok_Through => + -- A branch quantity + + -- Parse tolerance aspect + Tolerance := Parse_Tolerance_Aspect_Opt; + + -- Parse default value + if Current_Token = Tok_Assign then + Scan; + Default_Value := Parse_Expression; + else + Default_Value := Null_Iir; + end if; + + case Current_Token is + when Tok_Across => + Kind := Iir_Kind_Across_Quantity_Declaration; + when Tok_Through => + Kind := Iir_Kind_Through_Quantity_Declaration; + when others => + Error_Msg_Parse ("'across' or 'through' expected here"); + Eat_Tokens_Until_Semi_Colon; + raise Expect_Error; + end case; + + -- Eat across/through + Scan; + + -- Change declarations + Object := First; + Sub_Chain_Init (First, Last); + while Object /= Null_Iir loop + New_Object := Create_Iir (Kind); + Location_Copy (New_Object, Object); + Set_Identifier (New_Object, Get_Identifier (Object)); + Set_Parent (New_Object, Parent); + Set_Tolerance (New_Object, Tolerance); + Set_Default_Value (New_Object, Default_Value); + + Sub_Chain_Append (First, Last, New_Object); + + if Object /= First then + Set_Plus_Terminal (New_Object, Null_Iir); + end if; + New_Object := Get_Chain (Object); + Free_Iir (Object); + Object := New_Object; + end loop; + + -- Parse terminal (or first identifier of through declarations) + Plus_Terminal := Parse_Name; + + case Current_Token is + when Tok_Comma + | Tok_Tolerance + | Tok_Assign + | Tok_Through + | Tok_Across => + -- Through quantity declaration. Convert the Plus_Terminal + -- to a declaration. + Object := Create_Iir (Iir_Kind_Through_Quantity_Declaration); + New_Object := Object; + Location_Copy (Object, Plus_Terminal); + if Get_Kind (Plus_Terminal) /= Iir_Kind_Simple_Name then + Error_Msg_Parse + ("identifier for quantity declaration expected"); + else + Set_Identifier (Object, Get_Identifier (Plus_Terminal)); + end if; + Set_Plus_Terminal (Object, Null_Iir); + Free_Iir (Plus_Terminal); + + loop + Set_Parent (Object, Parent); + Sub_Chain_Append (First, Last, Object); + exit when Current_Token /= Tok_Comma; + Scan; + + Object := Create_Iir + (Iir_Kind_Through_Quantity_Declaration); + Set_Location (Object); + if Current_Token /= Tok_Identifier then + Error_Msg_Parse + ("identifier for quantity declaration expected"); + else + Set_Identifier (Object, Current_Identifier); + Scan; + end if; + Set_Plus_Terminal (Object, Null_Iir); + + end loop; + + -- Parse tolerance aspect + Set_Tolerance (Object, Parse_Tolerance_Aspect_Opt); + + -- Parse default value + if Current_Token = Tok_Assign then + Scan; + Set_Default_Value (Object, Parse_Expression); + end if; + + -- Scan 'through' + if Current_Token = Tok_Through then + Scan; + elsif Current_Token = Tok_Across then + Error_Msg_Parse ("across quantity declaration must appear" + & " before though declaration"); + Scan; + else + Error_Msg_Parse ("'through' expected"); + end if; + + -- Parse plus terminal + Plus_Terminal := Parse_Name; + when others => + null; + end case; + + Set_Plus_Terminal (First, Plus_Terminal); + + -- Parse minus terminal (if present) + if Current_Token = Tok_To then + Scan; + Set_Minus_Terminal (First, Parse_Name); + end if; + when others => + Error_Msg_Parse ("missign type or across/throught aspect " + & "in quantity declaration"); + Eat_Tokens_Until_Semi_Colon; + raise Expect_Error; + end case; + Expect (Tok_Semi_Colon); + return First; + end Parse_Quantity_Declaration; + + -- precond : token (CONSTANT, SIGNAL, VARIABLE, FILE) + -- postcond: ; + -- + -- KIND can be iir_kind_constant_declaration, iir_kind_file_declaration + -- or iir_kind_variable_declaration + -- + -- [ LRM93 4.3.1 ] + -- object_declaration ::= constant_declaration + -- | signal_declaration + -- | variable_declaration + -- | file_declaration + -- + -- [ LRM93 4.3.1.1 ] + -- constant_declaration ::= + -- CONSTANT identifier_list : subtype_indication [ := expression ] + -- + -- [ LRM87 4.3.2 ] + -- file_declaration ::= + -- FILE identifier : subtype_indication IS [ mode ] file_logical_name + -- + -- [ LRM93 4.3.1.4 ] + -- file_declaration ::= + -- FILE identifier_list : subtype_indication [ file_open_information ] + -- + -- [ LRM93 4.3.1.4 ] + -- file_open_information ::= + -- [ OPEN FILE_OPEN_KIND_expression ] IS file_logical_name + -- + -- [ LRM93 4.3.1.4 ] + -- file_logical_name ::= STRING_expression + -- + -- [ LRM93 4.3.1.3 ] + -- variable_declaration ::= + -- [ SHARED ] VARIABLE identifier_list : subtype_indication + -- [ := expression ] + -- + -- [ LRM93 4.3.1.2 ] + -- signal_declaration ::= + -- SIGNAL identifier_list : subtype_information [ signal_kind ] + -- [ := expression ] + -- + -- [ LRM93 4.3.1.2 ] + -- signal_kind ::= REGISTER | BUS + -- + -- FIXME: file_open_information. + function Parse_Object_Declaration (Parent : Iir) return Iir + is + -- First and last element of the chain to be returned. + First, Last : Iir; + Object: Iir; + Object_Type: Iir; + Default_Value : Iir; + Mode: Iir_Mode; + Signal_Kind : Iir_Signal_Kind; + Open_Kind : Iir; + Logical_Name : Iir; + Kind: Iir_Kind; + Shared : Boolean; + Has_Mode : Boolean; + begin + Sub_Chain_Init (First, Last); + + -- object keyword was just scanned. + case Current_Token is + when Tok_Signal => + Kind := Iir_Kind_Signal_Declaration; + when Tok_Constant => + Kind := Iir_Kind_Constant_Declaration; + when Tok_File => + Kind := Iir_Kind_File_Declaration; + when Tok_Variable => + Kind := Iir_Kind_Variable_Declaration; + Shared := False; + when Tok_Shared => + Kind := Iir_Kind_Variable_Declaration; + Shared := True; + Scan_Expect (Tok_Variable); + when others => + raise Internal_Error; + end case; + + loop + -- object or "," was just scanned. + Object := Create_Iir (Kind); + if Kind = Iir_Kind_Variable_Declaration then + Set_Shared_Flag (Object, Shared); + end if; + Scan_Expect (Tok_Identifier); + Set_Identifier (Object, Current_Identifier); + Set_Location (Object); + Set_Parent (Object, Parent); + + Sub_Chain_Append (First, Last, Object); + + Scan; + exit when Current_Token = Tok_Colon; + if Current_Token /= Tok_Comma then + case Current_Token is + when Tok_Assign => + Error_Msg_Parse ("missign type in " & Disp_Name (Kind)); + exit; + when others => + Error_Msg_Parse + ("',' or ':' is expected after identifier in " + & Disp_Name (Kind)); + raise Expect_Error; + end case; + end if; + Set_Has_Identifier_List (Object, True); + end loop; + + -- Eat ':' + Scan; + + Object_Type := Parse_Subtype_Indication; + + if Kind = Iir_Kind_Signal_Declaration then + Signal_Kind := Parse_Signal_Kind; + end if; + + if Current_Token = Tok_Assign then + if Kind = Iir_Kind_File_Declaration then + Error_Msg_Parse + ("default expression not allowed for a file declaration"); + end if; + + -- Skip ':='. + Scan; + + Default_Value := Parse_Expression; + else + Default_Value := Null_Iir; + end if; + + if Kind = Iir_Kind_File_Declaration then + if Current_Token = Tok_Open then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("'open' and open kind expression not allowed in vhdl 87"); + end if; + Scan; + Open_Kind := Parse_Expression; + else + Open_Kind := Null_Iir; + end if; + + -- LRM 4.3.1.4 + -- The default mode is IN, if no mode is specified. + Mode := Iir_In_Mode; + + Logical_Name := Null_Iir; + Has_Mode := False; + if Current_Token = Tok_Is then + -- Skip 'is'. + Scan; + + case Current_Token is + when Tok_In | Tok_Out | Tok_Inout => + if Flags.Vhdl_Std >= Vhdl_93 then + Error_Msg_Parse ("mode allowed only in vhdl 87"); + end if; + Mode := Parse_Mode (Iir_In_Mode); + if Mode = Iir_Inout_Mode then + Error_Msg_Parse ("inout mode not allowed for file"); + end if; + Has_Mode := True; + when others => + null; + end case; + Logical_Name := Parse_Expression; + elsif Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("file name expected (vhdl 87)"); + end if; + end if; + + Set_Subtype_Indication (First, Object_Type); + if Kind /= Iir_Kind_File_Declaration then + Set_Default_Value (First, Default_Value); + end if; + + Object := First; + while Object /= Null_Iir loop + case Kind is + when Iir_Kind_File_Declaration => + Set_Mode (Object, Mode); + Set_File_Open_Kind (Object, Open_Kind); + Set_File_Logical_Name (Object, Logical_Name); + Set_Has_Mode (Object, Has_Mode); + when Iir_Kind_Signal_Declaration => + Set_Signal_Kind (Object, Signal_Kind); + when others => + null; + end case; + Set_Is_Ref (Object, Object /= First); + Object := Get_Chain (Object); + end loop; + + -- ';' is not eaten. + Expect (Tok_Semi_Colon); + + return First; + end Parse_Object_Declaration; + + -- precond : COMPONENT + -- postcond: ';' + -- + -- [ §4.5 ] + -- component_declaration ::= + -- COMPONENT identifier [ IS ] + -- [ LOCAL_generic_clause ] + -- [ LOCAL_port_clause ] + -- END COMPONENT [ COMPONENT_simple_name ] ; + function Parse_Component_Declaration + return Iir_Component_Declaration + is + Component: Iir_Component_Declaration; + begin + Component := Create_Iir (Iir_Kind_Component_Declaration); + Scan_Expect (Tok_Identifier, + "an identifier is expected after 'component'"); + Set_Identifier (Component, Current_Identifier); + Set_Location (Component); + Scan; + if Current_Token = Tok_Is then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("""is"" keyword is not allowed here by vhdl 87"); + end if; + Set_Has_Is (Component, True); + Scan; + end if; + Parse_Generic_Port_Clauses (Component); + Check_End_Name (Tok_Component, Component); + return Component; + end Parse_Component_Declaration; + + -- precond : '[' + -- postcond: next token after ']' + -- + -- [ 2.3.2 ] + -- signature ::= [ [ type_mark { , type_mark } ] [ RETURN type_mark ] ] + function Parse_Signature return Iir_Signature + is + Res : Iir_Signature; + List : Iir_List; + begin + Expect (Tok_Left_Bracket); + Res := Create_Iir (Iir_Kind_Signature); + Set_Location (Res); + + -- Skip '[' + Scan; + + -- List of type_marks. + if Current_Token = Tok_Identifier then + List := Create_Iir_List; + Set_Type_Marks_List (Res, List); + loop + Append_Element (List, Parse_Type_Mark (Check_Paren => True)); + exit when Current_Token /= Tok_Comma; + Scan; + end loop; + end if; + + if Current_Token = Tok_Return then + -- Skip 'return' + Scan; + + Set_Return_Type_Mark (Res, Parse_Name); + end if; + + -- Skip ']' + Expect (Tok_Right_Bracket); + Scan; + + return Res; + end Parse_Signature; + + -- precond : ALIAS + -- postcond: a token + -- + -- [ LRM93 4.3.3 ] + -- alias_declaration ::= + -- ALIAS alias_designator [ : subtype_indication ] + -- IS name [ signature ] ; + -- + -- [ LRM93 4.3.3 ] + -- alias_designator ::= identifier | character_literal | operator_symbol + -- + -- FIXME: signature is not part of the node. + function Parse_Alias_Declaration return Iir + is + Res: Iir; + Ident : Name_Id; + begin + -- Eat 'alias'. + Scan; + + Res := Create_Iir (Iir_Kind_Object_Alias_Declaration); + Set_Location (Res); + + case Current_Token is + when Tok_Identifier => + Ident := Current_Identifier; + when Tok_Character => + Ident := Current_Identifier; + when Tok_String => + Ident := Scan_To_Operator_Name (Get_Token_Location); + -- FIXME: vhdl87 + -- FIXME: operator symbol. + when others => + Error_Msg_Parse ("alias designator expected"); + end case; + + -- Eat identifier. + Set_Identifier (Res, Ident); + Scan; + + if Current_Token = Tok_Colon then + Scan; + Set_Subtype_Indication (Res, Parse_Subtype_Indication); + end if; + + -- FIXME: nice message if token is ':=' ? + Expect (Tok_Is); + Scan; + Set_Name (Res, Parse_Name); + + return Res; + end Parse_Alias_Declaration; + + -- precond : FOR + -- postcond: ';' + -- + -- [ §5.2 ] + -- configuration_specification ::= + -- FOR component_specification binding_indication ; + function Parse_Configuration_Specification + return Iir_Configuration_Specification + is + Res : Iir_Configuration_Specification; + begin + Res := Create_Iir (Iir_Kind_Configuration_Specification); + Set_Location (Res); + Expect (Tok_For); + Scan; + Parse_Component_Specification (Res); + Set_Binding_Indication (Res, Parse_Binding_Indication); + Expect (Tok_Semi_Colon); + return Res; + end Parse_Configuration_Specification; + + -- precond : next token + -- postcond: next token + -- + -- [ § 5.2 ] + -- entity_class := ENTITY | ARCHITECTURE | CONFIGURATION | PROCEDURE + -- | FUNCTION | PACKAGE | TYPE | SUBTYPE | CONSTANT + -- | SIGNAL | VARIABLE | COMPONENT | LABEL | LITERAL + -- | UNITS | GROUP | FILE + function Parse_Entity_Class return Token_Type + is + Res : Token_Type; + begin + case Current_Token is + when Tok_Entity + | Tok_Architecture + | Tok_Configuration + | Tok_Procedure + | Tok_Function + | Tok_Package + | Tok_Type + | Tok_Subtype + | Tok_Constant + | Tok_Signal + | Tok_Variable + | Tok_Component + | Tok_Label => + null; + when Tok_Literal + | Tok_Units + | Tok_Group + | Tok_File => + null; + when others => + Error_Msg_Parse + (''' & Tokens.Image (Current_Token) & "' is not a entity class"); + end case; + Res := Current_Token; + Scan; + return Res; + end Parse_Entity_Class; + + function Parse_Entity_Class_Entry return Iir_Entity_Class + is + Res : Iir_Entity_Class; + begin + Res := Create_Iir (Iir_Kind_Entity_Class); + Set_Location (Res); + Set_Entity_Class (Res, Parse_Entity_Class); + return Res; + end Parse_Entity_Class_Entry; + + -- precond : next token + -- postcond: next token + -- + -- [ §5.1 ] + -- entity_designator ::= entity_tag [ signature ] + -- + -- entity_tag ::= simple_name | character_literal | operator_symbol + function Parse_Entity_Designator return Iir + is + Res : Iir; + Name : Iir; + begin + case Current_Token is + when Tok_Identifier => + Res := Create_Iir (Iir_Kind_Simple_Name); + Set_Location (Res); + Set_Identifier (Res, Current_Identifier); + when Tok_Character => + Res := Create_Iir (Iir_Kind_Character_Literal); + Set_Location (Res); + Set_Identifier (Res, Current_Identifier); + when Tok_String => + Res := Create_Iir (Iir_Kind_Operator_Symbol); + Set_Location (Res); + Set_Identifier (Res, Scan_To_Operator_Name (Get_Token_Location)); + when others => + Error_Msg_Parse ("identifier, character or string expected"); + raise Expect_Error; + end case; + Scan; + if Current_Token = Tok_Left_Bracket then + Name := Res; + Res := Parse_Signature; + Set_Signature_Prefix (Res, Name); + end if; + return Res; + end Parse_Entity_Designator; + + -- precond : next token + -- postcond: IS + -- + -- [ §5.1 ] + -- entity_name_list ::= entity_designator { , entity_designator } + -- | OTHERS + -- | ALL + procedure Parse_Entity_Name_List + (Attribute : Iir_Attribute_Specification) + is + List : Iir_List; + El : Iir; + begin + case Current_Token is + when Tok_All => + List := Iir_List_All; + Scan; + when Tok_Others => + List := Iir_List_Others; + Scan; + when others => + List := Create_Iir_List; + loop + El := Parse_Entity_Designator; + Append_Element (List, El); + exit when Current_Token /= Tok_Comma; + Scan; + end loop; + end case; + Set_Entity_Name_List (Attribute, List); + if Current_Token = Tok_Colon then + Scan; + Set_Entity_Class (Attribute, Parse_Entity_Class); + else + Error_Msg_Parse + ("missing ':' and entity kind in attribute specification"); + end if; + end Parse_Entity_Name_List; + + -- precond : ATTRIBUTE + -- postcond: ';' + -- + -- [ 4.4 ] + -- attribute_declaration ::= ATTRIBUTE identifier : type_mark ; + -- + -- [ 5.1 ] + -- attribute_specification ::= + -- ATTRIBUTE attribute_designator OF entity_specification + -- IS expression ; + function Parse_Attribute return Iir + is + Loc : Location_Type; + Ident : Name_Id; + begin + Expect (Tok_Attribute); + Scan_Expect (Tok_Identifier); + Loc := Get_Token_Location; + Ident := Current_Identifier; + Scan; + case Current_Token is + when Tok_Colon => + declare + Res : Iir_Attribute_Declaration; + begin + Res := Create_Iir (Iir_Kind_Attribute_Declaration); + Set_Location (Res, Loc); + Set_Identifier (Res, Ident); + Scan; + Set_Type_Mark (Res, Parse_Type_Mark (Check_Paren => True)); + Expect (Tok_Semi_Colon); + return Res; + end; + when Tok_Of => + declare + Res : Iir_Attribute_Specification; + Designator : Iir_Simple_Name; + begin + Res := Create_Iir (Iir_Kind_Attribute_Specification); + Set_Location (Res, Loc); + Designator := Create_Iir (Iir_Kind_Simple_Name); + Set_Location (Designator, Loc); + Set_Identifier (Designator, Ident); + Set_Attribute_Designator (Res, Designator); + Scan; + Parse_Entity_Name_List (Res); + Expect (Tok_Is); + Scan; + Set_Expression (Res, Parse_Expression); + Expect (Tok_Semi_Colon); + return Res; + end; + when others => + Error_Msg_Parse ("':' or 'of' expected after identifier"); + return Null_Iir; + end case; + end Parse_Attribute; + + -- precond : GROUP + -- postcond: ';' + -- + -- [ §4.6 ] + -- group_template_declaration ::= + -- GROUP identifier IS (entity_class_entry_list) ; + -- + -- entity_class_entry_list ::= entity_class_entry { , entity_class_entry } + -- + -- entity_class_entry ::= entity_class [ <> ] + function Parse_Group return Iir is + Loc : Location_Type; + Ident : Name_Id; + begin + Expect (Tok_Group); + Scan_Expect (Tok_Identifier); + Loc := Get_Token_Location; + Ident := Current_Identifier; + Scan; + case Current_Token is + when Tok_Is => + declare + use Iir_Chains.Entity_Class_Entry_Chain_Handling; + Res : Iir_Group_Template_Declaration; + El : Iir_Entity_Class; + Last : Iir_Entity_Class; + begin + Res := Create_Iir (Iir_Kind_Group_Template_Declaration); + Set_Location (Res, Loc); + Set_Identifier (Res, Ident); + Scan_Expect (Tok_Left_Paren); + Scan; + Build_Init (Last); + loop + Append (Last, Res, Parse_Entity_Class_Entry); + if Current_Token = Tok_Box then + El := Create_Iir (Iir_Kind_Entity_Class); + Set_Location (El); + Set_Entity_Class (El, Tok_Box); + Append (Last, Res, El); + Scan; + if Current_Token = Tok_Comma then + Error_Msg_Parse + ("'<>' is allowed only for the last " + & "entity class entry"); + end if; + end if; + exit when Current_Token = Tok_Right_Paren; + Expect (Tok_Comma); + Scan; + end loop; + Scan_Expect (Tok_Semi_Colon); + return Res; + end; + when Tok_Colon => + declare + Res : Iir_Group_Declaration; + List : Iir_Group_Constituent_List; + begin + Res := Create_Iir (Iir_Kind_Group_Declaration); + Set_Location (Res, Loc); + Set_Identifier (Res, Ident); + Scan; + Set_Group_Template_Name + (Res, Parse_Name (Allow_Indexes => False)); + Expect (Tok_Left_Paren); + Scan; + List := Create_Iir_List; + Set_Group_Constituent_List (Res, List); + loop + Append_Element (List, Parse_Name (Allow_Indexes => False)); + exit when Current_Token = Tok_Right_Paren; + Expect (Tok_Comma); + Scan; + end loop; + Scan_Expect (Tok_Semi_Colon); + return Res; + end; + when others => + Error_Msg_Parse ("':' or 'is' expected here"); + return Null_Iir; + end case; + end Parse_Group; + + -- precond : next token + -- postcond: ':' + -- + -- [ §5.4 ] + -- signal_list ::= signal_name { , signal_name } + -- | OTHERS + -- | ALL + function Parse_Signal_List return Iir_List + is + Res : Iir_List; + begin + case Current_Token is + when Tok_Others => + Scan; + return Iir_List_Others; + when Tok_All => + Scan; + return Iir_List_All; + when others => + Res := Create_Iir_List; + loop + Append_Element (Res, Parse_Name); + exit when Current_Token = Tok_Colon; + Expect (Tok_Comma); + Scan; + end loop; + return Res; + end case; + end Parse_Signal_List; + + -- precond : DISCONNECT + -- postcond: ';' + -- + -- [ §5.4 ] + -- disconnection_specification ::= + -- DISCONNECT guarded_signal_specification AFTER time_expression ; + function Parse_Disconnection_Specification + return Iir_Disconnection_Specification + is + Res : Iir_Disconnection_Specification; + begin + Res := Create_Iir (Iir_Kind_Disconnection_Specification); + Set_Location (Res); + + -- Skip 'disconnect' + Expect (Tok_Disconnect); + Scan; + + Set_Signal_List (Res, Parse_Signal_List); + + -- Skip ':' + Expect (Tok_Colon); + Scan; + + Set_Type_Mark (Res, Parse_Type_Mark (Check_Paren => True)); + + -- Skip 'after' + Expect (Tok_After); + Scan; + + Set_Expression (Res, Parse_Expression); + return Res; + end Parse_Disconnection_Specification; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 4 ] + -- declaration ::= type_declaration + -- | subtype_declaration + -- | object_declaration + -- | interface_declaration + -- | alias_declaration + -- | attribute_declaration + -- | component_declaration + -- | group_template_declaration + -- | group_declaration + -- | entity_declaration + -- | configuration_declaration + -- | subprogram_declaration + -- | package_declaration + procedure Parse_Declarative_Part (Parent : Iir) + is + use Declaration_Chain_Handling; + Last_Decl : Iir; + Decl : Iir; + begin + Build_Init (Last_Decl); + loop + Decl := Null_Iir; + case Current_Token is + when Tok_Invalid => + raise Internal_Error; + when Tok_Type => + Decl := Parse_Type_Declaration (Parent); + + -- LRM 2.5 Package declarations + -- If a package declarative item is a type declaration that is + -- a full type declaration whose type definition is a + -- protected_type definition, then that protected type + -- definition must not be a protected type body. + if Decl /= Null_Iir + and then Get_Kind (Decl) = Iir_Kind_Protected_Type_Body + then + case Get_Kind (Parent) is + when Iir_Kind_Package_Declaration => + Error_Msg_Parse ("protected type body not allowed " + & "in package declaration", Decl); + when others => + null; + end case; + end if; + when Tok_Subtype => + Decl := Parse_Subtype_Declaration; + when Tok_Nature => + Decl := Parse_Nature_Declaration; + when Tok_Terminal => + Decl := Parse_Terminal_Declaration (Parent); + when Tok_Quantity => + Decl := Parse_Quantity_Declaration (Parent); + when Tok_Signal => + case Get_Kind (Parent) is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Error_Msg_Parse + ("signal declaration not allowed in subprogram body"); + when Iir_Kinds_Process_Statement => + Error_Msg_Parse + ("signal declaration not allowed in process"); + when others => + null; + end case; + Decl := Parse_Object_Declaration (Parent); + when Tok_Constant => + Decl := Parse_Object_Declaration (Parent); + when Tok_Variable => + -- FIXME: remove this message (already checked during sem). + case Get_Kind (Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + -- FIXME: replace HERE with the kind of declaration + -- ie: "not allowed in a package" rather than "here". + Error_Msg_Parse ("variable declaration not allowed here"); + when others => + null; + end case; + Decl := Parse_Object_Declaration (Parent); + when Tok_Shared => + if Flags.Vhdl_Std <= Vhdl_87 then + Error_Msg_Parse ("shared variable not allowed in vhdl 87"); + end if; + Decl := Parse_Object_Declaration (Parent); + when Tok_File => + Decl := Parse_Object_Declaration (Parent); + when Tok_Function + | Tok_Procedure + | Tok_Pure + | Tok_Impure => + Decl := Parse_Subprogram_Declaration (Parent); + when Tok_Alias => + Decl := Parse_Alias_Declaration; + when Tok_Component => + case Get_Kind (Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body + | Iir_Kinds_Process_Statement => + Error_Msg_Parse + ("component declaration are not allowed here"); + when others => + null; + end case; + Decl := Parse_Component_Declaration; + when Tok_For => + case Get_Kind (Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kinds_Process_Statement => + Error_Msg_Parse + ("configuration specification not allowed here"); + when others => + null; + end case; + Decl := Parse_Configuration_Specification; + when Tok_Attribute => + Decl := Parse_Attribute; + when Tok_Disconnect => + case Get_Kind (Parent) is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kinds_Process_Statement => + Error_Msg_Parse + ("disconnect specification not allowed here"); + when others => + null; + end case; + Decl := Parse_Disconnection_Specification; + when Tok_Use => + Decl := Parse_Use_Clause; + when Tok_Group => + Decl := Parse_Group; + + when Tok_Identifier => + Error_Msg_Parse + ("object class keyword such as 'variable' is expected"); + Eat_Tokens_Until_Semi_Colon; + when Tok_Semi_Colon => + Error_Msg_Parse ("';' (semi colon) not allowed alone"); + Scan; + when others => + exit; + end case; + if Decl /= Null_Iir then + Append_Subchain (Last_Decl, Parent, Decl); + end if; + + if Current_Token = Tok_Semi_Colon or Current_Token = Tok_Invalid then + Scan; + end if; + end loop; + end Parse_Declarative_Part; + + -- precond : ENTITY + -- postcond: ';' + -- + -- [ §1.1 ] + -- entity_declaration ::= + -- ENTITY identifier IS + -- entiy_header + -- entity_declarative_part + -- [ BEGIN + -- entity_statement_part ] + -- END [ ENTITY ] [ ENTITY_simple_name ] + -- + -- [ §1.1.1 ] + -- entity_header ::= + -- [ FORMAL_generic_clause ] + -- [ FORMAL_port_clause ] + procedure Parse_Entity_Declaration (Unit : Iir_Design_Unit) + is + Res: Iir_Entity_Declaration; + begin + Expect (Tok_Entity); + Res := Create_Iir (Iir_Kind_Entity_Declaration); + + -- Get identifier. + Scan_Expect (Tok_Identifier, + "an identifier is expected after ""entity"""); + Set_Identifier (Res, Current_Identifier); + Set_Location (Res); + + Scan_Expect (Tok_Is, "missing ""is"" after identifier"); + Scan; + + Parse_Generic_Port_Clauses (Res); + + Parse_Declarative_Part (Res); + + if Current_Token = Tok_Begin then + Set_Has_Begin (Res, True); + Scan; + Parse_Concurrent_Statements (Res); + end if; + + -- end keyword is expected to finish an entity declaration + Expect (Tok_End); + Set_End_Location (Unit); + + Scan; + if Current_Token = Tok_Entity then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("""entity"" keyword not allowed here by vhdl 87"); + end if; + Set_End_Has_Reserved_Id (Res, True); + Scan; + end if; + Check_End_Name (Res); + Expect (Tok_Semi_Colon); + Invalidate_Current_Token; + Set_Library_Unit (Unit, Res); + end Parse_Entity_Declaration; + + -- [ LRM93 7.3.2 ] + -- choice ::= simple_expression + -- | discrete_range + -- | ELEMENT_simple_name + -- | OTHERS + function Parse_A_Choice (Expr: Iir) return Iir + is + A_Choice: Iir; + Expr1: Iir; + begin + if Expr = Null_Iir then + if Current_Token = Tok_Others then + A_Choice := Create_Iir (Iir_Kind_Choice_By_Others); + Set_Location (A_Choice); + + -- Skip 'others' + Scan; + + return A_Choice; + else + Expr1 := Parse_Expression; + + if Expr1 = Null_Iir then + -- Handle parse error now. + -- FIXME: skip until '=>'. + A_Choice := Create_Iir (Iir_Kind_Choice_By_Expression); + Set_Location (A_Choice); + return A_Choice; + end if; + end if; + else + Expr1 := Expr; + end if; + if Is_Range_Attribute_Name (Expr1) then + A_Choice := Create_Iir (Iir_Kind_Choice_By_Range); + Location_Copy (A_Choice, Expr1); + Set_Choice_Range (A_Choice, Expr1); + return A_Choice; + elsif Current_Token = Tok_To or else Current_Token = Tok_Downto then + A_Choice := Create_Iir (Iir_Kind_Choice_By_Range); + Location_Copy (A_Choice, Expr1); + Set_Choice_Range (A_Choice, Parse_Range_Right (Expr1)); + return A_Choice; + else + A_Choice := Create_Iir (Iir_Kind_Choice_By_Expression); + Location_Copy (A_Choice, Expr1); + Set_Choice_Expression (A_Choice, Expr1); + return A_Choice; + end if; + end Parse_A_Choice; + + -- [ LRM93 7.3.2 ] + -- choices ::= choice { | choice } + -- + -- Leave tok_double_arrow as current token. + function Parse_Choices (Expr: Iir) return Iir + is + First, Last : Iir; + A_Choice: Iir; + Expr1 : Iir; + begin + Sub_Chain_Init (First, Last); + Expr1 := Expr; + loop + A_Choice := Parse_A_Choice (Expr1); + if First /= Null_Iir then + Set_Same_Alternative_Flag (A_Choice, True); + if Get_Kind (A_Choice) = Iir_Kind_Choice_By_Others then + Error_Msg_Parse ("'others' choice must be alone"); + end if; + end if; + Sub_Chain_Append (First, Last, A_Choice); + if Current_Token /= Tok_Bar then + return First; + end if; + Scan; + Expr1 := Null_Iir; + end loop; + end Parse_Choices; + + -- precond : '(' + -- postcond: next token + -- + -- This can be an expression or an aggregate. + -- + -- [ LRM93 7.3.2 ] + -- aggregate ::= ( element_association { , element_association } ) + -- + -- [ LRM93 7.3.2 ] + -- element_association ::= [ choices => ] expression + function Parse_Aggregate return Iir + is + use Iir_Chains.Association_Choices_Chain_Handling; + Expr: Iir; + Res: Iir; + Last : Iir; + Assoc: Iir; + Loc : Location_Type; + begin + Loc := Get_Token_Location; + + -- Skip '(' + Scan; + + if Current_Token /= Tok_Others then + Expr := Parse_Expression; + case Current_Token is + when Tok_Comma + | Tok_Double_Arrow + | Tok_Bar => + -- This is really an aggregate + null; + when Tok_Right_Paren => + -- This was just a braced expression. + + -- Eat ')'. + Scan; + + if Get_Kind (Expr) = Iir_Kind_Aggregate then + -- Parenthesis around aggregate is useless and change the + -- context for array aggregate. + Warning_Msg_Sem + ("suspicious parenthesis around aggregate", Expr); + elsif not Flag_Parse_Parenthesis then + return Expr; + end if; + + -- Create a node for the parenthesis. + Res := Create_Iir (Iir_Kind_Parenthesis_Expression); + Set_Location (Res, Loc); + Set_Expression (Res, Expr); + return Res; + + when Tok_Semi_Colon => + -- Surely a missing parenthesis. + -- FIXME: in case of multiple missing parenthesises, several + -- messages will be displayed + Error_Msg_Parse ("missing ')' for opening parenthesis at " + & Get_Location_Str (Loc, Filename => False)); + return Expr; + when others => + -- Surely a parse error... + null; + end case; + else + Expr := Null_Iir; + end if; + Res := Create_Iir (Iir_Kind_Aggregate); + Set_Location (Res, Loc); + Build_Init (Last); + loop + if Current_Token = Tok_Others then + Assoc := Parse_A_Choice (Null_Iir); + Expect (Tok_Double_Arrow); + Scan; + Expr := Parse_Expression; + else + if Expr = Null_Iir then + Expr := Parse_Expression; + end if; + if Expr = Null_Iir then + return Null_Iir; + end if; + case Current_Token is + when Tok_Comma + | Tok_Right_Paren => + Assoc := Create_Iir (Iir_Kind_Choice_By_None); + Location_Copy (Assoc, Expr); + when others => + Assoc := Parse_Choices (Expr); + Expect (Tok_Double_Arrow); + Scan; + Expr := Parse_Expression; + end case; + end if; + Set_Associated_Expr (Assoc, Expr); + Append_Subchain (Last, Res, Assoc); + exit when Current_Token = Tok_Right_Paren; + Expect (Tok_Comma); + Scan; + Expr := Null_Iir; + end loop; + Scan; + return Res; + end Parse_Aggregate; + + -- precond : NEW + -- postcond: next token + -- + -- [LRM93 7.3.6] + -- allocator ::= NEW subtype_indication + -- | NEW qualified_expression + function Parse_Allocator return Iir + is + Loc: Location_Type; + Res : Iir; + Expr: Iir; + begin + Loc := Get_Token_Location; + + -- Accept 'new'. + Scan; + Expr := Parse_Name (Allow_Indexes => False); + if Get_Kind (Expr) /= Iir_Kind_Qualified_Expression then + -- This is a subtype_indication. + Res := Create_Iir (Iir_Kind_Allocator_By_Subtype); + Expr := Parse_Subtype_Indication (Expr); + Set_Subtype_Indication (Res, Expr); + else + Res := Create_Iir (Iir_Kind_Allocator_By_Expression); + Set_Expression (Res, Expr); + end if; + + Set_Location (Res, Loc); + return Res; + end Parse_Allocator; + + -- precond : next token + -- postcond: next token + -- + -- [ §7.1 ] + -- primary ::= name + -- | literal + -- | aggregate + -- | function_call + -- | qualified_expression + -- | type_conversion + -- | allocator + -- | ( expression ) + -- + -- [ §7.3.1 ] + -- literal ::= numeric_literal + -- | enumeration_literal + -- | string_literal + -- | bit_string_literal + -- | NULL + -- + -- [ §7.3.1 ] + -- numeric_literal ::= abstract_literal + -- | physical_literal + -- + -- [ §13.4 ] + -- abstract_literal ::= decimal_literal | based_literal + -- + -- [ §3.1.3 ] + -- physical_literal ::= [ abstract_literal ] UNIT_name + function Parse_Primary return Iir_Expression + is + Res: Iir_Expression; + Int: Iir_Int64; + Fp: Iir_Fp64; + Loc: Location_Type; + begin + case Current_Token is + when Tok_Integer => + Int := Current_Iir_Int64; + Loc := Get_Token_Location; + + -- Skip integer + Scan; + + if Current_Token = Tok_Identifier then + -- physical literal + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Set_Unit_Name (Res, Parse_Name (Allow_Indexes => False)); + else + -- integer literal + Res := Create_Iir (Iir_Kind_Integer_Literal); + end if; + Set_Location (Res, Loc); + Set_Value (Res, Int); + return Res; + + when Tok_Real => + Fp := Current_Iir_Fp64; + Loc := Get_Token_Location; + + -- Skip real + Scan; + + if Current_Token = Tok_Identifier then + -- physical literal + Res := Create_Iir (Iir_Kind_Physical_Fp_Literal); + Set_Unit_Name (Res, Parse_Name (Allow_Indexes => False)); + else + -- real literal + Res := Create_Iir (Iir_Kind_Floating_Point_Literal); + end if; + Set_Location (Res, Loc); + Set_Fp_Value (Res, Fp); + return Res; + + when Tok_Identifier => + return Parse_Name (Allow_Indexes => True); + when Tok_Character => + Res := Current_Text; + Scan; + if Current_Token = Tok_Tick then + Error_Msg_Parse + ("prefix of an attribute can't be a character literal"); + -- skip tick. + Scan; + -- skip attribute designator + Scan; + end if; + return Res; + when Tok_Left_Paren => + return Parse_Aggregate; + when Tok_String => + return Parse_Name; + when Tok_Null => + Res := Create_Iir (Iir_Kind_Null_Literal); + Set_Location (Res); + Scan; + return Res; + when Tok_New => + return Parse_Allocator; + when Tok_Bit_String => + Res := Create_Iir (Iir_Kind_Bit_String_Literal); + Set_Location (Res); + Set_String_Id (Res, Current_String_Id); + Set_String_Length (Res, Current_String_Length); + case Current_Iir_Int64 is + when 1 => + Set_Bit_String_Base (Res, Base_2); + when 3 => + Set_Bit_String_Base (Res, Base_8); + when 4 => + Set_Bit_String_Base (Res, Base_16); + when others => + raise Internal_Error; + end case; + Scan; + return Res; + when Tok_Minus + | Tok_Plus => + Error_Msg_Parse + ("'-' and '+' are not allowed in primary, use parenthesis"); + return Parse_Simple_Expression; + when Tok_Comma + | Tok_Semi_Colon + | Tok_Eof + | Tok_End => + -- Token not to be skipped + Unexpected ("primary"); + return Null_Iir; + when others => + Unexpected ("primary"); + Scan; + return Null_Iir; + end case; + end Parse_Primary; + + -- precond : next token + -- postcond: next token + -- + -- [ §7.1 ] + -- factor ::= primary [ ** primary ] + -- | ABS primary + -- | NOT primary + -- | logical_operator primary [ VHDL08 9.1 ] + function Build_Unary_Factor (Primary : Iir; Op : Iir_Kind) return Iir is + Res : Iir; + begin + if Primary /= Null_Iir then + return Primary; + end if; + Res := Create_Iir (Op); + Set_Location (Res); + Scan; + Set_Operand (Res, Parse_Primary); + return Res; + end Build_Unary_Factor; + + function Build_Unary_Factor_08 (Primary : Iir; Op : Iir_Kind) return Iir is + begin + if Primary /= Null_Iir then + return Primary; + end if; + if Flags.Vhdl_Std < Vhdl_08 then + Error_Msg_Parse ("missing left operand of logical expression"); + -- Skip operator + Scan; + return Parse_Primary; + else + return Build_Unary_Factor (Primary, Op); + end if; + end Build_Unary_Factor_08; + + function Parse_Factor (Primary : Iir := Null_Iir) return Iir_Expression is + Res, Left: Iir_Expression; + begin + case Current_Token is + when Tok_Abs => + return Build_Unary_Factor (Primary, Iir_Kind_Absolute_Operator); + when Tok_Not => + return Build_Unary_Factor (Primary, Iir_Kind_Not_Operator); + + when Tok_And => + return Build_Unary_Factor_08 + (Primary, Iir_Kind_Reduction_And_Operator); + when Tok_Or => + return Build_Unary_Factor_08 + (Primary, Iir_Kind_Reduction_Or_Operator); + when Tok_Nand => + return Build_Unary_Factor_08 + (Primary, Iir_Kind_Reduction_Nand_Operator); + when Tok_Nor => + return Build_Unary_Factor_08 + (Primary, Iir_Kind_Reduction_Nor_Operator); + when Tok_Xor => + return Build_Unary_Factor_08 + (Primary, Iir_Kind_Reduction_Xor_Operator); + when Tok_Xnor => + return Build_Unary_Factor_08 + (Primary, Iir_Kind_Reduction_Xnor_Operator); + + when others => + if Primary /= Null_Iir then + Left := Primary; + else + Left := Parse_Primary; + end if; + if Current_Token = Tok_Double_Star then + Res := Create_Iir (Iir_Kind_Exponentiation_Operator); + Set_Location (Res); + Scan; + Set_Left (Res, Left); + Set_Right (Res, Parse_Primary); + return Res; + else + return Left; + end if; + end case; + end Parse_Factor; + + -- precond : next token + -- postcond: next token + -- + -- [ §7.1 ] + -- term ::= factor { multiplying_operator factor } + -- + -- [ §7.2 ] + -- multiplying_operator ::= * | / | MOD | REM + function Parse_Term (Primary : Iir) return Iir_Expression is + Res, Tmp: Iir_Expression; + begin + Res := Parse_Factor (Primary); + while Current_Token in Token_Multiplying_Operator_Type loop + case Current_Token is + when Tok_Star => + Tmp := Create_Iir (Iir_Kind_Multiplication_Operator); + when Tok_Slash => + Tmp := Create_Iir (Iir_Kind_Division_Operator); + when Tok_Mod => + Tmp := Create_Iir (Iir_Kind_Modulus_Operator); + when Tok_Rem => + Tmp := Create_Iir (Iir_Kind_Remainder_Operator); + when others => + raise Program_Error; + end case; + Set_Location (Tmp); + Set_Left (Tmp, Res); + Scan; + Set_Right (Tmp, Parse_Factor); + Res := Tmp; + end loop; + return Res; + end Parse_Term; + + -- precond : next token + -- postcond: next token + -- + -- [ §7.1 ] + -- simple_expression ::= [ sign ] term { adding_operator term } + -- + -- [ §7.2 ] + -- sign ::= + | - + -- + -- [ §7.2 ] + -- adding_operator ::= + | - | & + function Parse_Simple_Expression (Primary : Iir := Null_Iir) + return Iir_Expression + is + Res, Tmp: Iir_Expression; + begin + if Current_Token in Token_Sign_Type + and then Primary = Null_Iir + then + case Current_Token is + when Tok_Plus => + Res := Create_Iir (Iir_Kind_Identity_Operator); + when Tok_Minus => + Res := Create_Iir (Iir_Kind_Negation_Operator); + when others => + raise Program_Error; + end case; + Set_Location (Res); + Scan; + Set_Operand (Res, Parse_Term (Null_Iir)); + else + Res := Parse_Term (Primary); + end if; + while Current_Token in Token_Adding_Operator_Type loop + case Current_Token is + when Tok_Plus => + Tmp := Create_Iir (Iir_Kind_Addition_Operator); + when Tok_Minus => + Tmp := Create_Iir (Iir_Kind_Substraction_Operator); + when Tok_Ampersand => + Tmp := Create_Iir (Iir_Kind_Concatenation_Operator); + when others => + raise Program_Error; + end case; + Set_Location (Tmp); + Scan; + Set_Left (Tmp, Res); + Set_Right (Tmp, Parse_Term (Null_Iir)); + Res := Tmp; + end loop; + return Res; + end Parse_Simple_Expression; + + -- precond : next token + -- postcond: next token + -- + -- [ §7.1 ] + -- shift_expression ::= + -- simple_expression [ shift_operator simple_expression ] + -- + -- [ §7.2 ] + -- shift_operator ::= SLL | SRL | SLA | SRA | ROL | ROR + function Parse_Shift_Expression return Iir_Expression is + Res, Tmp: Iir_Expression; + begin + Tmp := Parse_Simple_Expression; + if Current_Token not in Token_Shift_Operator_Type then + return Tmp; + elsif Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("shift operators not allowed in vhdl 87"); + end if; + case Current_Token is + when Tok_Sll => + Res := Create_Iir (Iir_Kind_Sll_Operator); + when Tok_Sla => + Res := Create_Iir (Iir_Kind_Sla_Operator); + when Tok_Srl => + Res := Create_Iir (Iir_Kind_Srl_Operator); + when Tok_Sra => + Res := Create_Iir (Iir_Kind_Sra_Operator); + when Tok_Rol => + Res := Create_Iir (Iir_Kind_Rol_Operator); + when Tok_Ror => + Res := Create_Iir (Iir_Kind_Ror_Operator); + when others => + raise Program_Error; + end case; + Set_Location (Res); + Scan; + Set_Left (Res, Tmp); + Set_Right (Res, Parse_Simple_Expression); + return Res; + end Parse_Shift_Expression; + + -- precond : next token (relational_operator) + -- postcond: next token + -- + -- [ §7.1 ] + -- relational_operator shift_expression + function Parse_Relation_Rhs (Left : Iir) return Iir + is + Res, Tmp: Iir_Expression; + begin + Tmp := Left; + + -- This loop is just to handle errors such as a = b = c. + loop + case Current_Token is + when Tok_Equal => + Res := Create_Iir (Iir_Kind_Equality_Operator); + when Tok_Not_Equal => + Res := Create_Iir (Iir_Kind_Inequality_Operator); + when Tok_Less => + Res := Create_Iir (Iir_Kind_Less_Than_Operator); + when Tok_Less_Equal => + Res := Create_Iir (Iir_Kind_Less_Than_Or_Equal_Operator); + when Tok_Greater => + Res := Create_Iir (Iir_Kind_Greater_Than_Operator); + when Tok_Greater_Equal => + Res := Create_Iir (Iir_Kind_Greater_Than_Or_Equal_Operator); + when Tok_Match_Equal => + Res := Create_Iir (Iir_Kind_Match_Equality_Operator); + when Tok_Match_Not_Equal => + Res := Create_Iir (Iir_Kind_Match_Inequality_Operator); + when Tok_Match_Less => + Res := Create_Iir (Iir_Kind_Match_Less_Than_Operator); + when Tok_Match_Less_Equal => + Res := Create_Iir (Iir_Kind_Match_Less_Than_Or_Equal_Operator); + when Tok_Match_Greater => + Res := Create_Iir (Iir_Kind_Match_Greater_Than_Operator); + when Tok_Match_Greater_Equal => + Res := Create_Iir + (Iir_Kind_Match_Greater_Than_Or_Equal_Operator); + when others => + raise Program_Error; + end case; + Set_Location (Res); + Scan; + Set_Left (Res, Tmp); + Set_Right (Res, Parse_Shift_Expression); + exit when Current_Token not in Token_Relational_Operator_Type; + Error_Msg_Parse + ("use parenthesis for consecutive relational expressions"); + Tmp := Res; + end loop; + return Res; + end Parse_Relation_Rhs; + + -- precond : next token + -- postcond: next token + -- + -- [ §7.1 ] + -- relation ::= shift_expression [ relational_operator shift_expression ] + -- + -- [ §7.2 ] + -- relational_operator ::= = | /= | < | <= | > | >= + -- | ?= | ?/= | ?< | ?<= | ?> | ?>= + function Parse_Relation return Iir + is + Tmp: Iir; + begin + Tmp := Parse_Shift_Expression; + if Current_Token not in Token_Relational_Operator_Type then + return Tmp; + end if; + + return Parse_Relation_Rhs (Tmp); + end Parse_Relation; + + -- precond : next token + -- postcond: next token + -- + -- [ §7.1 ] + -- expression ::= relation { AND relation } + -- | relation { OR relation } + -- | relation { XOR relation } + -- | relation [ NAND relation } + -- | relation [ NOR relation } + -- | relation { XNOR relation } + function Parse_Expression_Rhs (Left : Iir) return Iir + is + Res, Tmp: Iir; + + -- OP_TOKEN contains the operator combinaison. + Op_Token: Token_Type; + begin + Tmp := Left; + Op_Token := Tok_Invalid; + loop + case Current_Token is + when Tok_And => + Res := Create_Iir (Iir_Kind_And_Operator); + when Tok_Or => + Res := Create_Iir (Iir_Kind_Or_Operator); + when Tok_Xor => + Res := Create_Iir (Iir_Kind_Xor_Operator); + when Tok_Nand => + Res := Create_Iir (Iir_Kind_Nand_Operator); + when Tok_Nor => + Res := Create_Iir (Iir_Kind_Nor_Operator); + when Tok_Xnor => + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'xnor' keyword not allowed in vhdl 87"); + end if; + Res := Create_Iir (Iir_Kind_Xnor_Operator); + when others => + return Tmp; + end case; + + if Op_Token = Tok_Invalid then + Op_Token := Current_Token; + else + -- Check after the case, since current_token may not be an + -- operator... + -- TODO: avoid repetition of this message ? + if Op_Token = Tok_Nand or Op_Token = Tok_Nor then + Error_Msg_Parse ("sequence of 'nor' or 'nand' not allowed"); + Error_Msg_Parse ("('nor' and 'nand' are not associative)"); + end if; + if Op_Token /= Current_Token then + -- Expression is a sequence of relations, with the same + -- operator. + Error_Msg_Parse ("only one type of logical operators may be " + & "used to combine relation"); + end if; + end if; + + Set_Location (Res); + Scan; + + -- Catch errors for Ada programmers. + if Current_Token = Tok_Then or Current_Token = Tok_Else then + Error_Msg_Parse ("""or else"" and ""and then"" sequences " + & "are not allowed in vhdl"); + Error_Msg_Parse ("""and"" and ""or"" are short-circuit " + & "operators for BIT and BOOLEAN types"); + Scan; + end if; + + Set_Left (Res, Tmp); + Set_Right (Res, Parse_Relation); + Tmp := Res; + end loop; + end Parse_Expression_Rhs; + + -- precond : next token + -- postcond: next token + -- + -- LRM08 9.1 General + -- expression ::= condition_operator primary + -- | logical_expression + function Parse_Expression return Iir_Expression + is + Res : Iir; + begin + if Current_Token = Tok_Condition then + Res := Create_Iir (Iir_Kind_Condition_Operator); + Set_Location (Res); + + -- Skip '??' + Scan; + + Set_Operand (Res, Parse_Primary); + else + Res := Parse_Expression_Rhs (Parse_Relation); + end if; + + return Res; + end Parse_Expression; + + -- precond : next token + -- postcond: next token. + -- + -- [ §8.4 ] + -- waveform ::= waveform_element { , waveform_element } + -- | UNAFFECTED + -- + -- [ §8.4.1 ] + -- waveform_element ::= VALUE_expression [ AFTER TIME_expression ] + -- | NULL [ AFTER TIME_expression ] + function Parse_Waveform return Iir_Waveform_Element + is + Res: Iir_Waveform_Element; + We, Last_We : Iir_Waveform_Element; + begin + if Current_Token = Tok_Unaffected then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'unaffected' is not allowed in vhdl87"); + end if; + Scan; + return Null_Iir; + else + Sub_Chain_Init (Res, Last_We); + loop + We := Create_Iir (Iir_Kind_Waveform_Element); + Sub_Chain_Append (Res, Last_We, We); + Set_Location (We); + -- Note: NULL is handled as a null_literal. + Set_We_Value (We, Parse_Expression); + if Current_Token = Tok_After then + Scan; + Set_Time (We, Parse_Expression); + end if; + exit when Current_Token /= Tok_Comma; + Scan; + end loop; + return Res; + end if; + end Parse_Waveform; + + -- precond : next token + -- postcond: next token + -- + -- [ §8.4 ] + -- delay_mechanism ::= TRANSPORT + -- | [ REJECT TIME_expression ] INERTIAL + procedure Parse_Delay_Mechanism (Assign: Iir) is + begin + if Current_Token = Tok_Transport then + Set_Delay_Mechanism (Assign, Iir_Transport_Delay); + Scan; + else + Set_Delay_Mechanism (Assign, Iir_Inertial_Delay); + if Current_Token = Tok_Reject then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("'reject' delay mechanism not allowed in vhdl 87"); + end if; + Scan; + Set_Reject_Time_Expression (Assign, Parse_Expression); + Expect (Tok_Inertial); + Scan; + elsif Current_Token = Tok_Inertial then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("'inertial' keyword not allowed in vhdl 87"); + end if; + Scan; + end if; + end if; + end Parse_Delay_Mechanism; + + -- precond : next token + -- postcond: next token + -- + -- [ §9.5 ] + -- options ::= [ GUARDED ] [ delay_mechanism ] + procedure Parse_Options (Stmt : Iir) is + begin + if Current_Token = Tok_Guarded then + Set_Guard (Stmt, Stmt); + Scan; + end if; + Parse_Delay_Mechanism (Stmt); + end Parse_Options; + + -- precond : next tkoen + -- postcond: ';' + -- + -- [ §9.5.1 ] + -- conditional_signal_assignment ::= + -- target <= options conditional_waveforms ; + -- + -- [ §9.5.1 ] + -- conditional_waveforms ::= + -- { waveform WHEN condition ELSE } + -- waveform [ WHEN condition ] + function Parse_Conditional_Signal_Assignment (Target: Iir) return Iir + is + use Iir_Chains.Conditional_Waveform_Chain_Handling; + Res: Iir; + Cond_Wf, Last_Cond_Wf : Iir_Conditional_Waveform; + begin + Res := Create_Iir (Iir_Kind_Concurrent_Conditional_Signal_Assignment); + Set_Target (Res, Target); + Location_Copy (Res, Get_Target (Res)); + + case Current_Token is + when Tok_Less_Equal => + null; + when Tok_Assign => + Error_Msg_Parse ("':=' not allowed in concurrent statement, " + & "replaced by '<='"); + when others => + Expect (Tok_Less_Equal); + end case; + Scan; + + Parse_Options (Res); + + Build_Init (Last_Cond_Wf); + loop + Cond_Wf := Create_Iir (Iir_Kind_Conditional_Waveform); + Append (Last_Cond_Wf, Res, Cond_Wf); + Set_Location (Cond_Wf); + Set_Waveform_Chain (Cond_Wf, Parse_Waveform); + exit when Current_Token /= Tok_When; + Scan; + Set_Condition (Cond_Wf, Parse_Expression); + if Current_Token /= Tok_Else then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("else missing in vhdl 87"); + end if; + exit; + end if; + Scan; + end loop; + Expect (Tok_Semi_Colon); + return Res; + end Parse_Conditional_Signal_Assignment; + + -- precond : WITH + -- postcond: ';' + -- + -- [ §9.5.2 ] + -- selected_signal_assignment ::= + -- WITH expresion SELECT + -- target <= options selected_waveforms ; + -- + -- [ §9.5.2 ] + -- selected_waveforms ::= + -- { waveform WHEN choices , } + -- waveform WHEN choices + function Parse_Selected_Signal_Assignment return Iir + is + use Iir_Chains.Selected_Waveform_Chain_Handling; + Res: Iir; + Assoc: Iir; + Wf_Chain : Iir_Waveform_Element; + Target : Iir; + Last : Iir; + begin + Scan; -- accept 'with' token. + Res := Create_Iir (Iir_Kind_Concurrent_Selected_Signal_Assignment); + Set_Location (Res); + Set_Expression (Res, Parse_Expression); + + Expect (Tok_Select, "'select' expected after expression"); + Scan; + if Current_Token = Tok_Left_Paren then + Target := Parse_Aggregate; + else + Target := Parse_Name (Allow_Indexes => True); + end if; + Set_Target (Res, Target); + Expect (Tok_Less_Equal); + Scan; + + Parse_Options (Res); + + Build_Init (Last); + loop + Wf_Chain := Parse_Waveform; + Expect (Tok_When, "'when' expected after waveform"); + Scan; + Assoc := Parse_Choices (Null_Iir); + Set_Associated_Chain (Assoc, Wf_Chain); + Append_Subchain (Last, Res, Assoc); + exit when Current_Token = Tok_Semi_Colon; + Expect (Tok_Comma, "',' (comma) expected after choice"); + Scan; + end loop; + return Res; + end Parse_Selected_Signal_Assignment; + + -- precond : next token + -- postcond: next token. + -- + -- [ §8.1 ] + -- sensitivity_list ::= SIGNAL_name { , SIGNAL_name } + procedure Parse_Sensitivity_List (List: Iir_Designator_List) + is + El : Iir; + begin + loop + El := Parse_Name (Allow_Indexes => True); + case Get_Kind (El) is + when Iir_Kind_Simple_Name + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Attribute_Name + | Iir_Kind_Selected_By_All_Name + | Iir_Kind_Indexed_Name => + null; + when others => + Error_Msg_Parse + ("only names are allowed in a sensitivity list"); + end case; + Append_Element (List, El); + exit when Current_Token /= Tok_Comma; + Scan; + end loop; + end Parse_Sensitivity_List; + + -- precond : ASSERT + -- postcond: next token + -- Note: this fill an sequential or a concurrent statement. + -- + -- [ §8.2 ] + -- assertion ::= ASSERT condition + -- [ REPORT expression ] [ SEVERITY expression ] + procedure Parse_Assertion (Stmt: Iir) is + begin + Set_Location (Stmt); + Scan; + Set_Assertion_Condition (Stmt, Parse_Expression); + if Current_Token = Tok_Report then + Scan; + Set_Report_Expression (Stmt, Parse_Expression); + end if; + if Current_Token = Tok_Severity then + Scan; + Set_Severity_Expression (Stmt, Parse_Expression); + if Current_Token = Tok_Report then + -- Nice message in case of inversion. + Error_Msg_Parse + ("report expression must precede severity expression"); + Scan; + Set_Report_Expression (Stmt, Parse_Expression); + end if; + end if; + end Parse_Assertion; + + -- precond : REPORT + -- postcond: next token + -- + -- [ 8.3 ] + -- report_statement ::= REPORT expression [ SEVERITY expression ] + function Parse_Report_Statement return Iir_Report_Statement + is + Res : Iir_Report_Statement; + begin + Res := Create_Iir (Iir_Kind_Report_Statement); + Set_Location (Res); + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("report statement not allowed in vhdl87"); + end if; + Scan; + Set_Report_Expression (Res, Parse_Expression); + if Current_Token = Tok_Severity then + Scan; + Set_Severity_Expression (Res, Parse_Expression); + end if; + return Res; + end Parse_Report_Statement; + + -- precond : WAIT + -- postcond: ';' + -- + -- [ §8.1 ] + -- wait_statement ::= + -- [ label : ] WAIT [ sensitivity_clause ] [ condition_clause ] + -- [ timeout_clause ] ; + -- + -- [ §8.1 ] + -- sensitivity_clause ::= ON sensitivity_list + -- + -- [ §8.1 ] + -- condition_clause ::= UNTIL conditiion + -- + -- [ §8.1 ] + -- timeout_clause ::= FOR TIME_expression + function Parse_Wait_Statement return Iir_Wait_Statement + is + Res: Iir_Wait_Statement; + List: Iir_List; + begin + Res := Create_Iir (Iir_Kind_Wait_Statement); + Set_Location (Res); + Scan; + case Current_Token is + when Tok_On => + List := Create_Iir_List; + Set_Sensitivity_List (Res, List); + Scan; + Parse_Sensitivity_List (List); + when Tok_Until => + null; + when Tok_For => + null; + when Tok_Semi_Colon => + return Res; + when others => + Error_Msg_Parse ("'on', 'until', 'for' or ';' expected"); + Eat_Tokens_Until_Semi_Colon; + return Res; + end case; + case Current_Token is + when Tok_On => + Error_Msg_Parse ("only one sensitivity is allowed"); + -- FIXME: sync + return Res; + when Tok_Until => + Scan; + Set_Condition_Clause (Res, Parse_Expression); + when Tok_For => + null; + when Tok_Semi_Colon => + return Res; + when others => + Error_Msg_Parse ("'until', 'for' or ';' expected"); + Eat_Tokens_Until_Semi_Colon; + return Res; + end case; + case Current_Token is + when Tok_On => + Error_Msg_Parse ("only one sensitivity clause is allowed"); + -- FIXME: sync + return Res; + when Tok_Until => + Error_Msg_Parse ("only one condition clause is allowed"); + -- FIXME: sync + return Res; + when Tok_For => + Scan; + Set_Timeout_Clause (Res, Parse_Expression); + return Res; + when Tok_Semi_Colon => + return Res; + when others => + Error_Msg_Parse ("'for' or ';' expected"); + Eat_Tokens_Until_Semi_Colon; + return Res; + end case; + end Parse_Wait_Statement; + + -- precond : IF + -- postcond: next token. + -- + -- [ §8.7 ] + -- if_statement ::= + -- [ IF_label : ] + -- IF condition THEN + -- sequence_of_statements + -- { ELSIF condition THEN + -- sequence_of_statements } + -- [ ELSE + -- sequence_of_statements ] + -- END IF [ IF_label ] ; + -- + -- FIXME: end label. + function Parse_If_Statement (Parent : Iir) return Iir_If_Statement + is + Res: Iir_If_Statement; + Clause: Iir; + N_Clause: Iir; + begin + Res := Create_Iir (Iir_Kind_If_Statement); + Set_Location (Res); + Set_Parent (Res, Parent); + Scan; + Clause := Res; + loop + Set_Condition (Clause, Parse_Expression); + Expect (Tok_Then, "'then' is expected here"); + Scan; + Set_Sequential_Statement_Chain + (Clause, Parse_Sequential_Statements (Res)); + exit when Current_Token = Tok_End; + N_Clause := Create_Iir (Iir_Kind_Elsif); + Set_Location (N_Clause); + Set_Else_Clause (Clause, N_Clause); + Clause := N_Clause; + if Current_Token = Tok_Else then + Scan; + Set_Sequential_Statement_Chain + (Clause, Parse_Sequential_Statements (Res)); + exit; + elsif Current_Token = Tok_Elsif then + Scan; + else + Error_Msg_Parse ("'else' or 'elsif' expected"); + end if; + end loop; + Expect (Tok_End); + Scan_Expect (Tok_If); + Scan; + return Res; + end Parse_If_Statement; + + function Parenthesis_Name_To_Procedure_Call (Name: Iir; Kind : Iir_Kind) + return Iir + is + Res: Iir; + Call : Iir_Procedure_Call; + begin + Res := Create_Iir (Kind); + Location_Copy (Res, Name); + Call := Create_Iir (Iir_Kind_Procedure_Call); + Location_Copy (Call, Name); + Set_Procedure_Call (Res, Call); + case Get_Kind (Name) is + when Iir_Kind_Parenthesis_Name => + Set_Prefix (Call, Get_Prefix (Name)); + Set_Parameter_Association_Chain + (Call, Get_Association_Chain (Name)); + Free_Iir (Name); + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Set_Prefix (Call, Name); + when Iir_Kind_Attribute_Name => + Error_Msg_Parse ("attribute cannot be used as procedure call"); + when others => + Error_Kind ("parenthesis_name_to_procedure_call", Name); + end case; + return Res; + end Parenthesis_Name_To_Procedure_Call; + + -- precond : identifier + -- postcond: next token + -- + -- [ LRM93 8.9 ] + -- parameter_specification ::= identifier IN discrete_range + function Parse_Parameter_Specification (Parent : Iir) + return Iir_Iterator_Declaration + is + Decl : Iir_Iterator_Declaration; + begin + Decl := Create_Iir (Iir_Kind_Iterator_Declaration); + Set_Location (Decl); + Set_Parent (Decl, Parent); + + Expect (Tok_Identifier); + Set_Identifier (Decl, Current_Identifier); + + -- Skip identifier + Scan_Expect (Tok_In); + + -- Skip 'in' + Scan; + + Set_Discrete_Range (Decl, Parse_Discrete_Range); + return Decl; + end Parse_Parameter_Specification; + + -- precond: '<=' + -- postcond: next token + -- + -- [ §8.4 ] + -- signal_assignment_statement ::= + -- [ label : ] target <= [ delay_mechanism ] waveform ; + function Parse_Signal_Assignment_Statement (Target : Iir) return Iir + is + Stmt : Iir; + Wave_Chain : Iir_Waveform_Element; + begin + Stmt := Create_Iir (Iir_Kind_Signal_Assignment_Statement); + Location_Copy (Stmt, Target); + Set_Target (Stmt, Target); + Scan; + Parse_Delay_Mechanism (Stmt); + Wave_Chain := Parse_Waveform; + -- LRM 8.4 Signal assignment statement + -- It is an error is the reserved word UNAFFECTED appears as a + -- waveform in a (sequential) signa assignment statement. + if Wave_Chain = Null_Iir then + Error_Msg_Parse + ("'unaffected' is not allowed in a sequential statement"); + end if; + Set_Waveform_Chain (Stmt, Wave_Chain); + return Stmt; + end Parse_Signal_Assignment_Statement; + + -- precond: ':=' + -- postcond: next token + -- + -- [ §8.5 ] + -- variable_assignment_statement ::= + -- [ label : ] target := expression ; + function Parse_Variable_Assignment_Statement (Target : Iir) return Iir + is + Stmt : Iir; + begin + Stmt := Create_Iir (Iir_Kind_Variable_Assignment_Statement); + Location_Copy (Stmt, Target); + Set_Target (Stmt, Target); + Scan; + Set_Expression (Stmt, Parse_Expression); + return Stmt; + end Parse_Variable_Assignment_Statement; + + -- precond: next token + -- postcond: next token + -- + -- [ 8 ] + -- sequence_of_statement ::= { sequential_statement } + -- + -- [ 8 ] + -- sequential_statement ::= wait_statement + -- | assertion_statement + -- | report_statement + -- | signal_assignment_statement + -- | variable_assignment_statement + -- | procedure_call_statement + -- | if_statement + -- | case_statement + -- | loop_statement + -- | next_statement + -- | exit_statement + -- | return_statement + -- | null_statement + -- + -- [ 8.13 ] + -- null_statement ::= [ label : ] NULL ; + -- + -- [ 8.12 ] + -- return_statement ::= [ label : ] RETURN [ expression ] + -- + -- [ 8.10 ] + -- next_statement ::= [ label : ] NEXT [ LOOP_label ] [ WHEN condition ] ; + -- + -- [ 8.11 ] + -- exit_statement ::= [ label : ] EXIT [ LOOP_label ] [ WHEN condition ] ; + -- + -- [ 8.9 ] + -- loop_statement ::= + -- [ LOOP_label : ] + -- [ iteration_scheme ] LOOP + -- sequence_of_statements + -- END LOOP [ LOOP_label ] ; + -- + -- [ 8.9 ] + -- iteration_scheme ::= WHILE condition + -- | FOR LOOP_parameter_specification + -- + -- [ 8.8 ] + -- case_statement ::= + -- [ CASE_label : ] + -- CASE expression IS + -- case_statement_alternative + -- { case_statement_alternative } + -- END CASE [ CASE_label ] ; + -- + -- [ 8.8 ] + -- case_statement_alternative ::= WHEN choices => sequence_of_statements + -- + -- [ 8.2 ] + -- assertion_statement ::= [ label : ] assertion ; + -- + -- [ 8.3 ] + -- report_statement ::= [ label : ] REPORT expression SEVERITY expression ; + function Parse_Sequential_Assignment_Statement (Target : Iir) return Iir + is + Stmt : Iir; + Call : Iir; + begin + if Current_Token = Tok_Less_Equal then + return Parse_Signal_Assignment_Statement (Target); + elsif Current_Token = Tok_Assign then + return Parse_Variable_Assignment_Statement (Target); + elsif Current_Token = Tok_Semi_Colon then + return Parenthesis_Name_To_Procedure_Call + (Target, Iir_Kind_Procedure_Call_Statement); + else + Error_Msg_Parse ("""<="" or "":="" expected instead of " + & Image (Current_Token)); + Stmt := Create_Iir (Iir_Kind_Procedure_Call_Statement); + Call := Create_Iir (Iir_Kind_Procedure_Call); + Set_Prefix (Call, Target); + Set_Procedure_Call (Stmt, Call); + Set_Location (Call); + Eat_Tokens_Until_Semi_Colon; + return Stmt; + end if; + end Parse_Sequential_Assignment_Statement; + + function Parse_Sequential_Statements (Parent : Iir) + return Iir + is + First_Stmt : Iir; + Last_Stmt : Iir; + Stmt: Iir; + Label: Name_Id; + Loc : Location_Type; + Target : Iir; + begin + First_Stmt := Null_Iir; + Last_Stmt := Null_Iir; + -- Expect a current_token. + loop + Loc := Get_Token_Location; + if Current_Token = Tok_Identifier then + Label := Current_Identifier; + Scan; + if Current_Token = Tok_Colon then + Scan; + else + Target := Create_Iir (Iir_Kind_Simple_Name); + Set_Identifier (Target, Label); + Set_Location (Target, Loc); + Label := Null_Identifier; + Target := Parse_Name_Suffix (Target, True); + Stmt := Parse_Sequential_Assignment_Statement (Target); + goto Has_Stmt; + end if; + else + Label := Null_Identifier; + end if; + + case Current_Token is + when Tok_Null => + Stmt := Create_Iir (Iir_Kind_Null_Statement); + Scan; + when Tok_Assert => + Stmt := Create_Iir (Iir_Kind_Assertion_Statement); + Parse_Assertion (Stmt); + when Tok_Report => + Stmt := Parse_Report_Statement; + when Tok_If => + Stmt := Parse_If_Statement (Parent); + Set_Label (Stmt, Label); + Set_Location (Stmt, Loc); + if Flags.Vhdl_Std >= Vhdl_93c then + Check_End_Name (Stmt); + end if; + when Tok_Identifier + | Tok_String => + -- String for an expanded name with operator_symbol prefix. + Stmt := Parse_Sequential_Assignment_Statement (Parse_Name); + when Tok_Left_Paren => + declare + Target : Iir; + begin + Target := Parse_Aggregate; + if Current_Token = Tok_Less_Equal then + Stmt := Parse_Signal_Assignment_Statement (Target); + elsif Current_Token = Tok_Assign then + Stmt := Parse_Variable_Assignment_Statement (Target); + else + Error_Msg_Parse ("'<=' or ':=' expected"); + return First_Stmt; + end if; + end; + + when Tok_Return => + Stmt := Create_Iir (Iir_Kind_Return_Statement); + Scan; + if Current_Token /= Tok_Semi_Colon then + Set_Expression (Stmt, Parse_Expression); + end if; + + when Tok_For => + Stmt := Create_Iir (Iir_Kind_For_Loop_Statement); + Set_Location (Stmt, Loc); + Set_Label (Stmt, Label); + + -- Skip 'for' + Scan; + + Set_Parameter_Specification + (Stmt, Parse_Parameter_Specification (Stmt)); + + -- Skip 'loop' + Expect (Tok_Loop); + Scan; + + Set_Sequential_Statement_Chain + (Stmt, Parse_Sequential_Statements (Stmt)); + + -- Skip 'end' + Expect (Tok_End); + Scan_Expect (Tok_Loop); + + -- Skip 'loop' + Scan; + + Check_End_Name (Stmt); + -- A loop statement can have a label, even in vhdl87. + Label := Null_Identifier; + + when Tok_While + | Tok_Loop => + Stmt := Create_Iir (Iir_Kind_While_Loop_Statement); + Set_Location (Stmt); + Set_Label (Stmt, Label); + if Current_Token = Tok_While then + Scan; + Set_Condition (Stmt, Parse_Expression); + Expect (Tok_Loop); + end if; + Scan; + Set_Sequential_Statement_Chain + (Stmt, Parse_Sequential_Statements (Stmt)); + Expect (Tok_End); + Scan_Expect (Tok_Loop); + Scan; + Check_End_Name (Stmt); + -- A loop statement can have a label, even in vhdl87. + Label := Null_Identifier; + + when Tok_Next + | Tok_Exit => + if Current_Token = Tok_Next then + Stmt := Create_Iir (Iir_Kind_Next_Statement); + else + Stmt := Create_Iir (Iir_Kind_Exit_Statement); + end if; + + -- Skip 'next' or 'exit'. + Scan; + + if Current_Token = Tok_Identifier then + Set_Loop_Label (Stmt, Parse_Name (Allow_Indexes => False)); + end if; + + if Current_Token = Tok_When then + -- Skip 'when'. + Scan; + + Set_Condition (Stmt, Parse_Expression); + end if; + + when Tok_Case => + declare + use Iir_Chains.Case_Statement_Alternative_Chain_Handling; + Assoc: Iir; + Last_Assoc : Iir; + begin + Stmt := Create_Iir (Iir_Kind_Case_Statement); + Set_Location (Stmt); + Set_Label (Stmt, Label); + Scan; + Set_Expression (Stmt, Parse_Expression); + Expect (Tok_Is); + Scan; + if Current_Token = Tok_End then + Error_Msg_Parse ("missing alternative in case statement"); + end if; + Build_Init (Last_Assoc); + while Current_Token /= Tok_End loop + -- Eat 'when' + Expect (Tok_When); + Scan; + + if Current_Token = Tok_Double_Arrow then + Error_Msg_Parse ("missing expression in alternative"); + Assoc := Create_Iir (Iir_Kind_Choice_By_Expression); + Set_Location (Assoc); + else + Assoc := Parse_Choices (Null_Iir); + end if; + + -- Eat '=>' + Expect (Tok_Double_Arrow); + Scan; + + Set_Associated_Chain + (Assoc, Parse_Sequential_Statements (Stmt)); + Append_Subchain (Last_Assoc, Stmt, Assoc); + end loop; + + -- Eat 'end', 'case' + Scan_Expect (Tok_Case); + Scan; + + if Flags.Vhdl_Std >= Vhdl_93c then + Check_End_Name (Stmt); + end if; + end; + when Tok_Wait => + Stmt := Parse_Wait_Statement; + when others => + return First_Stmt; + end case; + << Has_Stmt >> null; + Set_Parent (Stmt, Parent); + Set_Location (Stmt, Loc); + if Label /= Null_Identifier then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Sem + ("this statement can't have a label in vhdl 87", Stmt); + else + Set_Label (Stmt, Label); + end if; + end if; + Scan_Semi_Colon ("statement"); + + -- Append it to the chain. + if First_Stmt = Null_Iir then + First_Stmt := Stmt; + else + Set_Chain (Last_Stmt, Stmt); + end if; + Last_Stmt := Stmt; + end loop; + end Parse_Sequential_Statements; + + -- precond : PROCEDURE, FUNCTION, PURE or IMPURE. + -- postcond: ';' + -- + -- [ §2.1 ] + -- subprogram_declaration ::= subprogram_specification ; + -- + -- [ §2.1 ] + -- subprogram_specification ::= + -- PROCEDURE designator [ ( formal_parameter_list ) ] + -- | [ PURE | IMPURE ] FUNCTION designator [ ( formal_parameter_list ) ] + -- RETURN type_mark + -- + -- [ §2.2 ] + -- subprogram_body ::= + -- subprogram_specification IS + -- subprogram_declarative_part + -- BEGIN + -- subprogram_statement_part + -- END [ subprogram_kind ] [ designator ] ; + -- + -- [ §2.1 ] + -- designator ::= identifier | operator_symbol + -- + -- [ §2.1 ] + -- operator_symbol ::= string_literal + function Parse_Subprogram_Declaration (Parent : Iir) return Iir + is + Kind : Iir_Kind; + Inters : Iir; + Subprg: Iir; + Subprg_Body : Iir; + Old : Iir; + pragma Unreferenced (Old); + begin + -- Create the node. + case Current_Token is + when Tok_Procedure => + Kind := Iir_Kind_Procedure_Declaration; + when Tok_Function + | Tok_Pure + | Tok_Impure => + Kind := Iir_Kind_Function_Declaration; + when others => + raise Internal_Error; + end case; + Subprg := Create_Iir (Kind); + Set_Location (Subprg); + + case Current_Token is + when Tok_Procedure => + null; + when Tok_Function => + -- LRM93 2.1 + -- A function is impure if its specification contains the + -- reserved word IMPURE; otherwise it is said to be pure. + Set_Pure_Flag (Subprg, True); + when Tok_Pure + | Tok_Impure => + Set_Pure_Flag (Subprg, Current_Token = Tok_Pure); + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("'pure' and 'impure' are not allowed in vhdl 87"); + end if; + Set_Has_Pure (Subprg, True); + -- FIXME: what to do in case of error ?? + -- Eat PURE or IMPURE. + Scan; + Expect (Tok_Function, "'function' must follow 'pure' or 'impure'"); + when others => + raise Internal_Error; + end case; + + -- Eat PROCEDURE or FUNCTION. + Scan; + + if Current_Token = Tok_Identifier then + Set_Identifier (Subprg, Current_Identifier); + Set_Location (Subprg); + elsif Current_Token = Tok_String then + if Kind = Iir_Kind_Procedure_Declaration then + -- LRM93 2.1 + -- A procedure designator is always an identifier. + Error_Msg_Parse ("a procedure name must be an identifier"); + end if; + -- LRM93 2.1 + -- A function designator is either an identifier or an operator + -- symbol. + Set_Identifier (Subprg, Scan_To_Operator_Name (Get_Token_Location)); + Set_Location (Subprg); + else + -- Just to display a parse error. + Expect (Tok_Identifier); + end if; + + Scan; + if Current_Token = Tok_Left_Paren then + -- Parse the interface declaration. + if Kind = Iir_Kind_Function_Declaration then + Inters := Parse_Interface_List + (Function_Parameter_Interface_List, Subprg); + else + Inters := Parse_Interface_List + (Procedure_Parameter_Interface_List, Subprg); + end if; + Set_Interface_Declaration_Chain (Subprg, Inters); + end if; + + if Current_Token = Tok_Return then + if Kind = Iir_Kind_Procedure_Declaration then + Error_Msg_Parse ("'return' not allowed for a procedure"); + Error_Msg_Parse ("(remove return part or define a function)"); + + -- Skip 'return' + Scan; + + Old := Parse_Type_Mark; + else + -- Skip 'return' + Scan; + + Set_Return_Type_Mark + (Subprg, Parse_Type_Mark (Check_Paren => True)); + end if; + else + if Kind = Iir_Kind_Function_Declaration then + Error_Msg_Parse ("'return' expected"); + end if; + end if; + + if Current_Token = Tok_Semi_Colon then + return Subprg; + end if; + + -- The body. + Set_Has_Body (Subprg, True); + if Kind = Iir_Kind_Function_Declaration then + Subprg_Body := Create_Iir (Iir_Kind_Function_Body); + else + Subprg_Body := Create_Iir (Iir_Kind_Procedure_Body); + end if; + Location_Copy (Subprg_Body, Subprg); + + Set_Subprogram_Body (Subprg, Subprg_Body); + Set_Subprogram_Specification (Subprg_Body, Subprg); + Set_Chain (Subprg, Subprg_Body); + + if Get_Kind (Parent) = Iir_Kind_Package_Declaration then + Error_Msg_Parse ("subprogram body not allowed in package spec"); + end if; + Expect (Tok_Is); + Scan; + Parse_Declarative_Part (Subprg_Body); + Expect (Tok_Begin); + Scan; + Set_Sequential_Statement_Chain + (Subprg_Body, Parse_Sequential_Statements (Subprg_Body)); + Expect (Tok_End); + Scan; + + case Current_Token is + when Tok_Function => + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'function' not allowed here by vhdl 87"); + end if; + if Kind = Iir_Kind_Procedure_Declaration then + Error_Msg_Parse ("'procedure' expected instead of 'function'"); + end if; + Set_End_Has_Reserved_Id (Subprg_Body, True); + Scan; + when Tok_Procedure => + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'procedure' not allowed here by vhdl 87"); + end if; + if Kind = Iir_Kind_Function_Declaration then + Error_Msg_Parse ("'function' expected instead of 'procedure'"); + end if; + Set_End_Has_Reserved_Id (Subprg_Body, True); + Scan; + when others => + null; + end case; + case Current_Token is + when Tok_Identifier => + Check_End_Name (Get_Identifier (Subprg), Subprg_Body); + when Tok_String => + if Scan_To_Operator_Name (Get_Token_Location) + /= Get_Identifier (Subprg) + then + Error_Msg_Parse + ("mispelling, 'end """ & Image_Identifier (Subprg) + & """;' expected"); + end if; + Set_End_Has_Identifier (Subprg_Body, True); + Scan; + when others => + null; + end case; + Expect (Tok_Semi_Colon); + return Subprg; + end Parse_Subprogram_Declaration; + + -- precond: PROCESS + -- postcond: null + -- + -- [ LRM87 9.2 / LRM08 11.3 ] + -- process_statement ::= + -- [ PROCESS_label : ] + -- [ POSTPONED ] PROCESS [ ( process_sensitivity_list ) ] [ IS ] + -- process_declarative_part + -- BEGIN + -- process_statement_part + -- END [ POSTPONED ] PROCESS [ PROCESS_label ] ; + -- + -- process_sensitivity_list ::= ALL | sensitivity_list + function Parse_Process_Statement + (Label: Name_Id; Loc : Location_Type; Is_Postponed : Boolean) + return Iir + is + Res: Iir; + Sensitivity_List : Iir_List; + begin + -- The PROCESS keyword was just scaned. + Scan; + + if Current_Token = Tok_Left_Paren then + Res := Create_Iir (Iir_Kind_Sensitized_Process_Statement); + Scan; + if Current_Token = Tok_All then + if Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("all sensitized process allowed only in vhdl 08"); + end if; + Sensitivity_List := Iir_List_All; + Scan; + else + Sensitivity_List := Create_Iir_List; + Parse_Sensitivity_List (Sensitivity_List); + end if; + Set_Sensitivity_List (Res, Sensitivity_List); + Expect (Tok_Right_Paren); + Scan; + else + Res := Create_Iir (Iir_Kind_Process_Statement); + end if; + + Set_Location (Res, Loc); + Set_Label (Res, Label); + + if Current_Token = Tok_Is then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("""is"" not allowed here by vhdl 87"); + end if; + Set_Has_Is (Res, True); + Scan; + end if; + + -- declarative part. + Parse_Declarative_Part (Res); + + -- Skip 'begin'. + Expect (Tok_Begin); + Scan; + + Set_Sequential_Statement_Chain (Res, Parse_Sequential_Statements (Res)); + + -- Skip 'end'. + Expect (Tok_End); + Scan; + + if Current_Token = Tok_Postponed then + if not Is_Postponed then + -- LRM93 9.2 + -- If the reserved word POSTPONED appears at the end of a process + -- statement, the process must be a postponed process. + Error_Msg_Parse ("process is not a postponed process"); + end if; + + Set_End_Has_Postponed (Res, True); + + -- Skip 'postponed', + Scan; + end if; + + if Current_Token = Tok_Semi_Colon then + Error_Msg_Parse ("""end"" must be followed by ""process"""); + else + Expect (Tok_Process); + Scan; + Set_End_Has_Reserved_Id (Res, True); + Check_End_Name (Res); + Expect (Tok_Semi_Colon); + end if; + return Res; + end Parse_Process_Statement; + + -- precond : NEXT_TOKEN + -- postcond: NEXT_TOKEN + -- + -- [ LRM93 4.3.2.2 ] + -- association_list ::= association_element { , association_element } + -- + -- [ LRM93 4.3.2.2 ] + -- association_element ::= [ formal_part => ] actual_part + -- + -- [ LRM93 4.3.2.2 ] + -- actual_part ::= actual_designator + -- | FUNCTION_name ( actual_designator ) + -- | type_mark ( actual_designator ) + -- + -- [ LRM93 4.3.2.2 ] + -- actual_designator ::= expression + -- | SIGNAL_name + -- | VARIABLE_name + -- | FILE_name + -- | OPEN + -- + -- [ LRM93 4.3.2.2 ] + -- formal_part ::= formal_designator + -- | FUNCTION_name ( formal_designator ) + -- | type_mark ( formal_designator ) + -- + -- [ LRM93 4.3.2.2 ] + -- formal_designator ::= GENERIC_name + -- | PORT_name + -- | PARAMETER_name + -- + -- Note: an actual part is parsed as an expression. + function Parse_Association_List return Iir + is + Res, Last: Iir; + El: Iir; + Formal: Iir; + Actual: Iir; + Nbr_Assocs : Natural; + Loc : Location_Type; + begin + Sub_Chain_Init (Res, Last); + + if Current_Token = Tok_Right_Paren then + Error_Msg_Parse ("empty association list is not allowed"); + return Res; + end if; + + Nbr_Assocs := 1; + loop + -- Parse formal and actual. + Loc := Get_Token_Location; + Formal := Null_Iir; + + if Current_Token /= Tok_Open then + Actual := Parse_Expression; + case Current_Token is + when Tok_To + | Tok_Downto => + -- To/downto can appear in slice name (which are parsed as + -- function call). + + if Actual = Null_Iir then + -- Left expression is missing ie: (downto x). + 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; + + when Tok_Double_Arrow => + Formal := Actual; + + -- Skip '=>' + Scan; + Loc := Get_Token_Location; + + if Current_Token /= Tok_Open then + Actual := Parse_Expression; + end if; + + when others => + null; + end case; + end if; + + if Current_Token = Tok_Open then + El := Create_Iir (Iir_Kind_Association_Element_Open); + Set_Location (El); + + -- Skip 'open' + Scan; + else + El := Create_Iir (Iir_Kind_Association_Element_By_Expression); + Set_Location (El, Loc); + Set_Actual (El, Actual); + end if; + Set_Formal (El, Formal); + + Sub_Chain_Append (Res, Last, El); + exit when Current_Token = Tok_Right_Paren; + Expect (Tok_Comma); + Scan; + Nbr_Assocs := Nbr_Assocs + 1; + end loop; + + return Res; + end Parse_Association_List; + + -- precond : NEXT_TOKEN + -- postcond: NEXT_TOKEN + -- + -- Parse: '(' association_list ')' + function Parse_Association_List_In_Parenthesis return Iir + is + Res : Iir; + begin + -- Skip '(' + Expect (Tok_Left_Paren); + Scan; + + Res := Parse_Association_List; + + -- Skip ')' + Scan; + + return Res; + end Parse_Association_List_In_Parenthesis; + + -- precond : GENERIC + -- postcond: next token + -- + -- [ LRM93 5.2.1.2, LRM08 6.5.7.2 ] + -- generic_map_aspect ::= GENERIC MAP ( GENERIC_association_list ) + function Parse_Generic_Map_Aspect return Iir is + begin + Expect (Tok_Generic); + Scan_Expect (Tok_Map); + Scan; + return Parse_Association_List_In_Parenthesis; + end Parse_Generic_Map_Aspect; + + -- precond : PORT + -- postcond: next token + -- + -- [ §5.2.1.2 ] + -- port_map_aspect ::= PORT MAP ( PORT_association_list ) + function Parse_Port_Map_Aspect return Iir is + begin + Expect (Tok_Port); + Scan_Expect (Tok_Map); + Scan; + return Parse_Association_List_In_Parenthesis; + end Parse_Port_Map_Aspect; + + -- precond : COMPONENT | ENTIY | CONFIGURATION + -- postcond : next_token + -- + -- instantiated_unit ::= + -- [ COMPONENT ] component_name + -- ENTITY entity_name [ ( architecture_identifier ) ] + -- CONFIGURATION configuration_name + function Parse_Instantiated_Unit return Iir + is + Res : Iir; + begin + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("component instantiation using keyword 'component', 'entity',"); + Error_Msg_Parse (" or 'configuration' is not allowed in vhdl87"); + end if; + + case Current_Token is + when Tok_Component => + Scan; + return Parse_Name (False); + when Tok_Entity => + Res := Create_Iir (Iir_Kind_Entity_Aspect_Entity); + Set_Location (Res); + Scan; + Set_Entity_Name (Res, Parse_Name (False)); + if Current_Token = Tok_Left_Paren then + Scan_Expect (Tok_Identifier); + Set_Architecture (Res, Current_Text); + Scan_Expect (Tok_Right_Paren); + Scan; + end if; + return Res; + when Tok_Configuration => + Res := Create_Iir (Iir_Kind_Entity_Aspect_Configuration); + Set_Location (Res); + Scan_Expect (Tok_Identifier); + Set_Configuration_Name (Res, Parse_Name (False)); + return Res; + when others => + raise Internal_Error; + end case; + end Parse_Instantiated_Unit; + + -- precond : next token + -- postcond: ';' + -- + -- component_instantiation_statement ::= + -- INSTANTIATION_label : + -- instantiated_unit [ generic_map_aspect ] [ port_map_aspect ] ; + function Parse_Component_Instantiation (Name: Iir) + return Iir_Component_Instantiation_Statement is + Res: Iir_Component_Instantiation_Statement; + begin + Res := Create_Iir (Iir_Kind_Component_Instantiation_Statement); + Set_Location (Res); + + Set_Instantiated_Unit (Res, Name); + + if Current_Token = Tok_Generic then + Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); + end if; + if Current_Token = Tok_Port then + Set_Port_Map_Aspect_Chain (Res, Parse_Port_Map_Aspect); + end if; + Expect (Tok_Semi_Colon); + return Res; + end Parse_Component_Instantiation; + + -- precond : next token + -- postcond: next token + -- + -- [ §9.1 ] + -- block_header ::= [ generic_clause [ generic_map_aspect ; ] ] + -- [ port_clause [ port_map_aspect ; ] ] + function Parse_Block_Header return Iir_Block_Header is + Res : Iir_Block_Header; + begin + Res := Create_Iir (Iir_Kind_Block_Header); + Set_Location (Res); + if Current_Token = Tok_Generic then + Parse_Generic_Clause (Res); + if Current_Token = Tok_Generic then + Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); + Scan_Semi_Colon ("generic map aspect"); + end if; + end if; + if Current_Token = Tok_Port then + Parse_Port_Clause (Res); + if Current_Token = Tok_Port then + Set_Port_Map_Aspect_Chain (Res, Parse_Port_Map_Aspect); + Scan_Semi_Colon ("port map aspect"); + end if; + end if; + return Res; + end Parse_Block_Header; + + -- precond : BLOCK + -- postcond: ';' + -- + -- [ §9.1 ] + -- block_statement ::= + -- BLOCK_label : + -- BLOCK [ ( GUARD_expression ) ] [ IS ] + -- block_header + -- block_declarative_part + -- BEGIN + -- block_statement_part + -- END BLOCK [ BLOCK_label ] ; + -- + -- [ §9.1 ] + -- block_declarative_part ::= { block_declarative_item } + -- + -- [ §9.1 ] + -- block_statement_part ::= { concurrent_statement } + function Parse_Block_Statement (Label: Name_Id; Loc : Location_Type) + return Iir_Block_Statement + is + Res : Iir_Block_Statement; + Guard : Iir_Guard_Signal_Declaration; + begin + if Label = Null_Identifier then + Error_Msg_Parse ("a block statement must have a label"); + end if; + + -- block was just parsed. + Res := Create_Iir (Iir_Kind_Block_Statement); + Set_Location (Res, Loc); + Set_Label (Res, Label); + Scan; + if Current_Token = Tok_Left_Paren then + Guard := Create_Iir (Iir_Kind_Guard_Signal_Declaration); + Set_Location (Guard); + Set_Guard_Decl (Res, Guard); + Scan; + Set_Guard_Expression (Guard, Parse_Expression); + Expect (Tok_Right_Paren, "a ')' is expected after guard expression"); + Scan; + end if; + if Current_Token = Tok_Is then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'is' not allowed here in vhdl87"); + end if; + Scan; + end if; + if Current_Token = Tok_Generic or Current_Token = Tok_Port then + Set_Block_Header (Res, Parse_Block_Header); + end if; + if Current_Token /= Tok_Begin then + Parse_Declarative_Part (Res); + end if; + Expect (Tok_Begin); + Scan; + Parse_Concurrent_Statements (Res); + Check_End_Name (Tok_Block, Res); + return Res; + end Parse_Block_Statement; + + -- precond : IF or FOR + -- postcond: ';' + -- + -- [ LRM93 9.7 ] + -- generate_statement ::= + -- GENERATE_label : generation_scheme GENERATE + -- [ { block_declarative_item } + -- BEGIN ] + -- { concurrent_statement } + -- END GENERATE [ GENERATE_label ] ; + -- + -- [ LRM93 9.7 ] + -- generation_scheme ::= + -- FOR GENERATE_parameter_specification + -- | IF condition + -- + -- FIXME: block_declarative item. + function Parse_Generate_Statement (Label : Name_Id; Loc : Location_Type) + return Iir_Generate_Statement + is + Res : Iir_Generate_Statement; + begin + if Label = Null_Identifier then + Error_Msg_Parse ("a generate statement must have a label"); + end if; + Res := Create_Iir (Iir_Kind_Generate_Statement); + Set_Location (Res, Loc); + Set_Label (Res, Label); + case Current_Token is + when Tok_For => + Scan; + Set_Generation_Scheme (Res, Parse_Parameter_Specification (Res)); + when Tok_If => + Scan; + Set_Generation_Scheme (Res, Parse_Expression); + when others => + raise Internal_Error; + end case; + Expect (Tok_Generate); + + Scan; + -- Check for a block declarative item. + case Current_Token is + when + -- subprogram_declaration + -- subprogram_body + Tok_Procedure + | Tok_Function + | Tok_Pure + | Tok_Impure + -- type_declaration + | Tok_Type + -- subtype_declaration + | Tok_Subtype + -- constant_declaration + | Tok_Constant + -- signal_declaration + | Tok_Signal + -- shared_variable_declaration + | Tok_Shared + | Tok_Variable + -- file_declaration + | Tok_File + -- alias_declaration + | Tok_Alias + -- component_declaration + | Tok_Component + -- attribute_declaration + -- attribute_specification + | Tok_Attribute + -- configuration_specification + | Tok_For + -- disconnection_specification + | Tok_Disconnect + -- use_clause + | Tok_Use + -- group_template_declaration + -- group_declaration + | Tok_Group + | Tok_Begin => + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("declarations not allowed in a generate in vhdl87"); + end if; + Parse_Declarative_Part (Res); + Expect (Tok_Begin); + Set_Has_Begin (Res, True); + Scan; + when others => + null; + end case; + + Parse_Concurrent_Statements (Res); + + Expect (Tok_End); + + -- Skip 'end' + Scan_Expect (Tok_Generate); + Set_End_Has_Reserved_Id (Res, True); + + -- Skip 'generate' + Scan; + + -- LRM93 9.7 + -- If a label appears at the end of a generate statement, it must repeat + -- the generate label. + Check_End_Name (Res); + Expect (Tok_Semi_Colon); + return Res; + end Parse_Generate_Statement; + + -- precond : first token + -- postcond: END + -- + -- [ §9 ] + -- concurrent_statement ::= block_statement + -- | process_statement + -- | concurrent_procedure_call_statement + -- | concurrent_assertion_statement + -- | concurrent_signal_assignment_statement + -- | component_instantiation_statement + -- | generate_statement + -- + -- [ §9.4 ] + -- concurrent_assertion_statement ::= + -- [ label : ] [ POSTPONED ] assertion ; + -- + -- [ §9.3 ] + -- concurrent_procedure_call_statement ::= + -- [ label : ] [ POSTPONED ] procedure_call ; + -- + -- [ §9.5 ] + -- concurrent_signal_assignment_statement ::= + -- [ label : ] [ POSTPONED ] conditional_signal_assignment + -- | [ label : ] [ POSTPONED ] selected_signal_assignment + function Parse_Concurrent_Assignment (Target : Iir) return Iir + is + Res : Iir; + begin + case Current_Token is + when Tok_Less_Equal + | Tok_Assign => + -- This is a conditional signal assignment. + -- Error for ':=' is handled by the subprogram. + return Parse_Conditional_Signal_Assignment (Target); + when Tok_Semi_Colon => + -- a procedure call or a component instantiation. + -- Parse it as a procedure call, may be revert to a + -- component instantiation during sem. + Expect (Tok_Semi_Colon); + return Parenthesis_Name_To_Procedure_Call + (Target, Iir_Kind_Concurrent_Procedure_Call_Statement); + when Tok_Generic | Tok_Port => + -- or a component instantiation. + return Parse_Component_Instantiation (Target); + when others => + -- or a simple simultaneous statement + if AMS_Vhdl then + Res := Create_Iir (Iir_Kind_Simple_Simultaneous_Statement); + Set_Simultaneous_Left (Res, Parse_Simple_Expression (Target)); + if Current_Token /= Tok_Equal_Equal then + Error_Msg_Parse ("'==' expected after expression"); + else + Set_Location (Res); + Scan; + end if; + Set_Simultaneous_Right (Res, Parse_Simple_Expression); + Set_Tolerance (Res, Parse_Tolerance_Aspect_Opt); + Expect (Tok_Semi_Colon); + return Res; + else + return Parse_Conditional_Signal_Assignment + (Parse_Simple_Expression (Target)); + end if; + end case; + end Parse_Concurrent_Assignment; + + function Parse_Psl_Default_Clock return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Psl_Default_Clock); + Scanner.Flag_Psl := True; + Scan_Expect (Tok_Psl_Clock); + Scan_Expect (Tok_Is); + Scan; + Set_Psl_Boolean (Res, Parse_Psl.Parse_Psl_Boolean); + Expect (Tok_Semi_Colon); + Scanner.Flag_Scan_In_Comment := False; + Scanner.Flag_Psl := False; + return Res; + end Parse_Psl_Default_Clock; + + function Parse_Psl_Declaration return Iir + is + Tok : constant Token_Type := Current_Token; + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Psl_Declaration); + Scan; + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("property name expected here"); + else + Set_Identifier (Res, Current_Identifier); + end if; + Scanner.Flag_Psl := True; + Set_Psl_Declaration (Res, Parse_Psl.Parse_Psl_Declaration (Tok)); + Expect (Tok_Semi_Colon); + Scanner.Flag_Scan_In_Comment := False; + Scanner.Flag_Psl := False; + return Res; + end Parse_Psl_Declaration; + + function Parse_Psl_Assert_Statement return Iir + is + Res : Iir; + begin + case Current_Token is + when Tok_Psl_Assert => + Res := Create_Iir (Iir_Kind_Psl_Assert_Statement); + when Tok_Psl_Cover => + Res := Create_Iir (Iir_Kind_Psl_Cover_Statement); + when others => + raise Internal_Error; + end case; + + -- Scan extended PSL tokens. + Scanner.Flag_Psl := True; + + -- Skip 'assert' + Scan; + + Set_Psl_Property (Res, Parse_Psl.Parse_Psl_Property); + + -- No more PSL tokens after the property. + Scanner.Flag_Psl := False; + + if Current_Token = Tok_Report then + -- Skip 'report' + Scan; + + Set_Report_Expression (Res, Parse_Expression); + end if; + + if Current_Token = Tok_Severity then + -- Skip 'severity' + Scan; + + Set_Severity_Expression (Res, Parse_Expression); + end if; + + Expect (Tok_Semi_Colon); + Scanner.Flag_Scan_In_Comment := False; + return Res; + end Parse_Psl_Assert_Statement; + + procedure Parse_Concurrent_Statements (Parent : Iir) + is + Last_Stmt : Iir; + Stmt: Iir; + Label: Name_Id; + Id: Iir; + Postponed : Boolean; + Loc : Location_Type; + Target : Iir; + + procedure Postponed_Not_Allowed is + begin + if Postponed then + Error_Msg_Parse ("'postponed' not allowed here"); + Postponed := False; + end if; + end Postponed_Not_Allowed; + begin + -- begin was just parsed. + Last_Stmt := Null_Iir; + loop + Stmt := Null_Iir; + Label := Null_Identifier; + Postponed := False; + Loc := Get_Token_Location; + + -- Try to find a label. + if Current_Token = Tok_Identifier then + Label := Current_Identifier; + Scan; + if Current_Token = Tok_Colon then + -- The identifier is really a label. + Scan; + else + -- This is not a label. + Target := Create_Iir (Iir_Kind_Simple_Name); + Set_Location (Target, Loc); + Set_Identifier (Target, Label); + Label := Null_Identifier; + Target := Parse_Name_Suffix (Target); + Stmt := Parse_Concurrent_Assignment (Target); + goto Has_Stmt; + end if; + end if; + + if Current_Token = Tok_Postponed then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'postponed' is not allowed in vhdl 87"); + else + Postponed := True; + end if; + Scan; + end if; + + case Current_Token is + when Tok_End => + Postponed_Not_Allowed; + if Label /= Null_Identifier then + Error_Msg_Parse + ("no label is allowed before the 'end' keyword"); + end if; + return; + when Tok_Identifier => + Target := Parse_Name (Allow_Indexes => True); + Stmt := Parse_Concurrent_Assignment (Target); + if Get_Kind (Stmt) = Iir_Kind_Component_Instantiation_Statement + and then Postponed + then + Error_Msg_Parse ("'postponed' not allowed for " & + "an instantiation statement"); + Postponed := False; + end if; + when Tok_Left_Paren => + Id := Parse_Aggregate; + if Current_Token = Tok_Less_Equal then + -- This is a conditional signal assignment. + Stmt := Parse_Conditional_Signal_Assignment (Id); + else + Error_Msg_Parse ("'<=' expected after aggregate"); + Eat_Tokens_Until_Semi_Colon; + end if; + when Tok_Process => + Stmt := Parse_Process_Statement (Label, Loc, Postponed); + when Tok_Assert => + Stmt := Create_Iir (Iir_Kind_Concurrent_Assertion_Statement); + Parse_Assertion (Stmt); + Expect (Tok_Semi_Colon); + when Tok_With => + Stmt := Parse_Selected_Signal_Assignment; + when Tok_Block => + Postponed_Not_Allowed; + Stmt := Parse_Block_Statement (Label, Loc); + when Tok_If + | Tok_For => + if Postponed then + Error_Msg_Parse + ("'postponed' not allowed before a generate statement"); + Postponed := False; + end if; + Stmt := Parse_Generate_Statement (Label, Loc); + when Tok_Eof => + Error_Msg_Parse ("unexpected end of file, 'END;' expected"); + return; + when Tok_Component + | Tok_Entity + | Tok_Configuration => + Postponed_Not_Allowed; + declare + Unit : Iir; + begin + Unit := Parse_Instantiated_Unit; + Stmt := Parse_Component_Instantiation (Unit); + end; + when Tok_Psl_Default => + Postponed_Not_Allowed; + Stmt := Parse_Psl_Default_Clock; + when Tok_Psl_Property + | Tok_Psl_Sequence + | Tok_Psl_Endpoint => + Postponed_Not_Allowed; + Stmt := Parse_Psl_Declaration; + when Tok_Psl_Assert + | Tok_Psl_Cover => + Postponed_Not_Allowed; + Stmt := Parse_Psl_Assert_Statement; + when others => + -- FIXME: improve message: + -- instead of 'unexpected token 'signal' in conc stmt list' + -- report: 'signal declarations are not allowed in conc stmt' + Unexpected ("concurrent statement list"); + Eat_Tokens_Until_Semi_Colon; + end case; + + << Has_Stmt >> null; + + -- stmt can be null in case of error. + if Stmt /= Null_Iir then + Set_Location (Stmt, Loc); + if Label /= Null_Identifier then + Set_Label (Stmt, Label); + end if; + Set_Parent (Stmt, Parent); + if Postponed then + Set_Postponed_Flag (Stmt, True); + end if; + -- Append it to the chain. + if Last_Stmt = Null_Iir then + Set_Concurrent_Statement_Chain (Parent, Stmt); + else + Set_Chain (Last_Stmt, Stmt); + end if; + Last_Stmt := Stmt; + end if; + + Scan; + end loop; + end Parse_Concurrent_Statements; + + -- precond : LIBRARY + -- postcond: ; + -- + -- [ LRM93 11.2 ] + -- library_clause ::= LIBRARY logical_name_list + function Parse_Library_Clause return Iir + is + First, Last : Iir; + Library: Iir_Library_Clause; + begin + Sub_Chain_Init (First, Last); + Expect (Tok_Library); + loop + Library := Create_Iir (Iir_Kind_Library_Clause); + + -- Skip 'library' or ','. + Scan_Expect (Tok_Identifier); + + Set_Identifier (Library, Current_Identifier); + Set_Location (Library); + Sub_Chain_Append (First, Last, Library); + + -- Skip identifier. + Scan; + + exit when Current_Token = Tok_Semi_Colon; + Expect (Tok_Comma); + + Set_Has_Identifier_List (Library, True); + end loop; + + -- Skip ';'. + Scan; + return First; + end Parse_Library_Clause; + + -- precond : USE + -- postcond: ; + -- + -- [ §10.4 ] + -- use_clause ::= USE selected_name { , selected_name } + -- + -- FIXME: should be a list. + function Parse_Use_Clause return Iir_Use_Clause + is + Use_Clause: Iir_Use_Clause; + First, Last : Iir; + begin + First := Null_Iir; + Last := Null_Iir; + Scan; + loop + Use_Clause := Create_Iir (Iir_Kind_Use_Clause); + Set_Location (Use_Clause); + Expect (Tok_Identifier); + Set_Selected_Name (Use_Clause, Parse_Name); + + -- Chain use clauses. + if First = Null_Iir then + First := Use_Clause; + else + Set_Use_Clause_Chain (Last, Use_Clause); + end if; + Last := Use_Clause; + + exit when Current_Token = Tok_Semi_Colon; + Expect (Tok_Comma); + Scan; + end loop; + return First; + end Parse_Use_Clause; + + -- precond : ARCHITECTURE + -- postcond: ';' + -- + -- [ §1.2 ] + -- architecture_body ::= + -- ARCHITECTURE identifier OF ENTITY_name IS + -- architecture_declarative_part + -- BEGIN + -- architecture_statement_part + -- END [ ARCHITECTURE ] [ ARCHITECTURE_simple_name ] ; + procedure Parse_Architecture_Body (Unit : Iir_Design_Unit) + is + Res: Iir_Architecture_Body; + begin + Expect (Tok_Architecture); + Res := Create_Iir (Iir_Kind_Architecture_Body); + + -- Get identifier. + Scan_Expect (Tok_Identifier); + Set_Identifier (Res, Current_Identifier); + Set_Location (Res); + Scan; + if Current_Token = Tok_Is then + Error_Msg_Parse ("architecture identifier is missing"); + else + Expect (Tok_Of); + Scan; + Set_Entity_Name (Res, Parse_Name (False)); + Expect (Tok_Is); + end if; + + Scan; + Parse_Declarative_Part (Res); + + Expect (Tok_Begin); + Scan; + Parse_Concurrent_Statements (Res); + -- end was scanned. + Set_End_Location (Unit); + Scan; + if Current_Token = Tok_Architecture then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("'architecture' keyword not allowed here by vhdl 87"); + end if; + Set_End_Has_Reserved_Id (Res, True); + Scan; + end if; + Check_End_Name (Res); + Expect (Tok_Semi_Colon); + Set_Library_Unit (Unit, Res); + end Parse_Architecture_Body; + + -- precond : next token + -- postcond: a token + -- + -- [ §5.2 ] + -- instantiation_list ::= INSTANTIATION_label { , INSTANTIATION_label } + -- | OTHERS + -- | ALL + function Parse_Instantiation_List return Iir_List + is + Res : Iir_List; + begin + case Current_Token is + when Tok_All => + Scan; + return Iir_List_All; + when Tok_Others => + Scan; + return Iir_List_Others; + when Tok_Identifier => + Res := Create_Iir_List; + loop + Append_Element (Res, Current_Text); + Scan; + exit when Current_Token /= Tok_Comma; + Expect (Tok_Comma); + Scan; + end loop; + return Res; + when others => + Error_Msg_Parse ("instantiation list expected"); + return Null_Iir_List; + end case; + end Parse_Instantiation_List; + + -- precond : next token + -- postcond: next token + -- + -- [ §5.2 ] + -- component_specification ::= instantiation_list : COMPONENT_name + procedure Parse_Component_Specification (Res : Iir) + is + List : Iir_List; + begin + List := Parse_Instantiation_List; + Set_Instantiation_List (Res, List); + Expect (Tok_Colon); + Scan_Expect (Tok_Identifier); + Set_Component_Name (Res, Parse_Name); + end Parse_Component_Specification; + + -- precond : next token + -- postcond: next token + -- + -- [ §5.2.1.1 ] + -- entity_aspect ::= ENTITY ENTITY_name [ ( ARCHITECTURE_identifier ) ] + -- | CONFIGURATION CONFIGURATION_name + -- | OPEN + function Parse_Entity_Aspect return Iir + is + Res : Iir; + begin + case Current_Token is + when Tok_Entity => + Res := Create_Iir (Iir_Kind_Entity_Aspect_Entity); + Set_Location (Res); + Scan_Expect (Tok_Identifier); + Set_Entity_Name (Res, Parse_Name (False)); + if Current_Token = Tok_Left_Paren then + Scan_Expect (Tok_Identifier); + Set_Architecture (Res, Current_Text); + Scan_Expect (Tok_Right_Paren); + Scan; + end if; + when Tok_Configuration => + Res := Create_Iir (Iir_Kind_Entity_Aspect_Configuration); + Set_Location (Res); + Scan_Expect (Tok_Identifier); + Set_Configuration_Name (Res, Parse_Name (False)); + when Tok_Open => + Res := Create_Iir (Iir_Kind_Entity_Aspect_Open); + Set_Location (Res); + Scan; + when others => + -- FIXME: if the token is an identifier, try as if the 'entity' + -- keyword is missing. + Error_Msg_Parse + ("'entity', 'configuration' or 'open' keyword expected"); + end case; + return Res; + end Parse_Entity_Aspect; + + -- precond : next token + -- postcond: next token + -- + -- [ §5.2.1 ] + -- binding_indication ::= + -- [ USE entity_aspect ] + -- [ generic_map_aspect ] + -- [ port_map_aspect ] + function Parse_Binding_Indication return Iir_Binding_Indication + is + Res : Iir_Binding_Indication; + begin + case Current_Token is + when Tok_Use + | Tok_Generic + | Tok_Port => + null; + when others => + return Null_Iir; + end case; + Res := Create_Iir (Iir_Kind_Binding_Indication); + Set_Location (Res); + if Current_Token = Tok_Use then + Scan; + Set_Entity_Aspect (Res, Parse_Entity_Aspect); + end if; + if Current_Token = Tok_Generic then + Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); + end if; + if Current_Token = Tok_Port then + Set_Port_Map_Aspect_Chain (Res, Parse_Port_Map_Aspect); + end if; + return Res; + end Parse_Binding_Indication; + + -- precond : ':' after instantiation_list. + -- postcond: ';' + -- + -- [ §1.3.2 ] + -- component_configuration ::= + -- FOR component_specification + -- [ binding_indication ; ] + -- [ block_configuration ] + -- END FOR ; + function Parse_Component_Configuration (Loc : Location_Type; + Inst_List : Iir_List) + return Iir_Component_Configuration + is + Res : Iir_Component_Configuration; + begin + Res := Create_Iir (Iir_Kind_Component_Configuration); + Set_Location (Res, Loc); + + -- Component specification. + Set_Instantiation_List (Res, Inst_List); + Expect (Tok_Colon); + Scan_Expect (Tok_Identifier); + Set_Component_Name (Res, Parse_Name); + + case Current_Token is + when Tok_Use + | Tok_Generic + | Tok_Port => + Set_Binding_Indication (Res, Parse_Binding_Indication); + Scan_Semi_Colon ("binding indication"); + when others => + null; + end case; + if Current_Token = Tok_For then + Set_Block_Configuration (Res, Parse_Block_Configuration); + -- Eat ';'. + Scan; + end if; + Expect (Tok_End); + Scan_Expect (Tok_For); + Scan_Expect (Tok_Semi_Colon); + return Res; + end Parse_Component_Configuration; + + -- precond : FOR + -- postcond: ';' + -- + -- [ §1.3.1 ] + -- block_configuration ::= + -- FOR block_specification + -- { use_clause } + -- { configuration_item } + -- END FOR ; + -- + -- [ §1.3.1 ] + -- block_specification ::= + -- ARCHITECTURE_name + -- | BLOCK_STATEMENT_label + -- | GENERATE_STATEMENT_label [ ( index_specification ) ] + function Parse_Block_Configuration_Suffix (Loc : Location_Type; + Block_Spec : Iir) + return Iir + is + Res : Iir_Block_Configuration; + begin + Res := Create_Iir (Iir_Kind_Block_Configuration); + Set_Location (Res, Loc); + + Set_Block_Specification (Res, Block_Spec); + + -- Parse use clauses. + if Current_Token = Tok_Use then + declare + Last : Iir; + use Declaration_Chain_Handling; + begin + Build_Init (Last); + + while Current_Token = Tok_Use loop + Append_Subchain (Last, Res, Parse_Use_Clause); + -- Eat ';'. + Scan; + end loop; + end; + end if; + + -- Parse configuration item list + declare + use Iir_Chains.Configuration_Item_Chain_Handling; + Last : Iir; + begin + Build_Init (Last); + while Current_Token /= Tok_End loop + Append (Last, Res, Parse_Configuration_Item); + -- Eat ';'. + Scan; + end loop; + end; + Scan_Expect (Tok_For); + Scan_Expect (Tok_Semi_Colon); + return Res; + end Parse_Block_Configuration_Suffix; + + function Parse_Block_Configuration return Iir_Block_Configuration + is + Loc : Location_Type; + begin + Loc := Get_Token_Location; + Expect (Tok_For); + + -- Parse label. + Scan; + return Parse_Block_Configuration_Suffix (Loc, Parse_Name); + end Parse_Block_Configuration; + + -- precond : FOR + -- postcond: ';' + -- + -- [ §1.3.1 ] + -- configuration_item ::= block_configuration + -- | component_configuration + function Parse_Configuration_Item return Iir + is + Loc : Location_Type; + List : Iir_List; + El : Iir; + begin + Loc := Get_Token_Location; + Expect (Tok_For); + Scan; + + -- ALL and OTHERS are tokens from an instantiation list. + -- Thus, the rule is a component_configuration. + case Current_Token is + when Tok_All => + Scan; + return Parse_Component_Configuration (Loc, Iir_List_All); + when Tok_Others => + Scan; + return Parse_Component_Configuration (Loc, Iir_List_Others); + when Tok_Identifier => + El := Current_Text; + Scan; + case Current_Token is + when Tok_Colon => + -- The identifier was a label from an instantiation list. + List := Create_Iir_List; + Append_Element (List, El); + return Parse_Component_Configuration (Loc, List); + when Tok_Comma => + -- The identifier was a label from an instantiation list. + List := Create_Iir_List; + Append_Element (List, El); + loop + Scan_Expect (Tok_Identifier); + Append_Element (List, Current_Text); + Scan; + exit when Current_Token /= Tok_Comma; + end loop; + return Parse_Component_Configuration (Loc, List); + when Tok_Left_Paren => + El := Parse_Name_Suffix (El); + return Parse_Block_Configuration_Suffix (Loc, El); + when Tok_Use | Tok_For | Tok_End => + -- Possibilities for a block_configuration. + -- FIXME: should use 'when others' ? + return Parse_Block_Configuration_Suffix (Loc, El); + when others => + Error_Msg_Parse + ("block_configuration or component_configuration " + & "expected"); + raise Parse_Error; + end case; + when others => + Error_Msg_Parse ("configuration item expected"); + raise Parse_Error; + end case; + end Parse_Configuration_Item; + + -- precond : next token + -- postcond: next token + -- + -- [§ 1.3] + -- configuration_declarative_part ::= { configuration_declarative_item } + -- + -- [§ 1.3] + -- configuration_declarative_item ::= use_clause + -- | attribute_specification + -- | group_declaration + -- FIXME: attribute_specification, group_declaration + procedure Parse_Configuration_Declarative_Part (Parent : Iir) + is + use Declaration_Chain_Handling; + Last : Iir; + El : Iir; + begin + Build_Init (Last); + loop + case Current_Token is + when Tok_Invalid => + raise Internal_Error; + when Tok_Use => + Append_Subchain (Last, Parent, Parse_Use_Clause); + when Tok_Attribute => + El := Parse_Attribute; + if El /= Null_Iir then + if Get_Kind (El) /= Iir_Kind_Attribute_Specification then + Error_Msg_Parse + ("attribute declaration not allowed here"); + end if; + Append (Last, Parent, El); + end if; + when Tok_Group => + El := Parse_Group; + if El /= Null_Iir then + if Get_Kind (El) /= Iir_Kind_Group_Declaration then + Error_Msg_Parse + ("group template declaration not allowed here"); + end if; + Append (Last, Parent, El); + end if; + when others => + exit; + end case; + Scan; + end loop; + end Parse_Configuration_Declarative_Part; + + -- precond : CONFIGURATION + -- postcond: ';' + -- + -- [ LRM93 1.3 ] + -- configuration_declaration ::= + -- CONFIGURATION identifier OF ENTITY_name IS + -- configuration_declarative_part + -- block_configuration + -- END [ CONFIGURATION ] [ CONFIGURATION_simple_name ] ; + -- + -- [ LRM93 1.3 ] + -- configuration_declarative_part ::= { configuration_declarative_item } + procedure Parse_Configuration_Declaration (Unit : Iir_Design_Unit) + is + Res : Iir_Configuration_Declaration; + begin + if Current_Token /= Tok_Configuration then + raise Program_Error; + end if; + Res := Create_Iir (Iir_Kind_Configuration_Declaration); + + -- Get identifier. + Scan_Expect (Tok_Identifier); + Set_Identifier (Res, Current_Identifier); + Set_Location (Res); + + -- Skip identifier. + Scan_Expect (Tok_Of); + + -- Skip 'of'. + Scan; + + Set_Entity_Name (Res, Parse_Name (False)); + + -- Skip 'is'. + Expect (Tok_Is); + Scan; + + Parse_Configuration_Declarative_Part (Res); + + Set_Block_Configuration (Res, Parse_Block_Configuration); + + Scan_Expect (Tok_End); + Set_End_Location (Unit); + + -- Skip 'end'. + Scan; + + if Current_Token = Tok_Configuration then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("'configuration' keyword not allowed here by vhdl 87"); + end if; + Set_End_Has_Reserved_Id (Res, True); + + -- Skip 'configuration'. + Scan; + end if; + + -- LRM93 1.3 + -- If a simple name appears at the end of a configuration declaration, it + -- must repeat the identifier of the configuration declaration. + Check_End_Name (Res); + Expect (Tok_Semi_Colon); + Set_Library_Unit (Unit, Res); + end Parse_Configuration_Declaration; + + -- precond : generic + -- postcond: next token + -- + -- LRM08 4.7 + -- package_header ::= + -- [ generic_clause -- LRM08 6.5.6.2 + -- [ generic_map aspect ; ] ] + function Parse_Package_Header return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Package_Header); + Parse_Generic_Clause (Res); + + if Current_Token = Tok_Generic then + Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); + Scan_Semi_Colon ("generic map aspect"); + end if; + return Res; + end Parse_Package_Header; + + -- precond : token (after 'IS') + -- postcond: ';' + -- + -- [ LRM93 2.5, LRM08 4.7 ] + -- package_declaration ::= + -- PACKAGE identifier IS + -- package_header -- LRM08 + -- package_declarative_part + -- END [ PACKAGE ] [ PACKAGE_simple_name ] ; + procedure Parse_Package_Declaration + (Unit : Iir_Design_Unit; Id : Name_Id; Loc : Location_Type) + is + Res: Iir_Package_Declaration; + begin + Res := Create_Iir (Iir_Kind_Package_Declaration); + Set_Location (Res, Loc); + Set_Identifier (Res, Id); + + if Current_Token = Tok_Generic then + if Vhdl_Std < Vhdl_08 then + Error_Msg_Parse ("generic packages not allowed before vhdl 2008"); + end if; + Set_Package_Header (Res, Parse_Package_Header); + end if; + + Parse_Declarative_Part (Res); + + Expect (Tok_End); + Set_End_Location (Unit); + + -- Skip 'end' + Scan; + + if Current_Token = Tok_Package then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'package' keyword not allowed here by vhdl 87"); + end if; + Set_End_Has_Reserved_Id (Res, True); + + -- Skip 'package'. + Scan; + end if; + + Check_End_Name (Res); + Expect (Tok_Semi_Colon); + Set_Library_Unit (Unit, Res); + end Parse_Package_Declaration; + + -- precond : BODY + -- postcond: ';' + -- + -- [ LRM93 2.6, LRM08 4.8 ] + -- package_body ::= + -- PACKAGE BODY PACKAGE_simple_name IS + -- package_body_declarative_part + -- END [ PACKAGE BODY ] [ PACKAGE_simple_name ] ; + procedure Parse_Package_Body (Unit : Iir_Design_Unit) + is + Res: Iir; + begin + Res := Create_Iir (Iir_Kind_Package_Body); + Set_Location (Res); + + -- Get identifier. + Expect (Tok_Identifier); + Set_Identifier (Res, Current_Identifier); + Scan_Expect (Tok_Is); + Scan; + + Parse_Declarative_Part (Res); + + Expect (Tok_End); + Set_End_Location (Unit); + + -- Skip 'end' + Scan; + + if Current_Token = Tok_Package then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'package' keyword not allowed here by vhdl 87"); + end if; + Set_End_Has_Reserved_Id (Res, True); + + -- Skip 'package' + Scan; + + if Current_Token /= Tok_Body then + Error_Msg_Parse ("missing 'body' after 'package'"); + else + -- Skip 'body' + Scan; + end if; + end if; + + Check_End_Name (Res); + Expect (Tok_Semi_Colon); + Set_Library_Unit (Unit, Res); + end Parse_Package_Body; + + -- precond : NEW + -- postcond: ';' + -- + -- [ LRM08 4.9 ] + -- package_instantiation_declaration ::= + -- PACKAGE identifier IS NEW uninstantiated_package_name + -- [ generic_map_aspect ] ; + function Parse_Package_Instantiation_Declaration + (Id : Name_Id; Loc : Location_Type) + return Iir + is + Res: Iir; + begin + Res := Create_Iir (Iir_Kind_Package_Instantiation_Declaration); + Set_Location (Res, Loc); + Set_Identifier (Res, Id); + + -- Skip 'new' + Scan; + + Set_Uninstantiated_Package_Name (Res, Parse_Name (False)); + + if Current_Token = Tok_Generic then + Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); + end if; + + Expect (Tok_Semi_Colon); + + return Res; + end Parse_Package_Instantiation_Declaration; + + -- precond : PACKAGE + -- postcond: ';' + -- + -- package_declaration + -- | package_body + -- | package_instantiation_declaration + procedure Parse_Package (Unit : Iir_Design_Unit) + is + Loc : Location_Type; + Id : Name_Id; + begin + -- Skip 'package' + Scan; + + if Current_Token = Tok_Body then + -- Skip 'body' + Scan; + + Parse_Package_Body (Unit); + else + Expect (Tok_Identifier); + Id := Current_Identifier; + Loc := Get_Token_Location; + + -- Skip identifier. + Scan; + + -- Skip 'is'. + Expect (Tok_Is); + Scan; + + if Current_Token = Tok_New then + Set_Library_Unit + (Unit, + Parse_Package_Instantiation_Declaration (Id, Loc)); + -- Note: there is no 'end' in instantiation. + Set_End_Location (Unit, Get_Token_Location); + else + Parse_Package_Declaration (Unit, Id, Loc); + end if; + end if; + end Parse_Package; + + -- Parse a design_unit. + -- The lexical scanner must have been initialized, but without a + -- current_token. + -- + -- [ §11.1 ] + -- design_unit ::= context_clause library_unit + -- + -- [ §11.3 ] + -- context_clause ::= { context_item } + -- + -- [ §11.3 ] + -- context_item ::= library_clause | use_clause + function Parse_Design_Unit return Iir_Design_Unit + is + Res: Iir_Design_Unit; + Unit: Iir; + begin + -- Internal check: there must be no current_token. + if Current_Token /= Tok_Invalid then + raise Internal_Error; + end if; + Scan; + if Current_Token = Tok_Eof then + return Null_Iir; + end if; + + -- Create the design unit node. + Res := Create_Iir (Iir_Kind_Design_Unit); + Set_Location (Res); + Set_Date_State (Res, Date_Extern); + + -- Parse context clauses + declare + use Context_Items_Chain_Handling; + Last : Iir; + Els : Iir; + begin + Build_Init (Last); + + loop + case Current_Token is + when Tok_Library => + Els := Parse_Library_Clause; + when Tok_Use => + Els := Parse_Use_Clause; + Scan; + when Tok_With => + -- Be Ada friendly. + Error_Msg_Parse ("'with' not allowed in context clause " + & "(try 'use' or 'library')"); + Els := Parse_Use_Clause; + Scan; + when others => + exit; + end case; + Append_Subchain (Last, Res, Els); + end loop; + end; + + -- Parse library unit + case Current_Token is + when Tok_Entity => + Parse_Entity_Declaration (Res); + when Tok_Architecture => + Parse_Architecture_Body (Res); + when Tok_Package => + Parse_Package (Res); + when Tok_Configuration => + Parse_Configuration_Declaration (Res); + when others => + Error_Msg_Parse ("entity, architecture, package or configuration " + & "keyword expected"); + return Null_Iir; + end case; + Unit := Get_Library_Unit (Res); + Set_Design_Unit (Unit, Res); + Set_Identifier (Res, Get_Identifier (Unit)); + Set_Date (Res, Date_Parsed); + Invalidate_Current_Token; + return Res; + exception + when Expect_Error => + raise Compilation_Error; + end Parse_Design_Unit; + + -- [ §11.1 ] + -- design_file ::= design_unit { design_unit } + function Parse_Design_File return Iir_Design_File + is + Res : Iir_Design_File; + Design, Last_Design : Iir_Design_Unit; + begin + Res := Create_Iir (Iir_Kind_Design_File); + Set_Location (Res); + + Last_Design := Null_Iir; + loop + Design := Parse.Parse_Design_Unit; + exit when Design = Null_Iir; + Set_Design_File (Design, Res); + if Last_Design = Null_Iir then + Set_First_Design_Unit (Res, Design); + else + Set_Chain (Last_Design, Design); + end if; + Last_Design := Design; + Set_Last_Design_Unit (Res, Last_Design); + end loop; + if Last_Design = Null_Iir then + Error_Msg_Parse ("design file is empty (no design unit found)"); + end if; + return Res; + exception + when Parse_Error => + return Null_Iir; + end Parse_Design_File; +end Parse; diff --git a/src/vhdl/parse.ads b/src/vhdl/parse.ads new file mode 100644 index 000000000..26bdef3ec --- /dev/null +++ b/src/vhdl/parse.ads @@ -0,0 +1,44 @@ +-- VHDL parser. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +package Parse is + -- If True, create nodes for parenthesis expressions. + Flag_Parse_Parenthesis : Boolean := False; + + -- Parse an expression. + -- (Used by PSL). + function Parse_Expression return Iir; + function Parse_Expression_Rhs (Left : Iir) return Iir; + + -- Parse an relationnal operator and its rhs. + function Parse_Relation_Rhs (Left : Iir) return Iir; + + -- Parse a single design unit. + -- The scanner must have been initialized, however, the current_token + -- shouldn't have been set. + -- At return, the last token accepted is the semi_colon that terminates + -- the library unit. + -- Return Null_Iir when end of file. + function Parse_Design_Unit return Iir_Design_Unit; + + -- Parse a file. + -- The scanner must habe been initialized as for parse_design_unit. + -- Return Null_Iir in case of error. + function Parse_Design_File return Iir_Design_File; +end Parse; diff --git a/src/vhdl/parse_psl.adb b/src/vhdl/parse_psl.adb new file mode 100644 index 000000000..7cb20ca3b --- /dev/null +++ b/src/vhdl/parse_psl.adb @@ -0,0 +1,667 @@ +-- VHDL PSL parser. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with PSL.Nodes; use PSL.Nodes; +with Iirs; +with Scanner; use Scanner; +with PSL.Errors; use PSL.Errors; +with PSL.Priorities; use PSL.Priorities; +with Parse; + +package body Parse_Psl is + function Create_Node_Loc (K : Nkind) return Node is + Res : Node; + begin + Res := PSL.Nodes.Create_Node (K); + Set_Location (Res, Get_Token_Location); + return Res; + end Create_Node_Loc; + + function Parse_Number return Node is + Res : Node; + begin + if Current_Token = Tok_Integer then + Res := Create_Node_Loc (N_Number); + -- FIXME: handle overflow. + Set_Value (Res, Uns32 (Current_Iir_Int64)); + Scan; + return Res; + elsif Current_Token = Tok_Inf then + -- FIXME: create node + Scan; + return Null_Node; + else + Error_Msg_Parse ("number expected"); + return Null_Node; + end if; + end Parse_Number; + + procedure Parse_Count (N : Node) is + begin + Set_Low_Bound (N, Parse_Number); + if Current_Token = Tok_To then + Scan; + Set_High_Bound (N, Parse_Number); + end if; + end Parse_Count; + + function Psl_To_Vhdl (N : Node) return Iirs.Iir + is + use Iirs; + Res : Iir; + begin + case Get_Kind (N) is + when N_HDL_Expr => + Res := Iirs.Iir (Get_HDL_Node (N)); + Free_Node (N); + return Res; + when others => + Error_Kind ("psl_to_vhdl", N); + end case; + end Psl_To_Vhdl; + + function Vhdl_To_Psl (N : Iirs.Iir) return Node + is + Res : Node; + begin + Res := Create_Node_Loc (N_HDL_Expr); + Set_Location (Res, Iirs.Get_Location (N)); + Set_HDL_Node (Res, Int32 (N)); + return Res; + end Vhdl_To_Psl; + + function Parse_FL_Property (Prio : Priority) return Node; + function Parse_Sequence return Node; + + function Parse_Parenthesis_Boolean return Node; + function Parse_Boolean (Parent_Prio : Priority) return Node; + + function Parse_Unary_Boolean return Node is + begin + return Vhdl_To_Psl (Parse.Parse_Expression); + end Parse_Unary_Boolean; + + function Parse_Boolean_Rhs (Parent_Prio : Priority; Left : Node) return Node + is + Kind : Nkind; + Prio : Priority; + Res : Node; + Tmp : Node; + begin + Res := Left; + loop + case Current_Token is + when Tok_And => + Kind := N_And_Bool; + Prio := Prio_Seq_And; + when Tok_Or => + Kind := N_Or_Bool; + Prio := Prio_Seq_Or; + when others => + return Res; + end case; + if Parent_Prio >= Prio then + return Res; + end if; + Tmp := Create_Node_Loc (Kind); + Scan; + Set_Left (Tmp, Res); + Res := Tmp; + Tmp := Parse_Boolean (Prio); + Set_Right (Res, Tmp); + end loop; + end Parse_Boolean_Rhs; + + function Parse_Boolean (Parent_Prio : Priority) return Node + is + begin + return Parse_Boolean_Rhs (Parent_Prio, Parse_Unary_Boolean); + end Parse_Boolean; + + function Parse_Psl_Boolean return PSL_Node is + begin + return Parse_Boolean (Prio_Lowest); + end Parse_Psl_Boolean; + + function Parse_Parenthesis_Boolean return Node is + Res : Node; + begin + if Current_Token /= Tok_Left_Paren then + Error_Msg_Parse ("'(' expected before boolean expression"); + return Null_Node; + else + Scan; + Res := Parse_Psl_Boolean; + if Current_Token = Tok_Right_Paren then + Scan; + else + Error_Msg_Parse ("missing matching ')' for boolean expression"); + end if; + return Res; + end if; + end Parse_Parenthesis_Boolean; + + function Parse_SERE (Prio : Priority) return Node is + Left, Res : Node; + Kind : Nkind; + Op_Prio : Priority; + begin + Left := Parse_Sequence; -- FIXME: allow boolean; + loop + case Current_Token is + when Tok_Semi_Colon => + Kind := N_Concat_SERE; + Op_Prio := Prio_Seq_Concat; + when Tok_Colon => + Kind := N_Fusion_SERE; + Op_Prio := Prio_Seq_Fusion; + when Tok_Within => + Kind := N_Within_SERE; + Op_Prio := Prio_Seq_Within; + when Tok_Ampersand => + -- For non-length matching and, the operator is '&'. + Kind := N_And_Seq; + Op_Prio := Prio_Seq_And; + when Tok_And_And => + Kind := N_Match_And_Seq; + Op_Prio := Prio_Seq_And; + when Tok_Bar => + Kind := N_Or_Seq; + Op_Prio := Prio_Seq_Or; +-- when Tok_Bar_Bar => +-- Res := Create_Node_Loc (N_Or_Bool); +-- Scan; +-- Set_Left (Res, Left); +-- Set_Right (Res, Parse_Boolean (Prio_Seq_Or)); +-- return Res; + when others => + return Left; + end case; + if Prio >= Op_Prio then + return Left; + end if; + Res := Create_Node_Loc (Kind); + Scan; + Set_Left (Res, Left); + Set_Right (Res, Parse_SERE (Op_Prio)); + Left := Res; + end loop; + end Parse_SERE; + + -- precond: '{' + function Parse_Braced_SERE return Node is + Res : Node; + begin + if Current_Token /= Tok_Left_Curly then + raise Program_Error; + end if; + Res := Create_Node_Loc (N_Braced_SERE); + Scan; + Set_SERE (Res, Parse_SERE (Prio_Lowest)); + if Current_Token /= Tok_Right_Curly then + Error_Msg_Parse ("missing '}' after braced SERE"); + else + Scan; + end if; + return Res; + end Parse_Braced_SERE; + + -- Parse [ Count ] ']' + function Parse_Maybe_Count (Kind : Nkind; Seq : Node) return Node is + N : Node; + begin + N := Create_Node_Loc (Kind); + Set_Sequence (N, Seq); + Scan; + if Current_Token /= Tok_Right_Bracket then + Parse_Count (N); + end if; + if Current_Token /= Tok_Right_Bracket then + Error_Msg_Parse ("missing ']'"); + else + Scan; + end if; + return N; + end Parse_Maybe_Count; + + procedure Parse_Bracket_Range (N : Node) is + begin + if Current_Token /= Tok_Left_Bracket then + Error_Msg_Parse ("'[' expected"); + else + Scan; + Set_Low_Bound (N, Parse_Number); + if Current_Token /= Tok_To then + Error_Msg_Parse ("'to' expected in range after left bound"); + else + Scan; + Set_High_Bound (N, Parse_Number); + end if; + if Current_Token /= Tok_Right_Bracket then + Error_Msg_Parse ("']' expected after range"); + else + Scan; + end if; + end if; + end Parse_Bracket_Range; + + function Parse_Bracket_Number return Node is + Res : Node; + begin + if Current_Token /= Tok_Left_Bracket then + Error_Msg_Parse ("'[' expected"); + return Null_Node; + else + Scan; + Res := Parse_Number; + if Current_Token /= Tok_Right_Bracket then + Error_Msg_Parse ("']' expected after range"); + else + Scan; + end if; + return Res; + end if; + end Parse_Bracket_Number; + + function Parse_Sequence return Node is + Res, N : Node; + begin + case Current_Token is + when Tok_Left_Curly => + Res := Parse_Braced_SERE; + when Tok_Brack_Star => + return Parse_Maybe_Count (N_Star_Repeat_Seq, Null_Node); + when Tok_Left_Paren => + Res := Parse_Parenthesis_Boolean; + if Current_Token = Tok_Or + or else Current_Token = Tok_And + then + Res := Parse_Boolean_Rhs (Prio_Lowest, Res); + end if; + when Tok_Brack_Plus_Brack => + Res := Create_Node_Loc (N_Plus_Repeat_Seq); + Scan; + return Res; + when others => + -- Repeated_SERE + Res := Parse_Unary_Boolean; + end case; + loop + case Current_Token is + when Tok_Brack_Star => + Res := Parse_Maybe_Count (N_Star_Repeat_Seq, Res); + when Tok_Brack_Plus_Brack => + N := Create_Node_Loc (N_Plus_Repeat_Seq); + Set_Sequence (N, Res); + Scan; + Res := N; + when Tok_Brack_Arrow => + Res := Parse_Maybe_Count (N_Goto_Repeat_Seq, Res); + when Tok_Brack_Equal => + N := Create_Node_Loc (N_Equal_Repeat_Seq); + Set_Sequence (N, Res); + Scan; + Parse_Count (N); + if Current_Token /= Tok_Right_Bracket then + Error_Msg_Parse ("missing ']'"); + else + Scan; + end if; + Res := N; + when others => + return Res; + end case; + end loop; + end Parse_Sequence; + + -- precond: '(' + -- postcond: next token + function Parse_Parenthesis_FL_Property return Node is + Res : Node; + Loc : Location_Type; + begin + Loc := Get_Token_Location; + if Current_Token /= Tok_Left_Paren then + Error_Msg_Parse ("'(' expected around property"); + return Parse_FL_Property (Prio_Lowest); + else + Scan; + Res := Parse_FL_Property (Prio_Lowest); + if Current_Token /= Tok_Right_Paren then + Error_Msg_Parse ("missing matching ')' for '(' at line " + & Get_Location_Str (Loc, False)); + else + Scan; + end if; + return Res; + end if; + end Parse_Parenthesis_FL_Property; + + -- Parse [ '!' ] '[' finite_Range ']' '(' FL_Property ')' + function Parse_Range_Property (K : Nkind) return Node is + Res : Node; + begin + Res := Create_Node_Loc (K); + Set_Strong_Flag (Res, Scan_Exclam_Mark); + Scan; + Parse_Bracket_Range (Res); + Set_Property (Res, Parse_Parenthesis_FL_Property); + return Res; + end Parse_Range_Property; + + -- Parse [ '!' ] '(' Boolean ')' '[' Range ']' '(' FL_Property ')' + function Parse_Boolean_Range_Property (K : Nkind) return Node is + Res : Node; + begin + Res := Create_Node_Loc (K); + Set_Strong_Flag (Res, Scan_Exclam_Mark); + Scan; + Set_Boolean (Res, Parse_Parenthesis_Boolean); + Parse_Bracket_Range (Res); + Set_Property (Res, Parse_Parenthesis_FL_Property); + return Res; + end Parse_Boolean_Range_Property; + + function Parse_FL_Property_1 return Node + is + Res : Node; + Tmp : Node; + begin + case Current_Token is + when Tok_Always => + Res := Create_Node_Loc (N_Always); + Scan; + Set_Property (Res, Parse_FL_Property (Prio_FL_Invariance)); + when Tok_Never => + Res := Create_Node_Loc (N_Never); + Scan; + Set_Property (Res, Parse_FL_Property (Prio_FL_Invariance)); + when Tok_Eventually => + Res := Create_Node_Loc (N_Eventually); + if not Scan_Exclam_Mark then + Error_Msg_Parse ("'eventually' must be followed by '!'"); + end if; + Scan; + Set_Property (Res, Parse_FL_Property (Prio_FL_Occurence)); + when Tok_Next => + Res := Create_Node_Loc (N_Next); + Scan; + if Current_Token = Tok_Left_Bracket then + Set_Number (Res, Parse_Bracket_Number); + Set_Property (Res, Parse_Parenthesis_FL_Property); + else + Set_Property (Res, Parse_FL_Property (Prio_FL_Occurence)); + end if; + when Tok_Next_A => + Res := Parse_Range_Property (N_Next_A); + when Tok_Next_E => + Res := Parse_Range_Property (N_Next_E); + when Tok_Next_Event => + Res := Create_Node_Loc (N_Next_Event); + Scan; + Set_Boolean (Res, Parse_Parenthesis_Boolean); + if Current_Token = Tok_Left_Bracket then + Set_Number (Res, Parse_Bracket_Number); + end if; + Set_Property (Res, Parse_Parenthesis_FL_Property); + when Tok_Next_Event_A => + Res := Parse_Boolean_Range_Property (N_Next_Event_A); + when Tok_Next_Event_E => + Res := Parse_Boolean_Range_Property (N_Next_Event_E); + when Tok_Left_Paren => + return Parse_Parenthesis_FL_Property; + when Tok_Left_Curly => + Res := Parse_Sequence; + if Get_Kind (Res) = N_Braced_SERE + and then Current_Token = Tok_Left_Paren + then + -- FIXME: must check that RES is really a sequence + -- (and not a SERE). + Tmp := Create_Node_Loc (N_Overlap_Imp_Seq); + Set_Sequence (Tmp, Res); + Set_Property (Tmp, Parse_Parenthesis_FL_Property); + Res := Tmp; + end if; + when others => + Res := Parse_Sequence; + end case; + return Res; + end Parse_FL_Property_1; + + function Parse_St_Binary_FL_Property (K : Nkind; Left : Node) return Node is + Res : Node; + begin + Res := Create_Node_Loc (K); + Set_Strong_Flag (Res, Scan_Exclam_Mark); + Set_Inclusive_Flag (Res, Scan_Underscore); + Scan; + Set_Left (Res, Left); + Set_Right (Res, Parse_FL_Property (Prio_FL_Bounding)); + return Res; + end Parse_St_Binary_FL_Property; + + function Parse_Binary_FL_Property (K : Nkind; Left : Node; Prio : Priority) + return Node + is + Res : Node; + begin + Res := Create_Node_Loc (K); + Scan; + Set_Left (Res, Left); + Set_Right (Res, Parse_FL_Property (Prio)); + return Res; + end Parse_Binary_FL_Property; + + function Parse_FL_Property (Prio : Priority) return Node + is + Res : Node; + N : Node; + begin + Res := Parse_FL_Property_1; + loop + case Current_Token is + when Tok_Minus_Greater => + if Prio > Prio_Bool_Imp then + return Res; + end if; + N := Create_Node_Loc (N_Log_Imp_Prop); + Set_Left (N, Res); + Scan; + Set_Right (N, Parse_FL_Property (Prio_Bool_Imp)); + Res := N; + when Tok_Bar_Arrow => + if Prio > Prio_Seq_Imp then + return Res; + end if; + N := Create_Node_Loc (N_Overlap_Imp_Seq); + Set_Sequence (N, Res); + Scan; + Set_Property (N, Parse_FL_Property (Prio_Seq_Imp)); + Res := N; + when Tok_Bar_Double_Arrow => + if Prio > Prio_Seq_Imp then + return Res; + end if; + N := Create_Node_Loc (N_Imp_Seq); + Set_Sequence (N, Res); + Scan; + Set_Property (N, Parse_FL_Property (Prio_Seq_Imp)); + Res := N; + when Tok_Abort => + if Prio > Prio_FL_Abort then + return Res; + end if; + N := Create_Node_Loc (N_Abort); + Set_Property (N, Res); + Scan; + Set_Boolean (N, Parse_Boolean (Prio_Lowest)); + -- Left associative. + return N; + when Tok_Exclam_Mark => + N := Create_Node_Loc (N_Strong); + Set_Property (N, Res); + Scan; + Res := N; + when Tok_Until => + if Prio > Prio_FL_Bounding then + return Res; + end if; + Res := Parse_St_Binary_FL_Property (N_Until, Res); + when Tok_Before => + if Prio > Prio_FL_Bounding then + return Res; + end if; + Res := Parse_St_Binary_FL_Property (N_Before, Res); + when Tok_Or => + if Prio > Prio_Seq_Or then + return Res; + end if; + Res := Parse_Binary_FL_Property (N_Or_Prop, Res, Prio_Seq_Or); + when Tok_And => + if Prio > Prio_Seq_And then + return Res; + end if; + Res := Parse_Binary_FL_Property (N_And_Prop, Res, Prio_Seq_And); + when Token_Relational_Operator_Type => + return Vhdl_To_Psl + (Parse.Parse_Relation_Rhs (Psl_To_Vhdl (Res))); + when Tok_Colon + | Tok_Bar + | Tok_Ampersand + | Tok_And_And => + Error_Msg_Parse ("SERE operator '" & Image (Current_Token) + & "' is not allowed in property"); + Scan; + N := Parse_FL_Property (Prio_Lowest); + return Res; + when Tok_Arobase => + if Prio > Prio_Clock_Event then + return Res; + end if; + N := Create_Node_Loc (N_Clock_Event); + Set_Property (N, Res); + Scan; + Set_Boolean (N, Parse_Boolean (Prio_Clock_Event)); + Res := N; + when others => + return Res; + end case; + end loop; + end Parse_FL_Property; + + function Parse_Psl_Property return PSL_Node is + begin + return Parse_FL_Property (Prio_Lowest); + end Parse_Psl_Property; + + -- precond: identifier + -- postcond: ';' + -- + -- 6.2.4.1 Property declaration + -- + -- Property_Declaration ::= + -- PROPERTY psl_identifier [ ( Formal_Parameter_List ) ] DEF_SYM + -- property ; + function Parse_Psl_Declaration (Tok : Token_Type) return PSL_Node + is + Res : Node; + Param : Node; + Last_Param : Node; + Pkind : Nkind; + Kind : Nkind; + begin + case Tok is + when Tok_Psl_Property => + Kind := N_Property_Declaration; + when Tok_Psl_Sequence => + Kind := N_Sequence_Declaration; + when Tok_Psl_Endpoint => + Kind := N_Endpoint_Declaration; + when others => + raise Internal_Error; + end case; + Res := Create_Node_Loc (Kind); + if Current_Token = Tok_Identifier then + Set_Identifier (Res, Current_Identifier); + Scan; + end if; + + -- Formal parameter list. + if Current_Token = Tok_Left_Paren then + Last_Param := Null_Node; + loop + -- precond: '(' or ';'. + Scan; + case Current_Token is + when Tok_Psl_Const => + Pkind := N_Const_Parameter; + when Tok_Psl_Boolean => + Pkind := N_Boolean_Parameter; + when Tok_Psl_Property => + Pkind := N_Property_Parameter; + when Tok_Psl_Sequence => + Pkind := N_Sequence_Parameter; + when others => + Error_Msg_Parse ("parameter type expected"); + end case; + + -- Formal parameters. + loop + -- precond: parameter_type or ',' + Scan; + Param := Create_Node_Loc (Pkind); + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("identifier for parameter expected"); + else + Set_Identifier (Param, Current_Identifier); + end if; + if Last_Param = Null_Node then + Set_Parameter_List (Res, Param); + else + Set_Chain (Last_Param, Param); + end if; + Last_Param := Param; + Scan; + exit when Current_Token /= Tok_Comma; + end loop; + exit when Current_Token = Tok_Right_Paren; + if Current_Token /= Tok_Semi_Colon then + Error_Msg_Parse ("';' expected between formal parameter"); + end if; + + end loop; + Scan; + end if; + + if Current_Token /= Tok_Is then + Error_Msg_Parse ("'is' expected after identifier"); + else + Scan; + end if; + case Kind is + when N_Property_Declaration => + Set_Property (Res, Parse_Psl_Property); + when N_Sequence_Declaration + | N_Endpoint_Declaration => + Set_Sequence (Res, Parse_Sequence); + when others => + raise Internal_Error; + end case; + return Res; + end Parse_Psl_Declaration; +end Parse_Psl; diff --git a/src/vhdl/parse_psl.ads b/src/vhdl/parse_psl.ads new file mode 100644 index 000000000..62869feb8 --- /dev/null +++ b/src/vhdl/parse_psl.ads @@ -0,0 +1,26 @@ +-- VHDL PSL parser. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with Tokens; use Tokens; + +package Parse_Psl is + function Parse_Psl_Property return PSL_Node; + function Parse_Psl_Boolean return PSL_Node; + function Parse_Psl_Declaration (Tok : Token_Type) return PSL_Node; +end Parse_Psl; diff --git a/src/vhdl/post_sems.adb b/src/vhdl/post_sems.adb new file mode 100644 index 000000000..78eda5015 --- /dev/null +++ b/src/vhdl/post_sems.adb @@ -0,0 +1,71 @@ +-- Global checks after semantization pass. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Std_Names; use Std_Names; +with Ieee.Std_Logic_1164; +with Ieee.Vital_Timing; +with Flags; use Flags; + +package body Post_Sems is + procedure Post_Sem_Checks (Unit : Iir_Design_Unit) + is + Lib_Unit : constant Iir := Get_Library_Unit (Unit); + Lib : Iir_Library_Declaration; + Id : Name_Id; + + Value : Iir_Attribute_Value; + Spec : Iir_Attribute_Specification; + Attr_Decl : Iir_Attribute_Declaration; + begin + -- No checks on package bodies. + if Get_Kind (Lib_Unit) = Iir_Kind_Package_Body then + return; + end if; + + Id := Get_Identifier (Lib_Unit); + Lib := Get_Library (Get_Design_File (Unit)); + + if Get_Identifier (Lib) = Name_Ieee then + -- This is a unit of IEEE. + if Get_Kind (Lib_Unit) = Iir_Kind_Package_Declaration then + if Id = Name_Std_Logic_1164 then + Ieee.Std_Logic_1164.Extract_Declarations (Lib_Unit); + elsif Id = Name_VITAL_Timing then + Ieee.Vital_Timing.Extract_Declarations (Lib_Unit); + end if; + end if; + end if; + + -- Look for VITAL attributes. + if Flag_Vital_Checks then + Value := Get_Attribute_Value_Chain (Lib_Unit); + while Value /= Null_Iir loop + Spec := Get_Attribute_Specification (Value); + Attr_Decl := Get_Named_Entity (Get_Attribute_Designator (Spec)); + if Attr_Decl = Ieee.Vital_Timing.Vital_Level0_Attribute then + Ieee.Vital_Timing.Check_Vital_Level0 (Unit); + elsif Attr_Decl = Ieee.Vital_Timing.Vital_Level1_Attribute then + Ieee.Vital_Timing.Check_Vital_Level1 (Unit); + end if; + + Value := Get_Chain (Value); + end loop; + end if; + end Post_Sem_Checks; +end Post_Sems; + diff --git a/src/vhdl/post_sems.ads b/src/vhdl/post_sems.ads new file mode 100644 index 000000000..ed042264e --- /dev/null +++ b/src/vhdl/post_sems.ads @@ -0,0 +1,25 @@ +-- Global checks after semantization pass. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +package Post_Sems is + -- Do post semantization checks, such as VITAL checks. + -- This procedure is also used to extract declarations from ieee + -- packages. + procedure Post_Sem_Checks (Unit : Iir_Design_Unit); +end Post_Sems; diff --git a/src/vhdl/psl-errors.ads b/src/vhdl/psl-errors.ads new file mode 100644 index 000000000..e99bb7de6 --- /dev/null +++ b/src/vhdl/psl-errors.ads @@ -0,0 +1,3 @@ +with Errorout; + +package PSL.Errors renames Errorout; diff --git a/src/vhdl/scanner-scan_literal.adb b/src/vhdl/scanner-scan_literal.adb new file mode 100644 index 000000000..74acf44d5 --- /dev/null +++ b/src/vhdl/scanner-scan_literal.adb @@ -0,0 +1,651 @@ +-- Lexical analysis for numbers. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Unchecked_Conversion; + +separate (Scanner) + +-- scan a decimal literal or a based literal. +-- +-- LRM93 13.4.1 +-- DECIMAL_LITERAL ::= INTEGER [ . INTEGER ] [ EXPONENT ] +-- EXPONENT ::= E [ + ] INTEGER | E - INTEGER +-- +-- LRM93 13.4.2 +-- BASED_LITERAL ::= BASE # BASED_INTEGER [ . BASED_INTEGER ] # EXPONENT +-- BASE ::= INTEGER +procedure Scan_Literal is + -- The base of an E_NUM is 2**16. + -- Type Uint16 is the type of a digit. + type Uint16 is mod 2 ** 16; + + type Uint32 is mod 2 ** 32; + + -- Type of the exponent. + type Sint16 is range -2 ** 15 .. 2 ** 15 - 1; + + -- Number of digits in a E_NUM. + -- We want at least 64bits of precision, so at least 5 digits of 16 bits + -- are required. + Nbr_Digits : constant Sint16 := 5; + subtype Digit_Range is Sint16 range 0 .. Nbr_Digits - 1; + + type Uint16_Array is array (Sint16 range <>) of Uint16; + + -- The value of an E_NUM is (S(N-1)|S(N-2) .. |S(0))* 2**(16*E) + -- where '|' is concatenation. + type E_Num is record + S : Uint16_Array (Digit_Range); + E : Sint16; + end record; + + E_Zero : constant E_Num := (S => (others => 0), E => 0); + E_One : constant E_Num := (S => (0 => 1, others => 0), E => 0); + + -- Compute RES = E * B + V. + -- RES and E can be the same object. + procedure Bmul (Res : out E_Num; E : E_Num; V : Uint16; B : Uint16); + + -- Convert to integer. + procedure Fix (Res : out Iir_Int64; Ok : out Boolean; E : E_Num); + + -- RES := A * B + -- RES can be A or B. + procedure Mul (Res : out E_Num; A, B : E_Num); + + -- RES := A / B. + -- RES can be A. + -- May raise constraint error. + procedure Div (Res : out E_Num; A, B: E_Num); + + -- Convert V to an E_Num. + function To_E_Num (V : Uint16) return E_Num; + + -- Convert E to RES. + procedure To_Float (Res : out Iir_Fp64; Ok : out Boolean; E : E_Num); + + procedure Bmul (Res : out E_Num; E : E_Num; V : Uint16; B : Uint16) + is + -- The carry. + C : Uint32; + begin + -- Only consider V if E is not scaled (otherwise V is not significant). + if E.E = 0 then + C := Uint32 (V); + else + C := 0; + end if; + + -- Multiply and propagate the carry. + for I in Digit_Range loop + C := Uint32 (E.S (I)) * Uint32 (B) + C; + Res.S (I) := Uint16 (C mod Uint16'Modulus); + C := C / Uint16'Modulus; + end loop; + + -- There is a carry, shift. + if C /= 0 then + -- ERR: Possible overflow. + Res.E := E.E + 1; + for I in 0 .. Nbr_Digits - 2 loop + Res.S (I) := Res.S (I + 1); + end loop; + Res.S (Nbr_Digits - 1) := Uint16 (C); + else + Res.E := E.E; + end if; + end Bmul; + + type Uint64 is mod 2 ** 64; + function Shift_Left (Value : Uint64; Amount: Natural) return Uint64; + function Shift_Left (Value : Uint16; Amount: Natural) return Uint16; + pragma Import (Intrinsic, Shift_Left); + + function Shift_Right (Value : Uint16; Amount: Natural) return Uint16; + pragma Import (Intrinsic, Shift_Right); + + function Unchecked_Conversion is new Ada.Unchecked_Conversion + (Source => Uint64, Target => Iir_Int64); + + procedure Fix (Res : out Iir_Int64; Ok : out Boolean; E : E_Num) + is + R : Uint64; + M : Sint16; + begin + -- Find the most significant digit. + M := -1; + for I in reverse Digit_Range loop + if E.S (I) /= 0 then + M := I; + exit; + end if; + end loop; + + -- Handle the easy 0 case. + -- The case M = -1 is handled below, in the normal flow. + if M + E.E < 0 then + Res := 0; + Ok := True; + return; + end if; + + -- Handle overflow. + -- 4 is the number of uint16 in a uint64. + if M + E.E >= 4 then + Ok := False; + return; + end if; + + -- Convert + R := 0; + for I in 0 .. M loop + R := R or Shift_Left (Uint64 (E.S (I)), 16 * Natural (E.E + I)); + end loop; + -- Check the sign bit is 0. + if (R and Shift_Left (1, 63)) /= 0 then + Ok := False; + else + Ok := True; + Res := Unchecked_Conversion (R); + end if; + end Fix; + + -- Return the position of the most non-null digit, -1 if V is 0. + function First_Digit (V : E_Num) return Sint16 is + begin + for I in reverse Digit_Range loop + if V.S (I) /= 0 then + return I; + end if; + end loop; + return -1; + end First_Digit; + + procedure Mul (Res : out E_Num; A, B : E_Num) + is + T : Uint16_Array (0 .. 2 * Nbr_Digits - 1); + V : Uint32; + Max : Sint16; + begin + V := 0; + for I in 0 .. Nbr_Digits - 1 loop + for J in 0 .. I loop + V := V + Uint32 (A.S (J)) * Uint32 (B.S (I - J)); + end loop; + T (I) := Uint16 (V mod Uint16'Modulus); + V := V / Uint16'Modulus; + end loop; + for I in Nbr_Digits .. 2 * Nbr_Digits - 2 loop + for J in I - Nbr_Digits + 1 .. Nbr_Digits - 1 loop + V := V + Uint32 (A.S (J)) * Uint32 (B.S (I - J)); + end loop; + T (I) := Uint16 (V mod Uint16'Modulus); + V := V / Uint16'Modulus; + end loop; + T (T'Last) := Uint16 (V); + -- Search the leading non-nul. + Max := -1; + for I in reverse T'Range loop + if T (I) /= 0 then + Max := I; + exit; + end if; + end loop; + if Max > Nbr_Digits - 1 then + -- Loss of precision. + -- Round. + if T (Max - Nbr_Digits) >= Uint16 (Uint16'Modulus / 2) then + V := 1; + for I in Max - (Nbr_Digits - 1) .. Max loop + V := V + Uint32 (T (I)); + T (I) := Uint16 (V mod Uint16'Modulus); + V := V / Uint16'Modulus; + exit when V = 0; + end loop; + if V /= 0 then + Max := Max + 1; + T (Max) := Uint16 (V); + end if; + end if; + Res.S := T (Max - (Nbr_Digits - 1) .. Max); + -- This may overflow. + Res.E := A.E + B.E + Max - (Nbr_Digits - 1); + else + Res.S (0 .. Max) := T (0 .. Max); + Res.S (Max + 1 .. Nbr_Digits - 1) := (others => 0); + -- This may overflow. + Res.E := A.E + B.E; + end if; + end Mul; + + procedure Div (Res : out E_Num; A, B: E_Num) + is + Dividend : Uint16_Array (0 .. Nbr_Digits); + A_F : constant Sint16 := First_Digit (A); + B_F : constant Sint16 := First_Digit (B); + + -- Digit corresponding to the first digit of B. + Doff : constant Sint16 := Dividend'Last - B_F; + Q : Uint16; + C, N_C : Uint16; + begin + -- Check for division by 0. + if B_F < 0 then + raise Constraint_Error; + end if; + + -- Copy and shift dividend. + -- Bit 15 of the most significant digit of A becomes bit 0 of the + -- most significant digit of DIVIDEND. Therefore we are sure + -- DIVIDEND < B (after realignment). + C := 0; + for K in 0 .. A_F loop + N_C := Shift_Right (A.S (K), 15); + Dividend (Dividend'Last - A_F - 1 + K) + := Shift_Left (A.S (K), 1) or C; + C := N_C; + end loop; + Dividend (Nbr_Digits) := C; + Dividend (0 .. Dividend'last - 2 - A_F) := (others => 0); + + -- Algorithm is the same as division by hand. + C := 0; + for I in reverse Digit_Range loop + Q := 0; + for J in 0 .. 15 loop + declare + Borrow : Uint32; + Tmp : Uint16_Array (0 .. B_F); + V : Uint32; + V16 : Uint16; + begin + -- Compute TMP := dividend - B; + Borrow := 0; + for K in 0 .. B_F loop + V := Uint32 (B.S (K)) + Borrow; + V16 := Uint16 (V mod Uint16'Modulus); + if V16 > Dividend (Doff + K) then + Borrow := 1; + else + Borrow := 0; + end if; + Tmp (K) := Dividend (Doff + K) - V16; + end loop; + + -- If the last shift creates a carry, we are sure Dividend > B + if C /= 0 then + Borrow := 0; + end if; + + Q := Q * 2; + -- Begin of : Dividend = Dividend * 2 + C := 0; + for K in 0 .. Doff - 1 loop + N_C := Shift_Right (Dividend (K), 15); + Dividend (K) := Shift_Left (Dividend (K), 1) or C; + C := N_C; + end loop; + + if Borrow = 0 then + -- Dividend > B + Q := Q + 1; + -- Dividend = Tmp * 2 + -- = (Dividend - B) * 2 + for K in Doff .. Nbr_Digits loop + N_C := Shift_Right (Tmp (K - Doff), 15); + Dividend (K) := Shift_Left (Tmp (K - Doff), 1) or C; + C := N_C; + end loop; + else + -- Dividend = Dividend * 2 + for K in Doff .. Nbr_Digits loop + N_C := Shift_Right (Dividend (K), 15); + Dividend (K) := Shift_Left (Dividend (K), 1) or C; + C := N_C; + end loop; + end if; + end; + end loop; + Res.S (I) := Q; + end loop; + Res.E := A.E - B.E + (A_F - B_F) - (Nbr_Digits - 1); + end Div; + + procedure To_Float (Res : out Iir_Fp64; Ok : out Boolean; E : E_Num) + is + V : Iir_Fp64; + P : Iir_Fp64; + begin + Res := 0.0; + P := Iir_Fp64'Scaling (1.0, 16 * E.E); + for I in Digit_Range loop + V := Iir_Fp64 (E.S (I)) * P; + P := Iir_Fp64'Scaling (P, 16); + Res := Res + V; + end loop; + Ok := True; + end To_Float; + + function To_E_Num (V : Uint16) return E_Num + is + Res : E_Num; + begin + Res.E := 0; + Res.S := (0 => V, others => 0); + return Res; + end To_E_Num; + + -- Numbers of digits. + Scale : Integer; + Res : E_Num; + + -- LRM 13.4.1 + -- INTEGER ::= DIGIT { [ UNDERLINE ] DIGIT } + -- + -- Update SCALE, RES. + -- The first character must be a digit. + procedure Scan_Integer + is + C : Character; + begin + C := Source (Pos); + loop + -- C is a digit. + Bmul (Res, Res, Character'Pos (C) - Character'Pos ('0'), 10); + Scale := Scale + 1; + + Pos := Pos + 1; + C := Source (Pos); + if C = '_' then + loop + Pos := Pos + 1; + C := Source (Pos); + exit when C /= '_'; + Error_Msg_Scan ("double underscore in number"); + end loop; + if C not in '0' .. '9' then + Error_Msg_Scan ("underscore must be followed by a digit"); + end if; + end if; + exit when C not in '0' .. '9'; + end loop; + end Scan_Integer; + + C : Character; + D : Uint16; + Ok : Boolean; + Has_Dot : Boolean; + Exp : Integer; + Exp_Neg : Boolean; + Base : Uint16; +begin + -- Start with a simple and fast conversion. + C := Source (Pos); + D := 0; + loop + D := D * 10 + Character'Pos (C) - Character'Pos ('0'); + + Pos := Pos + 1; + C := Source (Pos); + if C = '_' then + loop + Pos := Pos + 1; + C := Source (Pos); + exit when C /= '_'; + Error_Msg_Scan ("double underscore in number"); + end loop; + if C not in '0' .. '9' then + Error_Msg_Scan ("underscore must be followed by a digit"); + end if; + end if; + if C not in '0' .. '9' then + if C = '.' or else C = '#' or else (C = 'e' or C = 'E' or C = ':') + then + -- Continue scanning. + Res := To_E_Num (D); + exit; + end if; + + -- Finished. + -- a universal integer. + Current_Token := Tok_Integer; + -- No possible overflow. + Current_Context.Int64 := Iir_Int64 (D); + return; + elsif D >= 6552 then + -- Number may be greather than the uint16 limit. + Scale := 0; + Res := To_E_Num (D); + Scan_Integer; + exit; + end if; + end loop; + + Has_Dot := False; + Base := 10; + + C := Source (Pos); + if C = '.' then + -- Decimal integer. + Has_Dot := True; + Scale := 0; + Pos := Pos + 1; + C := Source (Pos); + if C not in '0' .. '9' then + Error_Msg_Scan ("a dot must be followed by a digit"); + return; + end if; + Scan_Integer; + elsif C = '#' + or else (C = ':' and then (Source (Pos + 1) in '0' .. '9' + or else Source (Pos + 1) in 'a' .. 'f' + or else Source (Pos + 1) in 'A' .. 'F')) + then + -- LRM 13.10 + -- The number sign (#) of a based literal can be replaced by colon (:), + -- provided that the replacement is done for both occurrences. + -- GHDL: correctly handle 'variable v : integer range 0 to 7:= 3'. + -- Is there any other places where a digit can be followed + -- by a colon ? (See IR 1093). + + -- Based integer. + declare + Number_Sign : constant Character := C; + Res_Int : Iir_Int64; + begin + Fix (Res_Int, Ok, Res); + if not Ok or else Res_Int > 16 then + -- LRM 13.4.2 + -- The base must be [...] at most sixteen. + Error_Msg_Scan ("base must be at most 16"); + -- Fallback. + Base := 16; + elsif Res_Int < 2 then + -- LRM 13.4.2 + -- The base must be at least two [...]. + Error_Msg_Scan ("base must be at least 2"); + -- Fallback. + Base := 2; + else + Base := Uint16 (Res_Int); + end if; + + Pos := Pos + 1; + Res := E_Zero; + C := Source (Pos); + loop + if C >= '0' and C <= '9' then + D := Character'Pos (C) - Character'Pos ('0'); + elsif C >= 'A' and C <= 'F' then + D := Character'Pos (C) - Character'Pos ('A') + 10; + elsif C >= 'a' and C <= 'f' then + D := Character'Pos (C) - Character'Pos ('a') + 10; + else + Error_Msg_Scan ("bad extended digit"); + exit; + end if; + + if D >= Base then + -- LRM 13.4.2 + -- The conventional meaning of base notation is + -- assumed; in particular the value of each extended + -- digit of a based literal must be less then the base. + Error_Msg_Scan ("digit beyond base"); + D := 1; + end if; + Pos := Pos + 1; + Bmul (Res, Res, D, Base); + Scale := Scale + 1; + + C := Source (Pos); + if C = '_' then + loop + Pos := Pos + 1; + C := Source (Pos); + exit when C /= '_'; + Error_Msg_Scan ("double underscore in based integer"); + end loop; + elsif C = '.' then + if Has_Dot then + Error_Msg_Scan ("double dot ignored"); + else + Has_Dot := True; + Scale := 0; + end if; + Pos := Pos + 1; + C := Source (Pos); + elsif C = Number_Sign then + Pos := Pos + 1; + exit; + elsif C = '#' or C = ':' then + Error_Msg_Scan ("bad number sign replacement character"); + exit; + end if; + end loop; + end; + end if; + C := Source (Pos); + Exp := 0; + if C = 'E' or else C = 'e' then + Pos := Pos + 1; + C := Source (Pos); + Exp_Neg := False; + if C = '+' then + Pos := Pos + 1; + C := Source (Pos); + elsif C = '-' then + if Has_Dot then + Exp_Neg := True; + else + -- LRM 13.4.1 + -- An exponent for an integer literal must not have a minus sign. + -- + -- LRM 13.4.2 + -- An exponent for a based integer literal must not have a minus + -- sign. + Error_Msg_Scan + ("negative exponent not allowed for integer literal"); + end if; + Pos := Pos + 1; + C := Source (Pos); + end if; + if C not in '0' .. '9' then + Error_Msg_Scan ("digit expected after exponent"); + else + loop + -- C is a digit. + Exp := Exp * 10 + (Character'Pos (C) - Character'Pos ('0')); + + Pos := Pos + 1; + C := Source (Pos); + if C = '_' then + loop + Pos := Pos + 1; + C := Source (Pos); + exit when C /= '_'; + Error_Msg_Scan ("double underscore not allowed in integer"); + end loop; + if C not in '0' .. '9' then + Error_Msg_Scan ("digit expected after underscore"); + exit; + end if; + elsif C not in '0' .. '9' then + exit; + end if; + end loop; + end if; + if Exp_Neg then + Exp := -Exp; + end if; + end if; + + if Has_Dot then + Scale := Scale - Exp; + else + Scale := -Exp; + end if; + if Scale /= 0 then + declare + Scale_Neg : Boolean; + Val_Exp : E_Num; + Val_Pow : E_Num; + begin + if Scale > 0 then + Scale_Neg := True; + else + Scale_Neg := False; + Scale := -Scale; + end if; + + Val_Pow := To_E_Num (Base); + Val_Exp := E_One; + while Scale /= 0 loop + if Scale mod 2 = 1 then + Mul (Val_Exp, Val_Exp, Val_Pow); + end if; + Scale := Scale / 2; + Mul (Val_Pow, Val_Pow, Val_Pow); + end loop; + if Scale_Neg then + Div (Res, Res, Val_Exp); + else + Mul (Res, Res, Val_Exp); + end if; + end; + end if; + + if Has_Dot then + -- a universal real. + Current_Token := Tok_Real; + -- Set to a valid literal, in case of constraint error. + To_Float (Current_Context.Fp64, Ok, Res); + if not Ok then + Error_Msg_Scan ("literal beyond real bounds"); + end if; + else + -- a universal integer. + Current_Token := Tok_Integer; + -- Set to a valid literal, in case of constraint error. + Fix (Current_Context.Int64, Ok, Res); + if not Ok then + Error_Msg_Scan ("literal beyond integer bounds"); + end if; + end if; +exception + when Constraint_Error => + Error_Msg_Scan ("literal overflow"); +end Scan_Literal; diff --git a/src/vhdl/scanner.adb b/src/vhdl/scanner.adb new file mode 100644 index 000000000..260bd7c8f --- /dev/null +++ b/src/vhdl/scanner.adb @@ -0,0 +1,1621 @@ +-- VHDL lexical scanner. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; +with Ada.Characters.Handling; +with Errorout; use Errorout; +with Name_Table; +with Files_Map; use Files_Map; +with Std_Names; +with Str_Table; +with Flags; use Flags; + +package body Scanner is + + -- This classification is a simplification of the categories of LRM93 13.1 + -- LRM93 13.1 + -- The only characters allowed in the text of a VHDL description are the + -- graphic characters and format effector. + + type Character_Kind_Type is + ( + -- Neither a format effector nor a graphic character. + Invalid, + Format_Effector, + Upper_Case_Letter, + Digit, + Special_Character, + Space_Character, + Lower_Case_Letter, + Other_Special_Character); + + -- LRM93 13.1 + -- BASIC_GRAPHIC_CHARACTER ::= + -- UPPER_CASE_LETTER | DIGIT | SPECIAL_CHARACTER | SPACE_CHARACTER + --subtype Basic_Graphic_Character is + -- Character_Kind_Type range Upper_Case_Letter .. Space_Character; + + -- LRM93 13.1 + -- GRAPHIC_CHARACTER ::= + -- BASIC_GRAPHIC_CHARACTER | LOWER_CASE_LETTER | OTHER_SPECIAL_CHARACTER + -- Note: There is 191 graphic character. + subtype Graphic_Character is + Character_Kind_Type range Upper_Case_Letter .. Other_Special_Character; + + -- LRM93 13.1 + -- The characters included in each of the categories of basic graphic + -- characters are defined as follows: + type Character_Array is array (Character) of Character_Kind_Type; + Characters_Kind : constant Character_Array := + (NUL .. BS => Invalid, + + -- Format effectors are the ISO (and ASCII) characters called horizontal + -- tabulation, vertical tabulation, carriage return, line feed, and form + -- feed. + HT | LF | VT | FF | CR => Format_Effector, + + SO .. US => Invalid, + + -- 1. upper case letters + 'A' .. 'Z' | UC_A_Grave .. UC_O_Diaeresis | + UC_O_Oblique_Stroke .. UC_Icelandic_Thorn => Upper_Case_Letter, + + -- 2. digits + '0' .. '9' => Digit, + + -- 3. special characters + Quotation | '#' | '&' | ''' | '(' | ')' | '+' | ',' | '-' | '.' | '/' + | ':' | ';' | '<' | '=' | '>' | '[' | ']' + | '_' | '|' | '*' => Special_Character, + + -- 4. the space characters + ' ' | No_Break_Space => Space_Character, + + -- 5. lower case letters + 'a' .. 'z' | LC_German_Sharp_S .. LC_O_Diaeresis | + LC_O_Oblique_Stroke .. LC_Y_Diaeresis => Lower_Case_Letter, + + -- 6. other special characters + '!' | '$' | '%' | '@' | '?' | '\' | '^' | '`' | '{' | '}' | '~' + | Inverted_Exclamation .. Inverted_Question | Multiplication_Sign | + Division_Sign => Other_Special_Character, + + -- '¡' -- INVERTED EXCLAMATION MARK + -- '¢' -- CENT SIGN + -- '£' -- POUND SIGN + -- '¤' -- CURRENCY SIGN + -- 'Â¥' -- YEN SIGN + -- '¦' -- BROKEN BAR + -- '§' -- SECTION SIGN + -- '¨' -- DIAERESIS + -- '©' -- COPYRIGHT SIGN + -- 'ª' -- FEMININE ORDINAL INDICATOR + -- '«' -- LEFT-POINTING DOUBLE ANGLE QUOTATION MARK + -- '¬' -- NOT SIGN + -- 'Â' -- SOFT HYPHEN + -- '®' -- REGISTERED SIGN + -- '¯' -- MACRON + -- '°' -- DEGREE SIGN + -- '±' -- PLUS-MINUS SIGN + -- '²' -- SUPERSCRIPT TWO + -- '³' -- SUPERSCRIPT THREE + -- '´' -- ACUTE ACCENT + -- 'µ' -- MICRO SIGN + -- '¶' -- PILCROW SIGN + -- '·' -- MIDDLE DOT + -- '¸' -- CEDILLA + -- '¹' -- SUPERSCRIPT ONE + -- 'º' -- MASCULINE ORDINAL INDICATOR + -- '»' -- RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK + -- '¼' -- VULGAR FRACTION ONE QUARTER + -- '½' -- VULGAR FRACTION ONE HALF + -- '¾' -- VULGAR FRACTION THREE QUARTERS + -- '¿' -- INVERTED QUESTION MARK + -- '×' -- MULTIPLICATION SIGN + -- '÷' -- DIVISION SIGN + + DEL .. APC => Invalid); + + -- The context contains the whole internal state of the scanner, ie + -- it can be used to push/pop a lexical analysis, to restart the + -- scanner from a context marking a previous point. + type Scan_Context is record + Source: File_Buffer_Acc; + Source_File: Source_File_Entry; + Line_Number: Natural; + Line_Pos: Source_Ptr; + Pos: Source_Ptr; + Token_Pos: Source_Ptr; + File_Len: Source_Ptr; + File_Name: Name_Id; + Token: Token_Type; + Prev_Token: Token_Type; + Str_Id : String_Id; + Str_Len : Nat32; + Identifier: Name_Id; + Int64: Iir_Int64; + Fp64: Iir_Fp64; + end record; + + -- The current context. + -- Default value is an invalid context. + Current_Context: Scan_Context := (Source => null, + Source_File => No_Source_File_Entry, + Line_Number => 0, + Line_Pos => 0, + Pos => 0, + Token_Pos => 0, + File_Len => 0, + File_Name => Null_Identifier, + Token => Tok_Invalid, + Prev_Token => Tok_Invalid, + Identifier => Null_Identifier, + Str_Id => Null_String, + Str_Len => 0, + Int64 => 0, + Fp64 => 0.0); + + Source: File_Buffer_Acc renames Current_Context.Source; + Pos: Source_Ptr renames Current_Context.Pos; + + -- When CURRENT_TOKEN is an identifier, its name_id is stored into + -- this global variable. + -- Function current_text can be used to convert it into an iir. + function Current_Identifier return Name_Id is + begin + return Current_Context.Identifier; + end Current_Identifier; + + procedure Invalidate_Current_Identifier is + begin + Current_Context.Identifier := Null_Identifier; + end Invalidate_Current_Identifier; + + procedure Invalidate_Current_Token is + begin + if Current_Token /= Tok_Invalid then + Current_Context.Prev_Token := Current_Token; + Current_Token := Tok_Invalid; + end if; + end Invalidate_Current_Token; + + function Current_String_Id return String_Id is + begin + return Current_Context.Str_Id; + end Current_String_Id; + + function Current_String_Length return Nat32 is + begin + return Current_Context.Str_Len; + end Current_String_Length; + + function Current_Iir_Int64 return Iir_Int64 is + begin + return Current_Context.Int64; + end Current_Iir_Int64; + + function Current_Iir_Fp64 return Iir_Fp64 is + begin + return Current_Context.Fp64; + end Current_Iir_Fp64; + + function Get_Current_File return Name_Id is + begin + return Current_Context.File_Name; + end Get_Current_File; + + function Get_Current_Source_File return Source_File_Entry is + begin + return Current_Context.Source_File; + end Get_Current_Source_File; + + function Get_Current_Line return Natural is + begin + return Current_Context.Line_Number; + end Get_Current_Line; + + function Get_Current_Column return Natural + is + Col : Natural; + Name : Name_Id; + begin + Coord_To_Position + (Current_Context.Source_File, + Current_Context.Line_Pos, + Integer (Current_Context.Pos - Current_Context.Line_Pos), + Name, Col); + return Col; + end Get_Current_Column; + + function Get_Token_Column return Natural + is + Col : Natural; + Name : Name_Id; + begin + Coord_To_Position + (Current_Context.Source_File, + Current_Context.Line_Pos, + Integer (Current_Context.Token_Pos - Current_Context.Line_Pos), + Name, Col); + return Col; + end Get_Token_Column; + + function Get_Token_Position return Source_Ptr is + begin + return Current_Context.Token_Pos; + end Get_Token_Position; + + function Get_Position return Source_Ptr is + begin + return Current_Context.Pos; + end Get_Position; + + procedure Set_File (Source_File : Source_File_Entry) + is + N_Source: File_Buffer_Acc; + begin + if Current_Context.Source /= null then + raise Internal_Error; + end if; + if Source_File = No_Source_File_Entry then + raise Internal_Error; + end if; + N_Source := Get_File_Source (Source_File); + Current_Context := + (Source => N_Source, + Source_File => Source_File, + Line_Number => 1, + Line_Pos => 0, + Pos => N_Source'First, + Token_Pos => 0, -- should be invalid, + File_Len => Get_File_Length (Source_File), + File_Name => Get_File_Name (Source_File), + Token => Tok_Invalid, + Prev_Token => Tok_Invalid, + Identifier => Null_Identifier, + Str_Id => Null_String, + Str_Len => 0, + Int64 => -1, + Fp64 => 0.0); + Current_Token := Tok_Invalid; + end Set_File; + + procedure Set_Current_Position (Position: Source_Ptr) + is + Loc : Location_Type; + Offset: Natural; + File_Entry : Source_File_Entry; + begin + if Current_Context.Source = null then + raise Internal_Error; + end if; + Current_Token := Tok_Invalid; + Current_Context.Pos := Position; + Loc := File_Pos_To_Location (Current_Context.Source_File, + Current_Context.Pos); + Location_To_Coord (Loc, + File_Entry, Current_Context.Line_Pos, + Current_Context.Line_Number, Offset); + end Set_Current_Position; + + procedure Close_File is + begin + Current_Context.Source := null; + end Close_File; + + -- Emit an error when a character above 128 was found. + -- This must be called only in vhdl87. + procedure Error_8bit is + begin + Error_Msg_Scan ("8 bits characters not allowed in vhdl87"); + end Error_8bit; + + -- Emit an error when a separator is expected. + procedure Error_Separator is + begin + Error_Msg_Scan ("a separator is required here"); + end Error_Separator; + + -- scan a decimal literal or a based literal. + -- + -- LRM93 13.4.1 + -- DECIMAL_LITERAL ::= INTEGER [ . INTEGER ] [ EXPONENT ] + -- EXPONENT ::= E [ + ] INTEGER | E - INTEGER + -- + -- LRM93 13.4.2 + -- BASED_LITERAL ::= BASE # BASED_INTEGER [ . BASED_INTEGER ] # EXPONENT + -- BASE ::= INTEGER + procedure Scan_Literal is separate; + + -- Scan a string literal. + -- + -- LRM93 13.6 + -- A string literal is formed by a sequence of graphic characters + -- (possibly none) enclosed between two quotation marks used as string + -- brackets. + -- STRING_LITERAL ::= " { GRAPHIC_CHARACTER } " + -- + -- IN: for a string, at the call of this procedure, the current character + -- must be either '"' or '%'. + procedure Scan_String + is + -- The quotation character (can be " or %). + Mark: Character; + -- Current character. + C : Character; + -- Current length. + Length : Nat32; + begin + Mark := Source (Pos); + if Mark /= Quotation and then Mark /= '%' then + raise Internal_Error; + end if; + Pos := Pos + 1; + Length := 0; + Current_Context.Str_Id := Str_Table.Start; + loop + C := Source (Pos); + if C = Mark then + -- LRM93 13.6 + -- If a quotation mark value is to be represented in the sequence + -- of character values, then a pair of adjacent quoatation + -- characters marks must be written at the corresponding place + -- within the string literal. + -- LRM93 13.10 + -- Any pourcent sign within the sequence of characters must then + -- be doubled, and each such doubled percent sign is interpreted + -- as a single percent sign value. + -- The same replacement is allowed for a bit string literal, + -- provieded that both bit string brackets are replaced. + Pos := Pos + 1; + exit when Source (Pos) /= Mark; + end if; + + case Characters_Kind (C) is + when Format_Effector => + Error_Msg_Scan ("format effector not allowed in a string"); + exit; + when Invalid => + Error_Msg_Scan + ("invalid character not allowed, even in a string"); + when Graphic_Character => + if Vhdl_Std = Vhdl_87 and then C > Character'Val (127) then + Error_8bit; + end if; + end case; + + if C = Quotation and Mark = '%' then + -- LRM93 13.10 + -- The quotation marks (") used as string brackets at both ends of + -- a string literal can be replaced by percent signs (%), provided + -- that the enclosed sequence of characters constains no quotation + -- marks, and provided that both string brackets are replaced. + Error_Msg_Scan + ("'""' cannot be used in a string delimited with '%'"); + end if; + + Length := Length + 1; + Str_Table.Append (C); + Pos := Pos + 1; + end loop; + + Str_Table.Finish; + + Current_Token := Tok_String; + Current_Context.Str_Len := Length; + end Scan_String; + + -- Scan a bit string literal. + -- + -- LRM93 13.7 + -- A bit string literal is formed by a sequence of extended digits + -- (possibly none) enclosed between two quotations used as bit string + -- brackets, preceded by a base specifier. + -- BIT_STRING_LITERAL ::= BASE_SPECIFIER " [ BIT_VALUE ] " + -- BIT_VALUE ::= EXTENDED_DIGIT { [ UNDERLINE ] EXTENDED_DIGIT } + -- + -- The current character must be a base specifier, followed by '"' or '%'. + -- The base must be valid. + procedure Scan_Bit_String + is + -- The base specifier. + Base_Len : Nat32 range 1 .. 4; + -- The quotation character (can be " or %). + Mark: Character; + -- Current character. + C : Character; + -- Current length. + Length : Nat32; + -- Digit value. + V : Natural; + begin + case Source (Pos) is + when 'x' | 'X' => + Base_Len := 4; + when 'o' | 'O' => + Base_Len := 3; + when 'b' | 'B' => + Base_Len := 1; + when others => + raise Internal_Error; + end case; + Pos := Pos + 1; + Mark := Source (Pos); + if Mark /= Quotation and then Mark /= '%' then + raise Internal_Error; + end if; + Pos := Pos + 1; + Length := 0; + Current_Context.Str_Id := Str_Table.Start; + loop + << Again >> null; + C := Source (Pos); + Pos := Pos + 1; + exit when C = Mark; + + -- LRM93 13.7 + -- If the base specifier is 'B', the extended digits in the bit + -- value are restricted to 0 and 1. + -- If the base specifier is 'O', the extended digits int the bit + -- value are restricted to legal digits in the octal number + -- system, ie, the digits 0 through 7. + -- If the base specifier is 'X', the extended digits are all digits + -- together with the letters A through F. + case C is + when '0' .. '9' => + V := Character'Pos (C) - Character'Pos ('0'); + when 'A' .. 'F' => + V := Character'Pos (C) - Character'Pos ('A') + 10; + when 'a' .. 'f' => + V := Character'Pos (C) - Character'Pos ('a') + 10; + when '_' => + if Source (Pos) = '_' then + Error_Msg_Scan + ("double underscore not allowed in a bit string"); + end if; + if Source (Pos - 2) = Mark then + Error_Msg_Scan + ("underscore not allowed at the start of a bit string"); + elsif Source (Pos) = Mark then + Error_Msg_Scan + ("underscore not allowed at the end of a bit string"); + end if; + goto Again; + when '"' => + pragma Assert (Mark = '%'); + Error_Msg_Scan + ("'""' cannot close a bit string opened by '%'"); + exit; + when '%' => + pragma Assert (Mark = '"'); + Error_Msg_Scan + ("'%' cannot close a bit string opened by '""'"); + exit; + when others => + Error_Msg_Scan ("bit string not terminated"); + Pos := Pos - 1; + exit; + end case; + + case Base_Len is + when 1 => + if V > 1 then + Error_Msg_Scan ("invalid character in a binary bit string"); + end if; + Str_Table.Append (C); + when 2 => + raise Internal_Error; + when 3 => + if V > 7 then + Error_Msg_Scan ("invalid character in a octal bit string"); + end if; + for I in 1 .. 3 loop + if (V / 4) = 1 then + Str_Table.Append ('1'); + else + Str_Table.Append ('0'); + end if; + V := (V mod 4) * 2; + end loop; + when 4 => + for I in 1 .. 4 loop + if (V / 8) = 1 then + Str_Table.Append ('1'); + else + Str_Table.Append ('0'); + end if; + V := (V mod 8) * 2; + end loop; + end case; + Length := Length + Base_Len; + end loop; + + Str_Table.Finish; + + if Length = 0 then + Error_Msg_Scan ("empty bit string is not allowed"); + end if; + Current_Token := Tok_Bit_String; + Current_Context.Int64 := Iir_Int64 (Base_Len); + Current_Context.Str_Len := Length; + end Scan_Bit_String; + + -- LRM93 13.3.1 + -- Basic Identifiers + -- A basic identifier consists only of letters, digits, and underlines. + -- BASIC_IDENTIFIER ::= LETTER { [ UNDERLINE ] LETTER_OR_DIGIT } + -- LETTER_OR_DIGIT ::= LETTER | DIGIT + -- LETTER ::= UPPER_CASE_LETTER | LOWER_CASE_LETTER + -- + -- NB: At the call of this procedure, the current character must be a legal + -- character for a basic identifier. + procedure Scan_Identifier + is + use Name_Table; + C : Character; + Len : Natural; + begin + -- This is an identifier or a key word. + Len := 0; + loop + -- source (pos) is correct. + -- LRM93 13.3.1 + -- All characters if a basic identifier are signifiant, including + -- any underline character inserted between a letter or digit and + -- an adjacent letter or digit. + -- Basic identifiers differing only in the use of the corresponding + -- upper and lower case letters are considered as the same. + -- This is achieved by converting all upper case letters into + -- equivalent lower case letters. + -- The opposite (converting in lower case letters) is not possible, + -- because two characters have no upper-case equivalent. + C := Source (Pos); + case Characters_Kind (C) is + when Upper_Case_Letter => + if Vhdl_Std = Vhdl_87 and C > 'Z' then + Error_8bit; + end if; + Len := Len + 1; + Name_Buffer (Len) := Ada.Characters.Handling.To_Lower (C); + when Lower_Case_Letter | Digit => + if Vhdl_Std = Vhdl_87 and C > 'z' then + Error_8bit; + end if; + Len := Len + 1; + Name_Buffer (Len) := C; + when Special_Character => + -- The current character is legal in an identifier. + if C = '_' then + if Source (Pos + 1) = '_' then + Error_Msg_Scan ("two underscores can't be consecutive"); + end if; + Len := Len + 1; + Name_Buffer (Len) := C; + else + exit; + end if; + when others => + exit; + end case; + Pos := Pos + 1; + end loop; + + if Source (Pos - 1) = '_' then + if not Flag_Psl then + -- Some PSL reserved words finish with '_'. This case is handled + -- later. + Error_Msg_Scan ("identifier cannot finish with '_'"); + end if; + Pos := Pos - 1; + Len := Len - 1; + C := '_'; + end if; + + -- LRM93 13.2 + -- At least one separator is required between an identifier or an + -- abstract literal and an adjacent identifier or abstract literal. + case Characters_Kind (C) is + when Digit + | Upper_Case_Letter + | Lower_Case_Letter => + raise Internal_Error; + when Other_Special_Character => + if Vhdl_Std /= Vhdl_87 and then C = '\' then + Error_Separator; + end if; + when Invalid + | Format_Effector + | Space_Character + | Special_Character => + null; + end case; + Name_Length := Len; + + -- Hash it. + Current_Context.Identifier := Name_Table.Get_Identifier; + if Current_Identifier in Std_Names.Name_Id_Keywords then + -- LRM93 13.9 + -- The identifiers listed below are called reserved words and are + -- reserved for signifiances in the language. + -- IN: this is also achieved in packages std_names and tokens. + Current_Token := Token_Type'Val + (Token_Type'Pos (Tok_First_Keyword) + + Current_Identifier - Std_Names.Name_First_Keyword); + case Current_Identifier is + when Std_Names.Name_Id_AMS_Reserved_Words => + if not AMS_Vhdl then + if Flags.Warn_Reserved_Word then + Warning_Msg_Scan + ("using """ & Name_Buffer (1 .. Name_Length) + & """ AMS-VHDL reserved word as an identifier"); + end if; + Current_Token := Tok_Identifier; + end if; + when Std_Names.Name_Id_Vhdl00_Reserved_Words => + if Vhdl_Std < Vhdl_00 then + if Flags.Warn_Reserved_Word then + Warning_Msg_Scan + ("using """ & Name_Buffer (1 .. Name_Length) + & """ vhdl00 reserved word as an identifier"); + end if; + Current_Token := Tok_Identifier; + end if; + when Std_Names.Name_Id_Vhdl93_Reserved_Words => + if Vhdl_Std = Vhdl_87 then + if Flags.Warn_Reserved_Word then + Warning_Msg_Scan + ("using """ & Name_Buffer (1 .. Name_Length) + & """ vhdl93 reserved word as a vhdl87 identifier"); + Warning_Msg_Scan + ("(use option --std=93 to compile as vhdl93)"); + end if; + Current_Token := Tok_Identifier; + end if; + when Std_Names.Name_Id_Vhdl87_Reserved_Words => + null; + when others => + raise Program_Error; + end case; + elsif Flag_Psl then + case Current_Identifier is + when Std_Names.Name_Clock => + Current_Token := Tok_Psl_Clock; + when Std_Names.Name_Const => + Current_Token := Tok_Psl_Const; + when Std_Names.Name_Boolean => + Current_Token := Tok_Psl_Boolean; + when Std_Names.Name_Sequence => + Current_Token := Tok_Psl_Sequence; + when Std_Names.Name_Property => + Current_Token := Tok_Psl_Property; + when Std_Names.Name_Inf => + Current_Token := Tok_Inf; + when Std_Names.Name_Within => + Current_Token := Tok_Within; + when Std_Names.Name_Abort => + Current_Token := Tok_Abort; + when Std_Names.Name_Before => + Current_Token := Tok_Before; + when Std_Names.Name_Always => + Current_Token := Tok_Always; + when Std_Names.Name_Never => + Current_Token := Tok_Never; + when Std_Names.Name_Eventually => + Current_Token := Tok_Eventually; + when Std_Names.Name_Next_A => + Current_Token := Tok_Next_A; + when Std_Names.Name_Next_E => + Current_Token := Tok_Next_E; + when Std_Names.Name_Next_Event => + Current_Token := Tok_Next_Event; + when Std_Names.Name_Next_Event_A => + Current_Token := Tok_Next_Event_A; + when Std_Names.Name_Next_Event_E => + Current_Token := Tok_Next_Event_E; + when Std_Names.Name_Until => + Current_Token := Tok_Until; + when others => + Current_Token := Tok_Identifier; + if C = '_' then + Error_Msg_Scan ("identifiers cannot finish with '_'"); + end if; + end case; + else + Current_Token := Tok_Identifier; + end if; + end Scan_Identifier; + + -- LRM93 13.3.2 + -- EXTENDED_IDENTIFIER ::= \ GRAPHIC_CHARACTER { GRAPHIC_CHARACTER } \ + -- + -- Create an (extended) indentifier. + -- Extended identifiers are stored as they appear (leading and tailing + -- backslashes, doubling backslashes inside). + procedure Scan_Extended_Identifier + is + use Name_Table; + begin + -- LRM93 13.3.2 + -- Moreover, every extended identifiers is distinct from any basic + -- identifier. + -- This is satisfied by storing '\' in the name table. + Name_Length := 1; + Name_Buffer (1) := '\'; + loop + -- Next character. + Pos := Pos + 1; + + if Source (Pos) = '\' then + -- LRM93 13.3.2 + -- If a backslash is to be used as one of the graphic characters + -- of an extended literal, it must be doubled. + -- LRM93 13.3.2 + -- (a doubled backslash couting as one character) + Name_Length := Name_Length + 1; + Name_Buffer (Name_Length) := '\'; + + Pos := Pos + 1; + + exit when Source (Pos) /= '\'; + end if; + + -- source (pos) is correct. + case Characters_Kind (Source (Pos)) is + when Format_Effector => + Error_Msg_Scan ("format effector in extended identifier"); + exit; + when Graphic_Character => + null; + when Invalid => + Error_Msg_Scan ("invalid character in extended identifier"); + end case; + Name_Length := Name_Length + 1; + -- LRM93 13.3.2 + -- Extended identifiers differing only in the use of corresponding + -- upper and lower case letters are distinct. + Name_Buffer (Name_Length) := Source (Pos); + end loop; + + if Name_Length <= 2 then + Error_Msg_Scan ("empty extended identifier is not allowed"); + end if; + + -- LRM93 13.2 + -- At least one separator is required between an identifier or an + -- abstract literal and an adjacent identifier or abstract literal. + case Characters_Kind (Source (Pos)) is + when Digit + | Upper_Case_Letter + | Lower_Case_Letter => + Error_Separator; + when Invalid + | Format_Effector + | Space_Character + | Special_Character + | Other_Special_Character => + null; + end case; + + -- Hash it. + Current_Context.Identifier := Name_Table.Get_Identifier; + Current_Token := Tok_Identifier; + end Scan_Extended_Identifier; + + procedure Convert_Identifier + is + procedure Error_Bad is + begin + Error_Msg_Option ("bad character in identifier"); + end Error_Bad; + + procedure Error_8bit is + begin + Error_Msg_Option ("8 bits characters not allowed in vhdl87"); + end Error_8bit; + + use Name_Table; + C : Character; + begin + if Name_Length = 0 then + Error_Msg_Option ("identifier required"); + return; + end if; + + if Name_Buffer (1) = '\' then + -- Extended identifier. + if Vhdl_Std = Vhdl_87 then + Error_Msg_Option ("extended identifiers not allowed in vhdl87"); + return; + end if; + + if Name_Length < 3 then + Error_Msg_Option ("extended identifier is too short"); + return; + end if; + if Name_Buffer (Name_Length) /= '\' then + Error_Msg_Option ("extended identifier must finish with a '\'"); + return; + end if; + for I in 2 .. Name_Length - 1 loop + C := Name_Buffer (I); + case Characters_Kind (C) is + when Format_Effector => + Error_Msg_Option ("format effector in extended identifier"); + return; + when Graphic_Character => + if C = '\' then + if Name_Buffer (I + 1) /= '\' + or else I = Name_Length - 1 + then + Error_Msg_Option ("anti-slash must be doubled " + & "in extended identifier"); + return; + end if; + end if; + when Invalid => + Error_Bad; + end case; + end loop; + else + -- Identifier + for I in 1 .. Name_Length loop + C := Name_Buffer (I); + case Characters_Kind (C) is + when Upper_Case_Letter => + if Vhdl_Std = Vhdl_87 and C > 'Z' then + Error_8bit; + end if; + Name_Buffer (I) := Ada.Characters.Handling.To_Lower (C); + when Lower_Case_Letter | Digit => + if Vhdl_Std = Vhdl_87 and C > 'z' then + Error_8bit; + end if; + when Special_Character => + -- The current character is legal in an identifier. + if C = '_' then + if I = 1 then + Error_Msg_Option + ("identifier cannot start with an underscore"); + return; + end if; + if Name_Buffer (I - 1) = '_' then + Error_Msg_Option + ("two underscores can't be consecutive"); + return; + end if; + if I = Name_Length then + Error_Msg_Option + ("identifier cannot finish with an underscore"); + return; + end if; + else + Error_Bad; + end if; + when others => + Error_Bad; + end case; + end loop; + end if; + end Convert_Identifier; + + -- Scan an identifier within a comment. Only lower case letters are + -- allowed. + function Scan_Comment_Identifier return Boolean + is + use Name_Table; + Len : Natural; + C : Character; + begin + -- Skip spaces. + while Source (Pos) = ' ' or Source (Pos) = HT loop + Pos := Pos + 1; + end loop; + + -- The identifier shall start with a lower case letter. + if Source (Pos) not in 'a' .. 'z' then + return False; + end if; + + -- Scan the identifier (in lower cases). + Len := 0; + loop + C := Source (Pos); + exit when C not in 'a' .. 'z' and C /= '_'; + Len := Len + 1; + Name_Buffer (Len) := C; + Pos := Pos + 1; + end loop; + + -- Shall be followed by a space or a new line. + case C is + when ' ' | HT | LF | CR => + null; + when others => + return False; + end case; + + Name_Length := Len; + return True; + end Scan_Comment_Identifier; + + -- Scan tokens within a comment. Return TRUE if Current_Token was set, + -- return FALSE to discard the comment (ie treat it like a real comment). + function Scan_Comment return Boolean + is + use Std_Names; + Id : Name_Id; + begin + if not Scan_Comment_Identifier then + return False; + end if; + + -- Hash it. + Id := Name_Table.Get_Identifier; + + case Id is + when Name_Psl => + -- Scan first identifier after '-- psl'. + if not Scan_Comment_Identifier then + return False; + end if; + Id := Name_Table.Get_Identifier; + case Id is + when Name_Property => + Current_Token := Tok_Psl_Property; + when Name_Sequence => + Current_Token := Tok_Psl_Sequence; + when Name_Endpoint => + Current_Token := Tok_Psl_Endpoint; + when Name_Assert => + Current_Token := Tok_Psl_Assert; + when Name_Cover => + Current_Token := Tok_Psl_Cover; + when Name_Default => + Current_Token := Tok_Psl_Default; + when others => + return False; + end case; + Flag_Scan_In_Comment := True; + return True; + when others => + return False; + end case; + end Scan_Comment; + + function Scan_Exclam_Mark return Boolean is + begin + if Source (Pos) = '!' then + Pos := Pos + 1; + return True; + else + return False; + end if; + end Scan_Exclam_Mark; + + function Scan_Underscore return Boolean is + begin + if Source (Pos) = '_' then + Pos := Pos + 1; + return True; + else + return False; + end if; + end Scan_Underscore; + + -- The Scan_Next_Line procedure must be called after each end-of-line to + -- register to next line number. This is called by Scan_CR_Newline and + -- Scan_LF_Newline. + procedure Scan_Next_Line is + begin + Current_Context.Line_Number := Current_Context.Line_Number + 1; + Current_Context.Line_Pos := Pos; + File_Add_Line_Number + (Current_Context.Source_File, Current_Context.Line_Number, Pos); + end Scan_Next_Line; + + -- Scan a CR end-of-line. + procedure Scan_CR_Newline is + begin + -- Accept CR or CR+LF as line separator. + if Source (Pos + 1) = LF then + Pos := Pos + 2; + else + Pos := Pos + 1; + end if; + Scan_Next_Line; + end Scan_CR_Newline; + + -- Scan a LF end-of-line. + procedure Scan_LF_Newline is + begin + -- Accept LF or LF+CR as line separator. + if Source (Pos + 1) = CR then + Pos := Pos + 2; + else + Pos := Pos + 1; + end if; + Scan_Next_Line; + end Scan_LF_Newline; + + -- Get a new token. + procedure Scan is + begin + if Current_Token /= Tok_Invalid then + Current_Context.Prev_Token := Current_Token; + end if; + + << Again >> null; + + -- Skip commonly used separators. + while Source(Pos) = ' ' or Source(Pos) = HT loop + Pos := Pos + 1; + end loop; + + Current_Context.Token_Pos := Pos; + Current_Context.Identifier := Null_Identifier; + + case Source (Pos) is + when HT | ' ' => + -- Must have already been skipped just above. + raise Internal_Error; + when NBSP => + if Vhdl_Std = Vhdl_87 then + Error_Msg_Scan ("NBSP character not allowed in vhdl87"); + end if; + Pos := Pos + 1; + goto Again; + when VT | FF => + Pos := Pos + 1; + goto Again; + when LF => + Scan_LF_Newline; + if Flag_Newline then + Current_Token := Tok_Newline; + return; + end if; + goto Again; + when CR => + Scan_CR_Newline; + if Flag_Newline then + Current_Token := Tok_Newline; + return; + end if; + goto Again; + when '-' => + if Source (Pos + 1) = '-' then + -- This is a comment. + -- LRM93 13.8 + -- A comment starts with two adjacent hyphens and extends up + -- to the end of the line. + -- A comment can appear on any line line of a VHDL + -- description. + -- The presence or absence of comments has no influence on + -- wether a description is legal or illegal. + -- Futhermore, comments do not influence the execution of a + -- simulation module; their sole purpose is the enlightenment + -- of the human reader. + -- GHDL note: As a consequence, an obfruscating comment + -- is out of purpose, and a warning could be reported :-) + Pos := Pos + 2; + + -- Scan inside a comment. So we just ignore the two dashes. + if Flag_Scan_In_Comment then + goto Again; + end if; + + -- Handle keywords in comment (PSL). + if Flag_Comment_Keyword + and then Scan_Comment + then + return; + end if; + + -- LRM93 13.2 + -- In any case, a sequence of one or more format + -- effectors other than horizontal tabulation must + -- cause at least one end of line. + while Source (Pos) /= CR and Source (Pos) /= LF and + Source (Pos) /= VT and Source (Pos) /= FF and + Source (Pos) /= Files_Map.EOT + loop + if not Flags.Mb_Comment + and then Characters_Kind (Source (Pos)) = Invalid + then + Error_Msg_Scan ("invalid character, even in a comment"); + end if; + Pos := Pos + 1; + end loop; + if Flag_Comment then + Current_Token := Tok_Comment; + return; + end if; + goto Again; + elsif Flag_Psl and then Source (Pos + 1) = '>' then + Current_Token := Tok_Minus_Greater; + Pos := Pos + 2; + return; + else + Current_Token := Tok_Minus; + Pos := Pos + 1; + return; + end if; + when '+' => + Current_Token := Tok_Plus; + Pos := Pos + 1; + return; + when '*' => + if Source (Pos + 1) = '*' then + Current_Token := Tok_Double_Star; + Pos := Pos + 2; + else + Current_Token := Tok_Star; + Pos := Pos + 1; + end if; + return; + when '/' => + if Source (Pos + 1) = '=' then + Current_Token := Tok_Not_Equal; + Pos := Pos + 2; + elsif Source (Pos + 1) = '*' then + -- LRM08 15.9 Comments + -- A delimited comment start with a solidus (slash) character + -- immediately followed by an asterisk character and extends up + -- to the first subsequent occurrence of an asterisk character + -- immediately followed by a solidus character. + if Vhdl_Std < Vhdl_08 then + Error_Msg_Scan + ("block comment are not allowed before vhdl 2008"); + end if; + + -- Skip '/*'. + Pos := Pos + 2; + + loop + case Source (Pos) is + when '/' => + -- LRM08 15.9 + -- Moreover, an occurrence of a solidus character + -- immediately followed by an asterisk character + -- within a delimited comment is not interpreted as + -- the start of a nested delimited comment. + if Source (Pos + 1) = '*' then + Warning_Msg_Scan + ("'/*' found within a block comment"); + end if; + Pos := Pos + 1; + when '*' => + if Source (Pos + 1) = '/' then + Pos := Pos + 2; + exit; + else + Pos := Pos + 1; + end if; + when CR => + Scan_CR_Newline; + when LF => + Scan_LF_Newline; + when Files_Map.EOT => + if Pos >= Current_Context.File_Len then + -- Point at the start of the comment. + Error_Msg_Scan + ("block comment not terminated at end of file", + File_Pos_To_Location + (Current_Context.Source_File, + Current_Context.Token_Pos)); + exit; + end if; + Pos := Pos + 1; + when others => + Pos := Pos + 1; + end case; + end loop; + if Flag_Comment then + Current_Token := Tok_Comment; + return; + end if; + goto Again; + else + Current_Token := Tok_Slash; + Pos := Pos + 1; + end if; + return; + when '(' => + Current_Token := Tok_Left_Paren; + Pos := Pos + 1; + return; + when ')' => + Current_Token := Tok_Right_Paren; + Pos := Pos + 1; + return; + when '|' => + if Flag_Psl then + if Source (Pos + 1) = '|' then + Current_Token := Tok_Bar_Bar; + Pos := Pos + 2; + elsif Source (Pos + 1) = '-' + and then Source (Pos + 2) = '>' + then + Current_Token := Tok_Bar_Arrow; + Pos := Pos + 3; + elsif Source (Pos + 1) = '=' + and then Source (Pos + 2) = '>' + then + Current_Token := Tok_Bar_Double_Arrow; + Pos := Pos + 3; + else + Current_Token := Tok_Bar; + Pos := Pos + 1; + end if; + else + Current_Token := Tok_Bar; + Pos := Pos + 1; + end if; + return; + when '!' => + if Flag_Psl then + Current_Token := Tok_Exclam_Mark; + else + -- LRM93 13.10 + -- A vertical line (|) can be replaced by an exclamation + -- mark (!) where used as a delimiter. + Current_Token := Tok_Bar; + end if; + Pos := Pos + 1; + return; + when ':' => + if Source (Pos + 1) = '=' then + Current_Token := Tok_Assign; + Pos := Pos + 2; + else + Current_Token := Tok_Colon; + Pos := Pos + 1; + end if; + return; + when ';' => + Current_Token := Tok_Semi_Colon; + Pos := Pos + 1; + return; + when ',' => + Current_Token := Tok_Comma; + Pos := Pos + 1; + return; + when '.' => + if Source (Pos + 1) = '.' then + -- Be Ada friendly... + Error_Msg_Scan ("'..' is invalid in vhdl, replaced by 'to'"); + Current_Token := Tok_To; + Pos := Pos + 2; + return; + end if; + Current_Token := Tok_Dot; + Pos := Pos + 1; + return; + when '&' => + if Flag_Psl and then Source (Pos + 1) = '&' then + Current_Token := Tok_And_And; + Pos := Pos + 2; + else + Current_Token := Tok_Ampersand; + Pos := Pos + 1; + end if; + return; + when '<' => + if Source (Pos + 1) = '=' then + Current_Token := Tok_Less_Equal; + Pos := Pos + 2; + elsif Source (Pos + 1) = '>' then + Current_Token := Tok_Box; + Pos := Pos + 2; + else + Current_Token := Tok_Less; + Pos := Pos + 1; + end if; + return; + when '>' => + if Source (Pos + 1) = '=' then + Current_Token := Tok_Greater_Equal; + Pos := Pos + 2; + else + Current_Token := Tok_Greater; + Pos := Pos + 1; + end if; + return; + when '=' => + if Source (Pos + 1) = '=' then + if AMS_Vhdl then + Current_Token := Tok_Equal_Equal; + else + Error_Msg_Scan + ("'==' is not the vhdl equality, replaced by '='"); + Current_Token := Tok_Equal; + end if; + Pos := Pos + 2; + elsif Source (Pos + 1) = '>' then + Current_Token := Tok_Double_Arrow; + Pos := Pos + 2; + else + Current_Token := Tok_Equal; + Pos := Pos + 1; + end if; + return; + when ''' => + -- Handle cases such as character'('a') + -- FIXME: what about f ()'length ? or .all'length + if Current_Context.Prev_Token /= Tok_Identifier + and then Current_Context.Prev_Token /= Tok_Character + and then Source (Pos + 2) = ''' + then + -- LRM93 13.5 + -- A character literal is formed by enclosing one of the 191 + -- graphic character (...) between two apostrophe characters. + -- CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER ' + if Characters_Kind (Source (Pos + 1)) not in Graphic_Character + then + Error_Msg_Scan + ("a character literal can only be a graphic character"); + elsif Vhdl_Std = Vhdl_87 + and then Source (Pos + 1) > Character'Val (127) + then + Error_8bit; + end if; + Current_Token := Tok_Character; + Current_Context.Identifier := + Name_Table.Get_Identifier (Source (Pos + 1)); + Pos := Pos + 3; + return; + else + Current_Token := Tok_Tick; + Pos := Pos + 1; + end if; + return; + when '0' .. '9' => + Scan_Literal; + + -- LRM 13.2 + -- At least one separator is required between an identifier or + -- an abstract literal and an adjacent identifier or abstract + -- literal. + case Characters_Kind (Source (Pos)) is + when Digit => + raise Internal_Error; + when Upper_Case_Letter + | Lower_Case_Letter => + -- Could call Error_Separator, but use a clearer message + -- for this common case. + -- Note: the term "unit name" is not correct here, since it + -- can be any identifier or even a keyword; however it is + -- probably the most common case (eg 10ns). + Error_Msg_Scan + ("space is required between number and unit name"); + when Other_Special_Character => + if Vhdl_Std /= Vhdl_87 and then Source (Pos) = '\' then + Error_Separator; + end if; + when Invalid + | Format_Effector + | Space_Character + | Special_Character => + null; + end case; + return; + when '#' => + Error_Msg_Scan ("'#' is used for based literals and " + & "must be preceded by a base"); + -- Cannot easily continue. + raise Compilation_Error; + when Quotation | '%' => + Scan_String; + return; + when '[' => + if Flag_Psl then + if Source (Pos + 1) = '*' then + Current_Token := Tok_Brack_Star; + Pos := Pos + 2; + elsif Source (Pos + 1) = '+' + and then Source (Pos + 2) = ']' + then + Current_Token := Tok_Brack_Plus_Brack; + Pos := Pos + 3; + elsif Source (Pos + 1) = '-' + and then Source (Pos + 2) = '>' + then + Current_Token := Tok_Brack_Arrow; + Pos := Pos + 3; + elsif Source (Pos + 1) = '=' then + Current_Token := Tok_Brack_Equal; + Pos := Pos + 2; + else + Current_Token := Tok_Left_Bracket; + Pos := Pos + 1; + end if; + else + if Vhdl_Std = Vhdl_87 then + Error_Msg_Scan + ("'[' is an invalid character in vhdl87, replaced by '('"); + Current_Token := Tok_Left_Paren; + else + Current_Token := Tok_Left_Bracket; + end if; + Pos := Pos + 1; + end if; + return; + when ']' => + if Vhdl_Std = Vhdl_87 and not Flag_Psl then + Error_Msg_Scan + ("']' is an invalid character in vhdl87, replaced by ')'"); + Current_Token := Tok_Right_Paren; + else + Current_Token := Tok_Right_Bracket; + end if; + Pos := Pos + 1; + return; + when '{' => + if Flag_Psl then + Current_Token := Tok_Left_Curly; + else + Error_Msg_Scan ("'{' is an invalid character, replaced by '('"); + Current_Token := Tok_Left_Paren; + end if; + Pos := Pos + 1; + return; + when '}' => + if Flag_Psl then + Current_Token := Tok_Right_Curly; + else + Error_Msg_Scan ("'}' is an invalid character, replaced by ')'"); + Current_Token := Tok_Right_Paren; + end if; + Pos := Pos + 1; + return; + when '\' => + if Vhdl_Std = Vhdl_87 then + Error_Msg_Scan + ("extended identifiers are not allowed in vhdl87"); + end if; + Scan_Extended_Identifier; + return; + when '^' => + Error_Msg_Scan ("'^' is not a VHDL operator, use 'xor'"); + Pos := Pos + 1; + Current_Token := Tok_Xor; + return; + when '~' => + Error_Msg_Scan ("'~' is not a VHDL operator, use 'not'"); + Pos := Pos + 1; + Current_Token := Tok_Not; + return; + when '?' => + if Vhdl_Std < Vhdl_08 then + Error_Msg_Scan ("'?' can only be used in strings or comments"); + Pos := Pos + 1; + goto Again; + else + if Source (Pos + 1) = '<' then + if Source (Pos + 2) = '=' then + Current_Token := Tok_Match_Less_Equal; + Pos := Pos + 3; + else + Current_Token := Tok_Match_Less; + Pos := Pos + 2; + end if; + elsif Source (Pos + 1) = '>' then + if Source (Pos + 2) = '=' then + Current_Token := Tok_Match_Greater_Equal; + Pos := Pos + 3; + else + Current_Token := Tok_Match_Greater; + Pos := Pos + 2; + end if; + elsif Source (Pos + 1) = '?' then + Current_Token := Tok_Condition; + Pos := Pos + 2; + elsif Source (Pos + 1) = '=' then + Current_Token := Tok_Match_Equal; + Pos := Pos + 2; + elsif Source (Pos + 1) = '/' + and then Source (Pos + 2) = '=' + then + Current_Token := Tok_Match_Not_Equal; + Pos := Pos + 3; + else + Error_Msg_Scan ("unknown matching operator"); + Pos := Pos + 1; + goto Again; + end if; + end if; + return; + when '$' | '`' + | Inverted_Exclamation .. Inverted_Question + | Multiplication_Sign | Division_Sign => + Error_Msg_Scan ("character """ & Source (Pos) + & """ can only be used in strings or comments"); + Pos := Pos + 1; + goto Again; + when '@' => + if Flag_Psl then + Current_Token := Tok_Arobase; + Pos := Pos + 1; + return; + else + Error_Msg_Scan + ("character """ & Source (Pos) + & """ can only be used in strings or comments"); + Pos := Pos + 1; + goto Again; + end if; + when '_' => + Error_Msg_Scan ("an identifier can't start with '_'"); + Pos := Pos + 1; + goto Again; + when 'B' | 'b' | 'O' | 'o' | 'X' | 'x' => + if Source (Pos + 1) = Quotation or else Source (Pos + 1) = '%' then + -- LRM93 13.7 + -- BASE_SPECIFIER ::= B | O | X + -- A letter in a bit string literal (either an extended digit or + -- the base specifier) can be written either in lower case or + -- in upper case, with the same meaning. + Scan_Bit_String; + else + Scan_Identifier; + end if; + return; + when 'A' | 'C' .. 'N' | 'P' .. 'W' | 'Y'| 'Z' + | 'a' | 'c' .. 'n' | 'p' .. 'w' | 'y'| 'z' => + Scan_Identifier; + return; + when UC_A_Grave .. UC_O_Diaeresis + | UC_O_Oblique_Stroke .. UC_Icelandic_Thorn => + if Vhdl_Std = Vhdl_87 then + Error_Msg_Scan + ("upper case letters above 128 are not allowed in vhdl87"); + end if; + Scan_Identifier; + return; + when LC_German_Sharp_S .. LC_O_Diaeresis + | LC_O_Oblique_Stroke .. LC_Y_Diaeresis => + if Vhdl_Std = Vhdl_87 then + Error_Msg_Scan + ("lower case letters above 128 are not allowed in vhdl87"); + end if; + Scan_Identifier; + return; + when NUL .. ETX | ENQ .. BS | SO .. US | DEL .. APC => + Error_Msg_Scan + ("control character that is not CR, LF, FF, HT or VT " & + "is not allowed"); + Pos := Pos + 1; + goto Again; + when Files_Map.EOT => + if Pos >= Current_Context.File_Len then + -- FIXME: should conditionnaly emit a warning if the file + -- is not terminated by an end of line. + Current_Token := Tok_Eof; + else + Error_Msg_Scan ("EOT is not allowed inside the file"); + Pos := Pos + 1; + goto Again; + end if; + return; + end case; + end Scan; + + function Get_Token_Location return Location_Type is + begin + return File_Pos_To_Location + (Current_Context.Source_File, Current_Context.Token_Pos); + end Get_Token_Location; +end Scanner; diff --git a/src/vhdl/scanner.ads b/src/vhdl/scanner.ads new file mode 100644 index 000000000..ddc0d1819 --- /dev/null +++ b/src/vhdl/scanner.ads @@ -0,0 +1,120 @@ +-- VHDL lexical scanner. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Tokens; use Tokens; + +package Scanner is + -- Global variables + -- The token that was just scanned. + -- When the token was eaten, you can call invalidate_current_token to + -- set it to tok_invalid. + -- Current_token should not be written outside of scan package. + -- It can be replaced by a function call. + Current_Token: Token_Type := Tok_Invalid; + + -- Simply set current_token to tok_invalid. + procedure Invalidate_Current_Token; + pragma Inline (Invalidate_Current_Token); + + -- When CURRENT_TOKEN is an tok_identifier, tok_char or tok_string, + -- its name_id can be got via this function. + function Current_Identifier return Name_Id; + pragma Inline (Current_Identifier); + + -- Get current string identifier and length. + function Current_String_Id return String_Id; + function Current_String_Length return Nat32; + pragma Inline (Current_String_Id); + pragma Inline (Current_String_Length); + + -- Set Current_identifier to null_identifier. + -- Can be used to catch bugs. + procedure Invalidate_Current_Identifier; + pragma Inline (Invalidate_Current_Identifier); + + -- When CURRENT_TOKEN is tok_integer, returns the value. + -- When CURRENT_TOKEN is tok_bit_string, returns the base. + function Current_Iir_Int64 return Iir_Int64; + pragma Inline (Current_Iir_Int64); + + -- When CURRENT_TOKEN is tok_real, it returns the value. + function Current_Iir_Fp64 return Iir_Fp64; + pragma Inline (Current_Iir_Fp64); + + -- Advances the lexical analyser. Put a new token into current_token. + procedure Scan; + + -- Initialize the scanner with file SOURCE_FILE. + procedure Set_File (Source_File : Source_File_Entry); + + procedure Set_Current_Position (Position: Source_Ptr); + + -- Finalize the scanner. + procedure Close_File; + + -- If true comments are reported as a token. + Flag_Comment : Boolean := False; + + -- If true newlines are reported as a token. + Flag_Newline : Boolean := False; + + -- If true also scan PSL tokens. + Flag_Psl : Boolean := False; + + -- If true handle PSL embedded in comments: '-- psl' is ignored. + Flag_Psl_Comment : Boolean := False; + + -- If true, ignore '--'. This is automatically set when Flag_Psl_Comment + -- is true and a starting PSL keyword has been identified. + -- Must be reset to false by the parser. + Flag_Scan_In_Comment : Boolean := False; + + -- If true scan for keywords in comments. Must be enabled if + -- Flag_Psl_Comment is true. + Flag_Comment_Keyword : Boolean := False; + + -- If the next character is '!', eat it and return True, otherwise return + -- False (used by PSL). + function Scan_Exclam_Mark return Boolean; + + -- If the next character is '_', eat it and return True, otherwise return + -- False (used by PSL). + function Scan_Underscore return Boolean; + + -- Get the current location, or the location of the current token. + -- Since a token cannot spread over lines, file and line of the current + -- token are the same as those of the current position. + function Get_Current_File return Name_Id; + function Get_Current_Source_File return Source_File_Entry; + function Get_Current_Line return Natural; + function Get_Current_Column return Natural; + function Get_Token_Location return Location_Type; + function Get_Token_Column return Natural; + function Get_Token_Position return Source_Ptr; + function Get_Position return Source_Ptr; + + -- Convert (canonicalize) an identifier stored in name_buffer/name_length. + -- Upper case letters are converted into lower case. + -- Lexical checks are performed. + -- This procedure is not used by Scan, but should be used for identifiers + -- given in the command line. + -- Errors are directly reported through error_msg_option. + -- Also, Vhdl_Std should be set. + procedure Convert_Identifier; + +end Scanner; diff --git a/src/vhdl/sem.adb b/src/vhdl/sem.adb new file mode 100644 index 000000000..e82bd72b7 --- /dev/null +++ b/src/vhdl/sem.adb @@ -0,0 +1,2749 @@ +-- Semantic analysis pass. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Unchecked_Conversion; +with Errorout; use Errorout; +with Std_Package; use Std_Package; +with Ieee.Std_Logic_1164; +with Libraries; +with Std_Names; +with Sem_Scopes; use Sem_Scopes; +with Sem_Expr; use Sem_Expr; +with Sem_Names; use Sem_Names; +with Sem_Specs; use Sem_Specs; +with Sem_Decls; use Sem_Decls; +with Sem_Assocs; use Sem_Assocs; +with Sem_Inst; +with Iirs_Utils; use Iirs_Utils; +with Flags; use Flags; +with Name_Table; +with Str_Table; +with Sem_Stmts; use Sem_Stmts; +with Iir_Chains; +with Xrefs; use Xrefs; + +package body Sem is + -- Forward declarations. + procedure Sem_Context_Clauses (Design_Unit: Iir_Design_Unit); + procedure Sem_Block_Configuration + (Block_Conf : Iir_Block_Configuration; Father: Iir); + procedure Sem_Component_Configuration + (Conf : Iir_Component_Configuration; Father : Iir); + + procedure Add_Dependence (Unit : Iir) + is + Targ : constant Iir := Get_Current_Design_Unit; + begin + -- During normal analysis, there is a current design unit. But not + -- during debugging outside of any context. + if Targ = Null_Iir then + return; + end if; + + Add_Dependence (Targ, Unit); + end Add_Dependence; + + -- LRM 1.1 Entity declaration. + procedure Sem_Entity_Declaration (Entity: Iir_Entity_Declaration) is + begin + Xrefs.Xref_Decl (Entity); + Sem_Scopes.Add_Name (Entity); + Set_Visible_Flag (Entity, True); + + Set_Is_Within_Flag (Entity, True); + + -- LRM 10.1 + -- 1. An entity declaration, together with a corresponding architecture + -- body. + Open_Declarative_Region; + + -- Sem generics. + Sem_Interface_Chain (Get_Generic_Chain (Entity), Generic_Interface_List); + + -- Sem ports. + Sem_Interface_Chain (Get_Port_Chain (Entity), Port_Interface_List); + + -- Entity declarative part and concurrent statements. + Sem_Block (Entity, True); + + Close_Declarative_Region; + Set_Is_Within_Flag (Entity, False); + end Sem_Entity_Declaration; + + -- Get the entity unit for LIBRARY_UNIT (an architecture or a + -- configuration declaration). + -- Return NULL_IIR in case of error (not found, bad library). + function Sem_Entity_Name (Library_Unit : Iir) return Iir + is + Name : Iir; + Library : Iir_Library_Declaration; + Entity : Iir; + begin + -- Get the library of architecture/configuration. + Library := Get_Library + (Get_Design_File (Get_Design_Unit (Library_Unit))); + + -- Resolve the name. + + Name := Get_Entity_Name (Library_Unit); + if Get_Kind (Name) = Iir_Kind_Simple_Name then + -- LRM93 10.1 Declarative Region + -- LRM08 12.1 Declarative Region + -- a) An entity declaration, tohether with a corresponding + -- architecture body. + -- + -- GHDL: simple name needs to be handled specially. Because + -- architecture body is in the declarative region of its entity, + -- the entity name is directly visible. But we cannot really use + -- that rule as is, as we don't know which is the entity. + Entity := Libraries.Load_Primary_Unit + (Library, Get_Identifier (Name), Library_Unit); + if Entity = Null_Iir then + Error_Msg_Sem ("entity " & Disp_Node (Name) & " was not analysed", + Library_Unit); + return Null_Iir; + end if; + Entity := Get_Library_Unit (Entity); + Set_Named_Entity (Name, Entity); + Xrefs.Xref_Ref (Name, Entity); + else + -- Certainly an expanded name. Use the standard name analysis. + Name := Sem_Denoting_Name (Name); + Set_Entity_Name (Library_Unit, Name); + Entity := Get_Named_Entity (Name); + end if; + + if Get_Kind (Entity) /= Iir_Kind_Entity_Declaration then + Error_Class_Match (Name, "entity"); + return Null_Iir; + end if; + + -- LRM 1.2 Architecture bodies + -- For a given design entity, both the entity declaration and the + -- associated architecture body must reside in the same library. + + -- LRM 1.3 Configuration Declarations + -- For a configuration of a given design entity, both the + -- configuration declaration and the corresponding entity + -- declaration must reside in the same library. + if Get_Library (Get_Design_File (Get_Design_Unit (Entity))) /= Library + then + Error_Msg_Sem + (Disp_Node (Entity) & " does not reside in " + & Disp_Node (Library), Library_Unit); + return Null_Iir; + end if; + + return Entity; + end Sem_Entity_Name; + + -- LRM 1.2 Architecture bodies. + procedure Sem_Architecture_Body (Arch: Iir_Architecture_Body) + is + Entity_Unit : Iir_Design_Unit; + Entity_Library : Iir_Entity_Declaration; + begin + Xrefs.Xref_Decl (Arch); + -- First, find the entity. + Entity_Library := Sem_Entity_Name (Arch); + if Entity_Library = Null_Iir then + return; + end if; + Entity_Unit := Get_Design_Unit (Entity_Library); + + -- LRM93 11.4 + -- In each case, the second unit depends on the first unit. + -- GHDL: an architecture depends on its entity. + Add_Dependence (Entity_Unit); + + Add_Context_Clauses (Entity_Unit); + + Set_Is_Within_Flag (Arch, True); + Set_Is_Within_Flag (Entity_Library, True); + + -- Makes the entity name visible. + -- FIXME: quote LRM. + Sem_Scopes.Add_Name + (Entity_Library, Get_Identifier (Entity_Library), False); + + -- LRM 10.1 Declarative Region + -- 1. An entity declaration, together with a corresponding architecture + -- body. + Open_Declarative_Region; + Sem_Scopes.Add_Entity_Declarations (Entity_Library); + + -- LRM02 1.2 Architecture bodies + -- For the purpose of interpreting the scope and visibility of the + -- identifier (see 10.2 and 10.3), the declaration of the identifier is + -- considered to occur after the final declarative item of the entity + -- declarative part of the corresponding entity declaration. + -- + -- FIXME: before VHDL-02, an architecture is not a declaration. + Sem_Scopes.Add_Name (Arch, Get_Identifier (Arch), True); + Set_Visible_Flag (Arch, True); + + -- LRM02 10.1 Declarative region + -- The declarative region associated with an architecture body is + -- considered to occur immediatly within the declarative region + -- associated with the entity declaration corresponding to the given + -- architecture body. + if Vhdl_Std >= Vhdl_02 then + Open_Declarative_Region; + end if; + Sem_Block (Arch, True); + if Vhdl_Std >= Vhdl_02 then + Close_Declarative_Region; + end if; + + Close_Declarative_Region; + Set_Is_Within_Flag (Arch, False); + Set_Is_Within_Flag (Entity_Library, False); + end Sem_Architecture_Body; + + -- Return the real resolver used for (sub) object OBJ. + -- Return NULL_IIR if none. + function Get_Resolver (Obj : Iir) return Iir + is + Obj_Type : Iir; + Res : Iir; + begin + case Get_Kind (Obj) is + when Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element => + Res := Get_Resolver (Get_Prefix (Obj)); + if Res /= Null_Iir then + return Res; + end if; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration => + null; + when Iir_Kind_Object_Alias_Declaration => + return Get_Resolver (Get_Name (Obj)); + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Get_Resolver (Get_Named_Entity (Obj)); + when others => + Error_Kind ("get_resolved", Obj); + end case; + + Obj_Type := Get_Type (Obj); + if Get_Kind (Obj_Type) in Iir_Kinds_Subtype_Definition then + return Get_Resolution_Indication (Obj_Type); + else + return Null_Iir; + end if; + end Get_Resolver; + + -- Return TRUE iff the actual of ASSOC can be the formal. + -- ASSOC must be an association_element_by_expression. + function Can_Collapse_Signals (Assoc : Iir; Formal : Iir) return Boolean + is + Actual : Iir; + Actual_Res : Iir; + Formal_Res : Iir; + Formal_Base : Iir; + Actual_Base : Iir; + begin + -- If there is a conversion, signals types are not necessarily + -- the same, and sharing is not possible. + -- FIXME: optimize type conversions + -- (unsigned <-> signed <-> std_ulogic_vector <-> ...) + if Get_In_Conversion (Assoc) /= Null_Iir + or else Get_Out_Conversion (Assoc) /= Null_Iir + then + return False; + end if; + + -- Here we may assume formal and actual have the same type and the + -- same lengths. This is caught at elaboration time. + + Actual := Name_To_Object (Get_Actual (Assoc)); + if Actual = Null_Iir then + -- This is an expression. + return False; + end if; + + Formal_Base := Get_Object_Prefix (Formal); + Actual_Base := Get_Object_Prefix (Actual); + + -- If the formal is of mode IN, then it has no driving value, and its + -- effective value is the effective value of the actual. + -- Always collapse in this case. + if Get_Mode (Formal_Base) = Iir_In_Mode then + return True; + end if; + + -- Otherwise, these rules are applied: + -- + -- In this table, E means element, S means signal. + -- Er means the element is resolved, + -- Sr means the signal is resolved (at the signal level). + -- + -- Actual + -- | E,S | Er,S | E,Sr | Er,Sr | + -- ------+-------+-------+-------+-------+ + -- E,S |collap | no(3) | no(3) | no(3) | + -- ------+-------+-------+-------+-------+ + -- Er,S | no(1) |if same| no(2) | no(2) | + -- Formal ------+-------+-------+-------+-------+ + -- E,Sr | no(1) | no(2) |if same| no(4) | + -- ------+-------+-------+-------+-------+ + -- Er,Sr | no(1) | no(2) | no(4) |if same| + -- ------+-------+-------+-------+-------+ + -- + -- Notes: (1): formal may have several sources. + -- (2): resolver is not the same. + -- (3): this prevents to catch several sources error in instance. + -- (4): resolver is not the same, because the types are not the + -- same. + -- + -- Furthermore, signals cannot be collapsed if the kind (none, bus or + -- register) is not the same. + -- + -- Default value: default value is the effective value. + + -- Resolution function. + Actual_Res := Get_Resolver (Actual); + Formal_Res := Get_Resolver (Formal); + + -- If the resolutions are not the same, signals cannot be collapsed. + if Actual_Res /= Formal_Res then + return False; + end if; + + -- If neither the actual nor the formal is resolved, then collapsing is + -- possible. + -- (this is case ES/ES). + if Actual_Res = Null_Iir and Formal_Res = Null_Iir then + return True; + end if; + + -- If the formal can have sources and is guarded, but the actual is + -- not guarded (or has not the same kind of guard), signals cannot + -- be collapsed. + if Get_Signal_Kind (Formal_Base) /= Get_Signal_Kind (Actual_Base) then + return False; + end if; + + return True; + end Can_Collapse_Signals; + + -- INTER_PARENT contains generics interfaces; + -- ASSOC_PARENT constains generic aspects. + function Sem_Generic_Association_Chain + (Inter_Parent : Iir; Assoc_Parent : Iir) return Boolean + is + El : Iir; + Match : Boolean; + Assoc_Chain : Iir; + Inter_Chain : Iir; + Miss : Missing_Type; + begin + -- LRM08 6.5.6.2 Generic clauses + -- If no such actual is specified for a given formal generic constant + -- (either because the formal generic is unassociated or because the + -- actual is open), and if a default expression is specified for that + -- generic, the value of this expression is the value of the generic. + -- It is an error if no actual is specified for a given formal generic + -- constant and no default expression is present in the corresponding + -- interface element. + + -- Note: CHECK_MATCH argument of sem_subprogram_arguments must be + -- true if parent is a component instantiation. + case Get_Kind (Assoc_Parent) is + when Iir_Kind_Component_Instantiation_Statement => + -- LRM 9.6 Component Instantiation Statement + -- Each local generic (or subelement or slice thereof) must be + -- associated {VHDL87: exactly}{VHDL93: at most} once. + -- ... + -- Each local port (or subelement or slice therof) must be + -- associated {VHDL87: exactly}{VHDL93: at most} once. + + -- GHDL: for a direct instantiation, follow rules of + -- LRM 1.1.1.1 Generic and LRM 1.1.1.2 Ports. + if Flags.Vhdl_Std = Vhdl_87 + or else Get_Kind (Inter_Parent) = Iir_Kind_Entity_Declaration + then + Miss := Missing_Generic; + else + Miss := Missing_Allowed; + end if; + when Iir_Kind_Binding_Indication => + -- LRM 5.2.1.2 Generic map and port map aspects + Miss := Missing_Allowed; + when Iir_Kind_Block_Header => + Miss := Missing_Generic; + when Iir_Kind_Package_Instantiation_Declaration => + -- LRM08 4.9 + -- Each formal generic (or member thereof) shall be associated + -- at most once. + Miss := Missing_Generic; + when others => + Error_Kind ("sem_generic_association_list", Assoc_Parent); + end case; + + -- The generics + Inter_Chain := Get_Generic_Chain (Inter_Parent); + Assoc_Chain := Get_Generic_Map_Aspect_Chain (Assoc_Parent); + + -- Extract non-object associations, as the actual cannot be analyzed + -- as an expression. + Assoc_Chain := Extract_Non_Object_Association (Assoc_Chain, Inter_Chain); + Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); + + if not Sem_Actual_Of_Association_Chain (Assoc_Chain) then + return False; + end if; + + Sem_Association_Chain + (Inter_Chain, Assoc_Chain, True, Miss, Assoc_Parent, Match); + Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); + if not Match then + return False; + end if; + + -- LRM 5.2.1.2 Generic map and port map aspects + -- An actual associated with a formal generic map aspect must be an + -- expression or the reserved word open; + El := Assoc_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Association_Element_By_Expression => + Check_Read (Get_Actual (El)); + when Iir_Kind_Association_Element_Open + | Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Package => + null; + when others => + Error_Kind ("sem_generic_map_association_chain(1)", El); + end case; + El := Get_Chain (El); + end loop; + + return True; + end Sem_Generic_Association_Chain; + + procedure Sem_Generic_Association_Chain + (Inter_Parent : Iir; Assoc_Parent : Iir) + is + Res : Boolean; + pragma Unreferenced (Res); + begin + Res := Sem_Generic_Association_Chain (Inter_Parent, Assoc_Parent); + end Sem_Generic_Association_Chain; + + -- INTER_PARENT contains ports interfaces; + -- ASSOC_PARENT constains ports map aspects. + procedure Sem_Port_Association_Chain + (Inter_Parent : Iir; Assoc_Parent : Iir) + is + El : Iir; + Actual : Iir; + Prefix : Iir; + Object : Iir; + Match : Boolean; + Assoc_Chain : Iir; + Miss : Missing_Type; + Inter : Iir; + Formal : Iir; + Formal_Base : Iir; + begin + -- Note: CHECK_MATCH argument of sem_subprogram_arguments must be + -- true if parent is a component instantiation. + case Get_Kind (Assoc_Parent) is + when Iir_Kind_Component_Instantiation_Statement => + -- LRM 9.6 Component Instantiation Statement + -- Each local generic (or subelement or slice thereof) must be + -- associated {VHDL87: exactly}{VHDL93: at most} once. + -- ... + -- Each local port (or subelement or slice therof) must be + -- associated {VHDL87: exactly}{VHDL93: at most} once. + + -- GHDL: for a direct instantiation, follow rules of + -- LRM 1.1.1.1 Generic and LRM 1.1.1.2 Ports. + if Flags.Vhdl_Std = Vhdl_87 + or else Get_Kind (Inter_Parent) = Iir_Kind_Entity_Declaration + then + Miss := Missing_Port; + else + Miss := Missing_Allowed; + end if; + when Iir_Kind_Binding_Indication => + -- LRM 5.2.1.2 Generic map and port map aspects + Miss := Missing_Allowed; + when Iir_Kind_Block_Header => + -- FIXME: it is possible to have port unassociated ? + Miss := Missing_Port; + when others => + Error_Kind ("sem_port_association_list", Assoc_Parent); + end case; + + -- The ports + Assoc_Chain := Get_Port_Map_Aspect_Chain (Assoc_Parent); + if not Sem_Actual_Of_Association_Chain (Assoc_Chain) then + return; + end if; + Sem_Association_Chain (Get_Port_Chain (Inter_Parent), Assoc_Chain, + True, Miss, Assoc_Parent, Match); + Set_Port_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); + if not Match then + return; + end if; + + -- LRM 5.2.1.2 Generic map and port map aspects + -- [...]; an actual associated with a formal port in a port map aspect + -- must be a signal, an expression, or the reserved word open. + -- + -- Certain restriction apply to the actual associated with a formal in + -- a port map aspect; these restrictions are described in 1.1.1.2 + + -- LRM93 1.1.1.2 + -- The actual, if a port or signal, must be denoted by a static name. + -- The actual, if an expression, must be a globally static expression. + El := Assoc_Chain; + Inter := Get_Port_Chain (Inter_Parent); + while El /= Null_Iir loop + Formal := Get_Formal (El); + + if Formal = Null_Iir then + -- No formal: use association by position. + Formal := Inter; + Formal_Base := Inter; + Inter := Get_Chain (Inter); + else + Inter := Null_Iir; + Formal_Base := Get_Association_Interface (El); + end if; + + if Get_Kind (El) = Iir_Kind_Association_Element_By_Expression then + Actual := Get_Actual (El); + -- There has been an error, exit from the loop. + exit when Actual = Null_Iir; + Object := Name_To_Object (Actual); + if Object = Null_Iir then + Prefix := Actual; + else + Prefix := Get_Object_Prefix (Object); + end if; + case Get_Kind (Prefix) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kinds_Signal_Attribute => + -- Port or signal. + Set_Collapse_Signal_Flag + (El, Can_Collapse_Signals (El, Formal)); + if Get_Name_Staticness (Object) < Globally then + Error_Msg_Sem ("actual must be a static name", Actual); + end if; + if Get_Kind (Prefix) = Iir_Kind_Interface_Signal_Declaration + then + declare + P : Boolean; + pragma Unreferenced (P); + begin + P := Check_Port_Association_Restriction + (Formal_Base, Prefix, El); + end; + end if; + when others => + -- Expression. + Set_Collapse_Signal_Flag (El, False); + + -- If there is an IN conversion, re-integrate it into + -- the actual. + declare + In_Conv : Iir; + begin + In_Conv := Get_In_Conversion (El); + if In_Conv /= Null_Iir then + Set_In_Conversion (El, Null_Iir); + Set_Expr_Staticness + (In_Conv, Get_Expr_Staticness (Actual)); + Actual := In_Conv; + Set_Actual (El, Actual); + end if; + end; + if Flags.Vhdl_Std >= Vhdl_93c then + -- LRM93 1.1.1.2 Ports + -- Moreover, the ports of a block may be associated + -- with an expression, in order to provide these ports + -- with constant driving values; such ports must be + -- of mode in. + if Get_Mode (Formal_Base) /= Iir_In_Mode then + Error_Msg_Sem ("only 'in' ports may be associated " + & "with expression", El); + end if; + + -- LRM93 1.1.1.2 Ports + -- The actual, if an expression, must be a globally + -- static expression. + if Get_Expr_Staticness (Actual) < Globally then + Error_Msg_Sem + ("actual expression must be globally static", + Actual); + end if; + else + Error_Msg_Sem + ("cannot associate ports with expression in vhdl87", + El); + end if; + end case; + end if; + El := Get_Chain (El); + end loop; + end Sem_Port_Association_Chain; + + -- INTER_PARENT contains generics and ports interfaces; + -- ASSOC_PARENT constains generics and ports map aspects. + procedure Sem_Generic_Port_Association_Chain + (Inter_Parent : Iir; Assoc_Parent : Iir) + is + Res : Boolean; + pragma Unreferenced (Res); + begin + Sem_Generic_Association_Chain (Inter_Parent, Assoc_Parent); + Sem_Port_Association_Chain (Inter_Parent, Assoc_Parent); + end Sem_Generic_Port_Association_Chain; + + -- LRM 1.3 Configuration Declarations. + procedure Sem_Configuration_Declaration (Decl: Iir) + is + Entity: Iir_Entity_Declaration; + Entity_Unit : Iir_Design_Unit; + begin + Xref_Decl (Decl); + + -- LRM 1.3 + -- The entity name identifies the name of the entity declaration that + -- defines the design entity at the apex of the design hierarchy. + Entity := Sem_Entity_Name (Decl); + if Entity = Null_Iir then + return; + end if; + Entity_Unit := Get_Design_Unit (Entity); + + -- LRM 11.4 + -- A primary unit whose name is referenced within a given design unit + -- must be analyzed prior to the analysis of the given design unit. + Add_Dependence (Entity_Unit); + + Sem_Scopes.Add_Name (Decl); + + Set_Visible_Flag (Decl, True); + + -- LRM 10.1 Declarative Region + -- 2. A configuration declaration. + Open_Declarative_Region; + + -- LRM93 10.2 + -- In addition to the above rules, the scope of any declaration that + -- includes the end of the declarative part of a given block (wether + -- it be an external block defined by a design entity or an internal + -- block defined by a block statement) extends into a configuration + -- declaration that configures the given block. + Add_Context_Clauses (Entity_Unit); + Sem_Scopes.Add_Entity_Declarations (Entity); + + Sem_Declaration_Chain (Decl); + -- GHDL: no need to check for missing subprogram bodies, since they are + -- not allowed in configuration declarations. + + Sem_Block_Configuration (Get_Block_Configuration (Decl), Decl); + Close_Declarative_Region; + end Sem_Configuration_Declaration; + + -- LRM 1.3.1 Block Configuration. + -- FATHER is the block_configuration, configuration_declaration, + -- component_configuration containing the block_configuration BLOCK_CONF. + procedure Sem_Block_Configuration + (Block_Conf : Iir_Block_Configuration; Father: Iir) + is + El : Iir; + Block : Iir; + begin + case Get_Kind (Father) is + when Iir_Kind_Configuration_Declaration => + -- LRM93 1.3.1 + -- If a block configuration appears immediately within a + -- configuration declaration, then the block specification of that + -- block configuration must be an architecture name, and that + -- architecture name must denote a design entity body whose + -- interface is defined by the entity declaration denoted by the + -- entity name of the enclosing configuration declaration. + declare + Block_Spec : Iir; + Arch : Iir_Architecture_Body; + Design: Iir_Design_Unit; + begin + Block_Spec := Get_Block_Specification (Block_Conf); + -- FIXME: handle selected name. + if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then + Error_Msg_Sem ("architecture name expected", Block_Spec); + return; + end if; + -- LRM 10.3 rule b) + -- For an architecture body associated with a given entity + -- declaration: at the place of the block specification in a + -- block configuration for an external block whose interface + -- is defined by that entity declaration. + Design := Libraries.Load_Secondary_Unit + (Get_Design_Unit (Get_Entity (Father)), + Get_Identifier (Block_Spec), + Block_Conf); + if Design = Null_Iir then + Error_Msg_Sem + ("no architecture '" & Image_Identifier (Block_Spec) & "'", + Block_Conf); + return; + end if; + Arch := Get_Library_Unit (Design); + Xref_Ref (Block_Spec, Arch); + Free_Iir (Block_Spec); + Set_Block_Specification (Block_Conf, Arch); + Block := Arch; + Add_Dependence (Design); + end; + + when Iir_Kind_Component_Configuration => + -- LRM93 1.3.1 + -- If a block configuration appears immediately within a component + -- configuration, then the corresponding components must be + -- fully bound, the block specification of that block + -- configuration must be an architecture name, and that + -- architecture name must denote the same architecture body as + -- that to which the corresponding components are bound. + declare + Block_Spec : Iir; + Arch : Iir_Architecture_Body; + Design: Iir_Design_Unit; + Entity_Aspect : Iir; + Comp_Arch : Iir; + begin + Entity_Aspect := + Get_Entity_Aspect (Get_Binding_Indication (Father)); + if Entity_Aspect = Null_Iir or else + Get_Kind (Entity_Aspect) /= Iir_Kind_Entity_Aspect_Entity + then + Error_Msg_Sem ("corresponding component not fully bound", + Block_Conf); + end if; + + Block_Spec := Get_Block_Specification (Block_Conf); + -- FIXME: handle selected name. + if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then + Error_Msg_Sem ("architecture name expected", Block_Spec); + return; + end if; + + Comp_Arch := Get_Architecture (Entity_Aspect); + if Comp_Arch /= Null_Iir then + if Get_Kind (Comp_Arch) /= Iir_Kind_Simple_Name then + raise Internal_Error; + end if; + if Get_Identifier (Comp_Arch) /= Get_Identifier (Block_Spec) + then + Error_Msg_Sem + ("block specification name is different from " + & "component architecture name", Block_Spec); + return; + end if; + end if; + + Design := Libraries.Load_Secondary_Unit + (Get_Design_Unit (Get_Entity (Entity_Aspect)), + Get_Identifier (Block_Spec), + Block_Conf); + if Design = Null_Iir then + Error_Msg_Sem + ("no architecture '" & Image_Identifier (Block_Spec) & "'", + Block_Conf); + return; + end if; + Arch := Get_Library_Unit (Design); + Xref_Ref (Block_Spec, Arch); + Free_Iir (Block_Spec); + Set_Block_Specification (Block_Conf, Arch); + Block := Arch; + end; + + when Iir_Kind_Block_Configuration => + -- LRM93 1.3.1 + -- If a block configuration appears immediately within another + -- block configuration, then the block specification of the + -- contained block configuration must be a block statement or + -- generate statement label, and the label must denote a block + -- statement or generate statement that is contained immediatly + -- within the block denoted by the block specification of the + -- containing block configuration. + declare + Block_Spec : Iir; + Block_Name : Iir; + Block_Stmts : Iir; + Block_Spec_Kind : Iir_Kind; + Prev : Iir_Block_Configuration; + begin + Block_Spec := Get_Block_Specification (Block_Conf); + -- Remember the kind of BLOCK_SPEC, since the node can be free + -- by find_declaration if it is a simple name. + Block_Spec_Kind := Get_Kind (Block_Spec); + case Block_Spec_Kind is + when Iir_Kind_Simple_Name => + Block_Name := Block_Spec; + when Iir_Kind_Parenthesis_Name => + Block_Name := Get_Prefix (Block_Spec); + when Iir_Kind_Slice_Name => + Block_Name := Get_Prefix (Block_Spec); + when others => + Error_Msg_Sem ("label expected", Block_Spec); + return; + end case; + Block_Name := Sem_Denoting_Name (Block_Name); + Block := Get_Named_Entity (Block_Name); + case Get_Kind (Block) is + when Iir_Kind_Block_Statement => + if Block_Spec_Kind /= Iir_Kind_Simple_Name then + Error_Msg_Sem + ("label does not denote a generate statement", + Block_Spec); + end if; + Prev := Get_Block_Block_Configuration (Block); + if Prev /= Null_Iir then + Error_Msg_Sem + (Disp_Node (Block) & " was already configured at " + & Disp_Location (Prev), + Block_Conf); + return; + end if; + Set_Block_Block_Configuration (Block, Block_Conf); + when Iir_Kind_Generate_Statement => + if Block_Spec_Kind /= Iir_Kind_Simple_Name + and then Get_Kind (Get_Generation_Scheme (Block)) + /= Iir_Kind_Iterator_Declaration + then + -- LRM93 1.3 + -- If the block specification of a block configuration + -- contains a generate statement label, and if this + -- label contains an index specification, then it is + -- an error if the generate statement denoted by the + -- label does not have a generation scheme including + -- the reserved word for. + Error_Msg_Sem ("generate statement does not has a for", + Block_Spec); + return; + end if; + Set_Prev_Block_Configuration + (Block_Conf, Get_Generate_Block_Configuration (Block)); + Set_Generate_Block_Configuration (Block, Block_Conf); + when others => + Error_Msg_Sem ("block statement label expected", + Block_Conf); + return; + end case; + Block_Stmts := Get_Concurrent_Statement_Chain + (Get_Block_From_Block_Specification + (Get_Block_Specification (Father))); + if not Is_In_Chain (Block_Stmts, Block) then + Error_Msg_Sem + ("label does not denotes an inner block statement", + Block_Conf); + return; + end if; + + if Block_Spec_Kind = Iir_Kind_Parenthesis_Name then + Block_Spec := Sem_Index_Specification + (Block_Spec, Get_Type (Get_Generation_Scheme (Block))); + if Block_Spec /= Null_Iir then + Set_Prefix (Block_Spec, Block_Name); + Set_Block_Specification (Block_Conf, Block_Spec); + Block_Spec_Kind := Get_Kind (Block_Spec); + end if; + end if; + + case Block_Spec_Kind is + when Iir_Kind_Simple_Name => + Set_Block_Specification (Block_Conf, Block_Name); + when Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name => + null; + when Iir_Kind_Parenthesis_Name => + null; + when others => + raise Internal_Error; + end case; + end; + + when others => + Error_Kind ("sem_block_configuration", Father); + end case; + + -- LRM93 §10.1 + -- 10. A block configuration + Sem_Scopes.Open_Scope_Extension; + + -- LRM 10.3 + -- In addition, any declaration that is directly visible at the end of + -- the declarative part of a given block is directly visible in a block + -- configuration that configure the given block. This rule holds unless + -- a use clause that makes a homograph of the declaration potentially + -- visible (see 10.4) appears in the corresponding configuration + -- declaration, and if the scope of that use clause encompasses all or + -- part of those configuration items. If such a use clase appears, then + -- the declaration will be directly visible within the corresponding + -- configuration items, except at hose places that fall within the scope + -- of the additional use clause. At such places, neither name will be + -- directly visible. + -- FIXME: handle use clauses. + Sem_Scopes.Extend_Scope_Of_Block_Declarations (Block); + + declare + El : Iir; + begin + El := Get_Declaration_Chain (Block_Conf); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause => + Sem_Use_Clause (El); + when others => + -- Parse checks there are only use clauses. + raise Internal_Error; + end case; + El := Get_Chain (El); + end loop; + end; + + -- VHDL 87: do not remove configuration specification in generate stmts. + Clear_Instantiation_Configuration (Block, False); + + El := Get_Configuration_Item_Chain (Block_Conf); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Block_Configuration => + Sem_Block_Configuration (El, Block_Conf); + when Iir_Kind_Component_Configuration => + Sem_Component_Configuration (El, Block_Conf); + when others => + Error_Kind ("sem_block_configuration(2)", El); + end case; + El := Get_Chain (El); + end loop; + Sem_Scopes.Close_Scope_Extension; + end Sem_Block_Configuration; + + -- LRM 1.3.2 + procedure Sem_Component_Configuration + (Conf : Iir_Component_Configuration; Father : Iir) + is + Block : Iir; + Configured_Block : Iir; + Binding : Iir; + Entity : Iir_Design_Unit; + Comp : Iir_Component_Declaration; + Primary_Entity_Aspect : Iir; + begin + -- LRM 10.1 Declarative Region + -- 11. A component configuration. + Open_Declarative_Region; + + -- LRM93 §10.2 + -- If a component configuration appears as a configuration item + -- immediatly within a block configuration that configures a given + -- block, and the scope of a given declaration includes the end of the + -- declarative part of that block, then the scope of the given + -- declaration extends from the beginning to the end of the + -- declarative region associated with the given component configuration. + -- GHDL: this is for labels of component instantiation statements, and + -- for local ports and generics of the component. + if Get_Kind (Father) = Iir_Kind_Block_Configuration then + Configured_Block := Get_Block_Specification (Father); + if Get_Kind (Configured_Block) = Iir_Kind_Design_Unit then + raise Internal_Error; + end if; + Configured_Block := + Get_Block_From_Block_Specification (Configured_Block); + Sem_Scopes.Extend_Scope_Of_Block_Declarations (Configured_Block); + else + -- Can a component configuration not be just inside a block + -- configuration ? + raise Internal_Error; + end if; + -- FIXME: this is wrong (all declarations should be considered). + Sem_Component_Specification + (Configured_Block, Conf, Primary_Entity_Aspect); + + Comp := Get_Named_Entity (Get_Component_Name (Conf)); + if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then + -- There has been an error in sem_component_specification. + -- Leave here. + Close_Declarative_Region; + return; + end if; + + -- FIXME: (todo) + -- If a given component instance is unbound in the corresponding block, + -- then any explicit component configuration for that instance that does + -- not contain an explicit binding indication will contain an implicit, + -- default binding indication (see 5.2.2). Similarly, if a given + -- component instance is unbound in the corresponding block, then any + -- implicit component configuration for that instance will contain an + -- implicit, default binding indication. + Open_Declarative_Region; + Sem_Scopes.Add_Component_Declarations (Comp); + Binding := Get_Binding_Indication (Conf); + if Binding /= Null_Iir then + Sem_Binding_Indication (Binding, Comp, Conf, Primary_Entity_Aspect); + + if Primary_Entity_Aspect /= Null_Iir then + -- LRM93 5.2.1 Binding Indication + -- It is an error if a formal port appears in the port map aspect + -- of the incremental binding indication and it is a formal + -- port that is associated with an actual other than OPEN in one + -- of the primary binding indications. + declare + Inst : Iir; + Primary_Binding : Iir; + F_Chain : Iir; + F_El, S_El : Iir; + Formal : Iir; + begin + Inst := Get_Concurrent_Statement_Chain (Configured_Block); + while Inst /= Null_Iir loop + if Get_Kind (Inst) + = Iir_Kind_Component_Instantiation_Statement + and then Get_Component_Configuration (Inst) = Conf + then + -- Check here. + Primary_Binding := Get_Binding_Indication + (Get_Configuration_Specification (Inst)); + F_Chain := Get_Port_Map_Aspect_Chain (Primary_Binding); + S_El := Get_Port_Map_Aspect_Chain (Binding); + while S_El /= Null_Iir loop + -- Find S_EL formal in F_CHAIN. + Formal := Get_Association_Interface (S_El); + F_El := F_Chain; + while F_El /= Null_Iir loop + exit when Get_Association_Interface (F_El) = Formal; + F_El := Get_Chain (F_El); + end loop; + if F_El /= Null_Iir + and then Get_Kind (F_El) + /= Iir_Kind_Association_Element_Open + then + Error_Msg_Sem + (Disp_Node (Formal) + & " already associated in primary binding", + S_El); + end if; + S_El := Get_Chain (S_El); + end loop; + end if; + Inst := Get_Chain (Inst); + end loop; + end; + end if; + elsif Primary_Entity_Aspect = Null_Iir then + -- LRM93 5.2.1 + -- If the generic map aspect or port map aspect of a primary binding + -- indication is not present, then the default rules as described + -- in 5.2.2 apply. + + -- Create a default binding indication. + Entity := Get_Visible_Entity_Declaration (Comp); + Binding := Sem_Create_Default_Binding_Indication + (Comp, Entity, Conf, False); + + if Binding /= Null_Iir then + -- Remap to defaults. + Set_Default_Entity_Aspect (Binding, Get_Entity_Aspect (Binding)); + Set_Entity_Aspect (Binding, Null_Iir); + + Set_Default_Generic_Map_Aspect_Chain + (Binding, Get_Generic_Map_Aspect_Chain (Binding)); + Set_Generic_Map_Aspect_Chain (Binding, Null_Iir); + + Set_Default_Port_Map_Aspect_Chain + (Binding, Get_Port_Map_Aspect_Chain (Binding)); + Set_Port_Map_Aspect_Chain (Binding, Null_Iir); + + Set_Binding_Indication (Conf, Binding); + end if; + end if; + Close_Declarative_Region; + + -- External block. + Block := Get_Block_Configuration (Conf); + if Block /= Null_Iir and then Binding /= Null_Iir then + Sem_Block_Configuration (Block, Conf); + end if; + Close_Declarative_Region; + end Sem_Component_Configuration; + + function Are_Trees_Chain_Equal (Left, Right : Iir) return Boolean + is + El_Left, El_Right : Iir; + begin + if Left = Right then + return True; + end if; + El_Left := Left; + El_Right := Right; + loop + if El_Left = Null_Iir and El_Right = Null_Iir then + return True; + end if; + if El_Left = Null_Iir or El_Right = Null_Iir then + return False; + end if; + if not Are_Trees_Equal (El_Left, El_Right) then + return False; + end if; + El_Left := Get_Chain (El_Left); + El_Right := Get_Chain (El_Right); + end loop; + end Are_Trees_Chain_Equal; + + -- Return TRUE iff LEFT and RIGHT are (in depth) equal. + -- This corresponds to conformance rules, LRM93 2.7 + function Are_Trees_Equal (Left, Right : Iir) return Boolean + is + El_Left, El_Right : Iir; + begin + -- Short-cut to speed up. + if Left = Right then + return True; + end if; + + -- Handle null_iir. + if Left = Null_Iir or Right = Null_Iir then + -- Note: LEFT *xor* RIGHT is null_iir. + return False; + end if; + + -- LRM 2.7 Conformance Rules + -- A simple name can be replaced by an expanded name in which this + -- simple name is the selector, if and only if at both places the + -- meaning of the simple name is given by the same declaration. + case Get_Kind (Left) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + case Get_Kind (Right) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Are_Trees_Equal (Get_Named_Entity (Left), + Get_Named_Entity (Right)); + when others => + return False; + end case; + when others => + null; + end case; + + -- If nodes are not of the same kind, then they are not equals! + if Get_Kind (Left) /= Get_Kind (Right) then + return False; + end if; + + case Get_Kind (Left) is + when Iir_Kinds_Procedure_Declaration => + return Are_Trees_Chain_Equal + (Get_Interface_Declaration_Chain (Left), + Get_Interface_Declaration_Chain (Right)); + when Iir_Kinds_Function_Declaration => + if not Are_Trees_Equal (Get_Return_Type (Left), + Get_Return_Type (Right)) + then + return False; + end if; + if Get_Pure_Flag (Left) /= Get_Pure_Flag (Right) then + return False; + end if; + if not Are_Trees_Chain_Equal + (Get_Interface_Declaration_Chain (Left), + Get_Interface_Declaration_Chain (Right)) + then + return False; + end if; + return True; + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration => + if Get_Identifier (Left) /= Get_Identifier (Right) then + return False; + end if; + if Get_Lexical_Layout (Left) /= Get_Lexical_Layout (Right) + or else Get_Mode (Left) /= Get_Mode (Right) + then + return False; + end if; + if not Are_Trees_Equal (Get_Type (Left), Get_Type (Right)) then + return False; + end if; + El_Left := Get_Default_Value (Left); + El_Right := Get_Default_Value (Right); + if (El_Left = Null_Iir) xor (El_Right = Null_Iir) then + return False; + end if; + if El_Left /= Null_Iir + and then Are_Trees_Equal (El_Left, El_Right) = False + then + return False; + end if; + return True; + + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + if Get_Base_Type (Left) /= Get_Base_Type (Right) then + return False; + end if; + if Get_Type_Declarator (Left) /= Get_Type_Declarator (Right) then + return False; + end if; + if not Are_Trees_Equal (Get_Resolution_Indication (Left), + Get_Resolution_Indication (Right)) + then + return False; + end if; + if Are_Trees_Equal (Get_Range_Constraint (Left), + Get_Range_Constraint (Right)) = False + then + return False; + end if; + return True; + when Iir_Kind_Array_Subtype_Definition => + if Get_Base_Type (Left) /= Get_Base_Type (Right) then + return False; + end if; + if not Are_Trees_Equal (Get_Resolution_Indication (Left), + Get_Resolution_Indication (Right)) + then + return False; + end if; + declare + L_Left, L_Right : Iir_List; + begin + L_Left := Get_Index_Subtype_List (Left); + L_Right := Get_Index_Subtype_List (Right); + for I in Natural loop + El_Left := Get_Nth_Element (L_Left, I); + El_Right := Get_Nth_Element (L_Right, I); + exit when El_Left = Null_Iir; + if not Are_Trees_Equal (El_Left, El_Right) then + return False; + end if; + end loop; + end; + return True; + when Iir_Kind_Record_Subtype_Definition => + if Get_Base_Type (Left) /= Get_Base_Type (Right) then + return False; + end if; + if not Are_Trees_Equal (Get_Resolution_Indication (Left), + Get_Resolution_Indication (Right)) + then + return False; + end if; + declare + L_Left, L_Right : Iir_List; + begin + L_Left := Get_Elements_Declaration_List (Left); + L_Right := Get_Elements_Declaration_List (Right); + for I in Natural loop + El_Left := Get_Nth_Element (L_Left, I); + El_Right := Get_Nth_Element (L_Right, I); + exit when El_Left = Null_Iir; + if not Are_Trees_Equal (El_Left, El_Right) then + return False; + end if; + end loop; + end; + return True; + + when Iir_Kind_Integer_Literal => + if Get_Value (Left) /= Get_Value (Right) then + return False; + end if; + return Are_Trees_Equal (Get_Literal_Origin (Left), + Get_Literal_Origin (Right)); + when Iir_Kind_Enumeration_Literal => + if Get_Enum_Pos (Left) /= Get_Enum_Pos (Right) then + return False; + end if; + return Are_Trees_Equal (Get_Literal_Origin (Left), + Get_Literal_Origin (Right)); + when Iir_Kind_Physical_Int_Literal => + if Get_Value (Left) /= Get_Value (Right) + or else not Are_Trees_Equal (Get_Unit_Name (Left), + Get_Unit_Name (Right)) + then + return False; + end if; + return Are_Trees_Equal (Get_Literal_Origin (Left), + Get_Literal_Origin (Right)); + when Iir_Kind_Physical_Fp_Literal => + if Get_Fp_Value (Left) /= Get_Fp_Value (Right) + or else Get_Unit_Name (Left) /= Get_Unit_Name (Right) + then + return False; + end if; + return Are_Trees_Equal (Get_Literal_Origin (Left), + Get_Literal_Origin (Right)); + when Iir_Kind_Floating_Point_Literal => + if Get_Fp_Value (Left) /= Get_Fp_Value (Right) then + return False; + end if; + return Are_Trees_Equal (Get_Literal_Origin (Left), + Get_Literal_Origin (Right)); + + when Iir_Kinds_Dyadic_Operator => + return Are_Trees_Equal (Get_Left (Left), Get_Left (Right)) + and then Are_Trees_Equal (Get_Right (Left), Get_Right (Right)); + when Iir_Kinds_Monadic_Operator => + return Are_Trees_Equal (Get_Operand (Left), Get_Operand (Right)); + + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_File_Type_Definition => + return Left = Right; + + when Iir_Kind_Range_Expression => + if Get_Type (Left) /= Get_Type (Right) + or else Get_Direction (Left) /= Get_Direction (Right) + then + return False; + end if; + if not Are_Trees_Equal (Get_Left_Limit (Left), + Get_Left_Limit (Right)) + or else not Are_Trees_Equal (Get_Right_Limit (Left), + Get_Right_Limit (Right)) + then + return False; + end if; + return True; + + when Iir_Kind_High_Type_Attribute + | Iir_Kind_Low_Type_Attribute + | Iir_Kind_Left_Type_Attribute + | Iir_Kind_Right_Type_Attribute + | Iir_Kind_Ascending_Type_Attribute => + return Are_Trees_Equal (Get_Prefix (Left), Get_Prefix (Right)); + + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + if Get_Kind (Left) = Iir_Kind_Bit_String_Literal + and then Get_Bit_String_Base (Left) + /= Get_Bit_String_Base (Right) + then + return False; + end if; + declare + use Str_Table; + Len : Nat32; + L_Ptr : String_Fat_Acc; + R_Ptr : String_Fat_Acc; + begin + Len := Get_String_Length (Left); + if Get_String_Length (Right) /= Len then + return False; + end if; + L_Ptr := Get_String_Fat_Acc (Get_String_Id (Left)); + R_Ptr := Get_String_Fat_Acc (Get_String_Id (Right)); + for I in 1 .. Len loop + if L_Ptr (I) /= R_Ptr (I) then + return False; + end if; + end loop; + return True; + end; + + when Iir_Kind_Aggregate => + if not Are_Trees_Equal (Get_Type (Left), Get_Type (Right)) then + return False; + end if; + declare + El_L, El_R : Iir; + begin + El_L := Get_Association_Choices_Chain (Left); + El_R := Get_Association_Choices_Chain (Right); + loop + exit when El_L = Null_Iir and El_R = Null_Iir; + if not Are_Trees_Equal (El_L, El_R) then + return False; + end if; + El_L := Get_Chain (El_L); + El_R := Get_Chain (El_R); + end loop; + return True; + end; + + when Iir_Kind_Choice_By_None + | Iir_Kind_Choice_By_Others => + return Are_Trees_Equal (Get_Associated_Expr (Left), + Get_Associated_Expr (Right)); + when Iir_Kind_Choice_By_Name => + if not Are_Trees_Equal (Get_Choice_Name (Left), + Get_Choice_Name (Right)) + then + return False; + end if; + return Are_Trees_Equal (Get_Associated_Expr (Left), + Get_Associated_Expr (Right)); + when Iir_Kind_Choice_By_Expression => + if not Are_Trees_Equal (Get_Choice_Expression (Left), + Get_Choice_Expression (Right)) then + return False; + end if; + return Are_Trees_Equal (Get_Associated_Expr (Left), + Get_Associated_Expr (Right)); + when Iir_Kind_Choice_By_Range => + if not Are_Trees_Equal (Get_Choice_Range (Left), + Get_Choice_Range (Right)) then + return False; + end if; + return Are_Trees_Equal (Get_Associated_Expr (Left), + Get_Associated_Expr (Right)); + when Iir_Kind_Character_Literal => + return Are_Trees_Equal (Get_Named_Entity (Left), + Get_Named_Entity (Right)); + when others => + Error_Kind ("are_trees_equal", Left); + end case; + end Are_Trees_Equal; + + -- LRM 2.7 Conformance Rules. + procedure Check_Conformance_Rules (Subprg, Spec: Iir) is + begin + if not Are_Trees_Equal (Subprg, Spec) then + -- FIXME: should explain why it does not conform ? + Error_Msg_Sem ("body of " & Disp_Node (Subprg) + & " does not conform with specification at " + & Disp_Location (Spec), Subprg); + end if; + end Check_Conformance_Rules; + + -- Return the specification corresponding to a declaration DECL, or + -- null_Iir if none. + -- FIXME: respect rules of LRM93 2.7 + function Find_Subprogram_Specification (Decl: Iir) return Iir + is + Interpretation : Name_Interpretation_Type; + Decl1: Iir; + Hash : Iir_Int32; + Kind : Iir_Kind; + begin + Hash := Get_Subprogram_Hash (Decl); + Interpretation := Get_Interpretation (Get_Identifier (Decl)); + while Valid_Interpretation (Interpretation) loop + if not Is_In_Current_Declarative_Region (Interpretation) then + -- The declaration does not belong to the current declarative + -- region, neither will the following one. So, we do not found + -- it. + return Null_Iir; + end if; + Decl1 := Get_Declaration (Interpretation); + Kind := Get_Kind (Decl1); + -- Should be sure DECL1 and DECL belongs to the same declarative + -- region, ie DECL1 was not made visible via a USE clause. + -- + -- Also, only check for explicitly subprograms (and not + -- implicit one). + if (Kind = Iir_Kind_Function_Declaration + or Kind = Iir_Kind_Procedure_Declaration) + and then not Is_Potentially_Visible (Interpretation) + and then Get_Subprogram_Hash (Decl1) = Hash + and then Is_Same_Profile (Decl, Decl1) + then + return Decl1; + end if; + Interpretation := Get_Next_Interpretation (Interpretation); + end loop; + return Null_Iir; + end Find_Subprogram_Specification; + + procedure Set_Subprogram_Overload_Number (Decl : Iir) + is + Id : constant Name_Id := Get_Identifier (Decl); + Inter : Name_Interpretation_Type; + Prev : Iir; + Num : Iir_Int32; + begin + Inter := Get_Interpretation (Id); + while Valid_Interpretation (Inter) + and then Is_In_Current_Declarative_Region (Inter) + loop + -- There is a previous declaration with the same name in the + -- current declarative region. + Prev := Get_Declaration (Inter); + case Get_Kind (Prev) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- The previous declaration is a user subprogram. + Num := Get_Overload_Number (Prev) + 1; + if Num = 1 + and then Get_Parent (Prev) = Get_Parent (Decl) + then + -- The previous was not (yet) overloaded. Mark it as + -- overloaded. + -- Do not mark it if it is not in the same declarative part. + -- (ie, do not change a subprogram declaration in the + -- package while analyzing the body). + 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 Iir_Kind_Enumeration_Literal => + -- Enumeration literal are ignored for overload number. + Inter := Get_Next_Interpretation (Inter); + when others => + -- An error ? + Set_Overload_Number (Decl, 0); + return; + end case; + 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 + -- SUBPRG. Requirements only concern operators, and are defined in + -- LRM 2.3.1 + procedure Check_Operator_Requirements (Id : Name_Id; Subprg : Iir) + is + use Std_Names; + + Nbr_Interfaces : Natural; + Is_Method : Boolean; + begin + Nbr_Interfaces := Iir_Chains.Get_Chain_Length + (Get_Interface_Declaration_Chain (Subprg)); + + -- For vhdl-02, the protected variable is an implicit parameter. + if Flags.Vhdl_Std >= Vhdl_02 + and then Is_Subprogram_Method (Subprg) + then + Nbr_Interfaces := Nbr_Interfaces + 1; + else + Is_Method := False; + end if; + + case Id is + when Name_Abs + | Name_Not => + -- LRM93 2.3.1 + -- The subprogram specification of a unary operator must have a + -- single parameter. + + -- LRM02 2.3.1 + -- ..., unless the subprogram specification is a method (see + -- 3.5.1) of a protected type. In this latter case, the + -- subprogram specification must have no parameters. + if Nbr_Interfaces = 1 then + return; + end if; + Error_Msg_Sem ("unary operator must have a single parameter", + Subprg); + when Name_Mod + | Name_Rem + | Name_Op_Mul + | Name_Op_Div + | Name_Relational_Operators + | Name_Op_Concatenation + | Name_Shift_Operators + | Name_Op_Exp => + -- LRM93 2.3.1 + -- The subprogram specification of a binary operator must have + -- two parameters. + + -- LRM02 2.3.1 + -- ..., unless the subprogram specification is a method of a + -- protected type, in which case, the subprogram specification + -- must have a single parameter. + if Nbr_Interfaces = 2 then + return; + end if; + 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 + -- For each of the operators "+" and "-", overloading is allowed + -- both as a unary operator and as a binary operator. + if Nbr_Interfaces in 1 .. 2 then + return; + end if; + Error_Msg_Sem + ("""+"" and ""-"" operators must have 1 or 2 parameters", + Subprg); + when others => + return; + end case; + if Is_Method then + Error_Msg_Sem + (" (the protected object is an implicit parameter of methods)", + Subprg); + end if; + end Check_Operator_Requirements; + + procedure Compute_Subprogram_Hash (Subprg : Iir) + is + type Hash_Type is mod 2**32; + function To_Hash is new Ada.Unchecked_Conversion + (Source => Iir, Target => Hash_Type); + function To_Int32 is new Ada.Unchecked_Conversion + (Source => Hash_Type, Target => Iir_Int32); + + Kind : Iir_Kind; + Hash : Hash_Type; + Sig : Hash_Type; + Inter : Iir; + Itype : Iir; + begin + Kind := Get_Kind (Subprg); + if Kind in Iir_Kinds_Function_Declaration + or else Kind = Iir_Kind_Enumeration_Literal + then + Itype := Get_Base_Type (Get_Return_Type (Subprg)); + Hash := To_Hash (Itype); + Sig := 8; + else + Sig := 1; + Hash := 0; + end if; + + if Kind /= Iir_Kind_Enumeration_Literal then + Inter := Get_Interface_Declaration_Chain (Subprg); + while Inter /= Null_Iir loop + Itype := Get_Base_Type (Get_Type (Inter)); + Sig := Sig + 1; + Hash := Hash * 7 + To_Hash (Itype); + Hash := Hash + Hash / 2**28; + Inter := Get_Chain (Inter); + end loop; + end if; + Set_Subprogram_Hash (Subprg, To_Int32 (Hash + Sig)); + end Compute_Subprogram_Hash; + + -- LRM 2.1 Subprogram Declarations. + procedure Sem_Subprogram_Declaration (Subprg: Iir) + is + Spec: Iir; + Interface_Chain : Iir; + Subprg_Body : Iir; + Return_Type : Iir; + begin + -- Set depth. + declare + Parent : constant Iir := Get_Parent (Subprg); + begin + case Get_Kind (Parent) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + raise Internal_Error; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Set_Subprogram_Depth + (Subprg, + Get_Subprogram_Depth + (Get_Subprogram_Specification (Parent)) + 1); + when others => + Set_Subprogram_Depth (Subprg, 0); + end case; + end; + + -- LRM 10.1 Declarative Region + -- 3. A subprogram declaration, together with the corresponding + -- subprogram body. + Open_Declarative_Region; + + -- Sem interfaces. + Interface_Chain := Get_Interface_Declaration_Chain (Subprg); + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration => + Sem_Interface_Chain + (Interface_Chain, Function_Parameter_Interface_List); + Return_Type := Get_Return_Type_Mark (Subprg); + Return_Type := Sem_Type_Mark (Return_Type); + Set_Return_Type_Mark (Subprg, Return_Type); + Set_Return_Type (Subprg, Get_Type (Return_Type)); + Set_All_Sensitized_State (Subprg, Unknown); + when Iir_Kind_Procedure_Declaration => + Sem_Interface_Chain + (Interface_Chain, Procedure_Parameter_Interface_List); + -- Unless the body is analyzed, the procedure purity is unknown. + Set_Purity_State (Subprg, Unknown); + -- Check if the procedure is passive. + Set_Passive_Flag (Subprg, True); + Set_All_Sensitized_State (Subprg, Unknown); + declare + Inter : Iir; + begin + Inter := Interface_Chain; + while Inter /= Null_Iir loop + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration + and then Get_Mode (Inter) /= Iir_In_Mode + then + -- There is a driver for this signal interface. + Set_Passive_Flag (Subprg, False); + exit; + end if; + Inter := Get_Chain (Inter); + end loop; + end; + when others => + Error_Kind ("sem_subprogram_declaration", Subprg); + end case; + + Check_Operator_Requirements (Get_Identifier (Subprg), Subprg); + + Compute_Subprogram_Hash (Subprg); + + -- The specification has been semantized, close the declarative region + -- now. + Close_Declarative_Region; + + -- Look if there is an associated body (the next node). + Subprg_Body := Get_Chain (Subprg); + if Subprg_Body /= Null_Iir + and then (Get_Kind (Subprg_Body) = Iir_Kind_Function_Body + or else Get_Kind (Subprg_Body) = Iir_Kind_Procedure_Body) + then + Spec := Find_Subprogram_Specification (Subprg); + else + Spec := Null_Iir; + end if; + + if Spec /= Null_Iir then + -- SUBPRG is the body of the specification SPEC. + Check_Conformance_Rules (Subprg, Spec); + Xref_Body (Subprg, Spec); + Set_Subprogram_Body (Subprg, Subprg_Body); + Set_Subprogram_Specification (Subprg_Body, Spec); + Set_Subprogram_Body (Spec, Subprg_Body); + else + -- Forward declaration or specification followed by body. + Set_Subprogram_Overload_Number (Subprg); + Sem_Scopes.Add_Name (Subprg); + Name_Visible (Subprg); + Xref_Decl (Subprg); + end if; + end Sem_Subprogram_Declaration; + + procedure Add_Analysis_Checks_List (El : Iir) + is + Design : constant Iir := Get_Current_Design_Unit; + List : Iir_List; + begin + List := Get_Analysis_Checks_List (Design); + if List = Null_Iir_List then + List := Create_Iir_List; + Set_Analysis_Checks_List (Design, List); + end if; + Add_Element (List, El); + end Add_Analysis_Checks_List; + + procedure Sem_Subprogram_Body (Subprg : Iir) + is + Spec : Iir; + El : Iir; + begin + Spec := Get_Subprogram_Specification (Subprg); + Set_Impure_Depth (Subprg, Iir_Depth_Pure); + + -- LRM 10.1 Declarative regions + -- 3. A subprogram declaration, together with the corresponding + -- subprogram body. + Open_Declarative_Region; + Set_Is_Within_Flag (Spec, True); + + -- Add the interface names into the current declarative region. + El := Get_Interface_Declaration_Chain (Spec); + while El /= Null_Iir loop + Add_Name (El, Get_Identifier (El), False); + if Get_Kind (El) = Iir_Kind_Interface_Signal_Declaration then + Set_Has_Active_Flag (El, False); + end if; + El := Get_Chain (El); + end loop; + + Sem_Sequential_Statements (Spec, Subprg); + + Set_Is_Within_Flag (Spec, False); + Close_Declarative_Region; + + case Get_Kind (Spec) is + when Iir_Kind_Procedure_Declaration => + -- Update purity state of procedure if there are no callees. + case Get_Purity_State (Spec) is + when Pure + | Maybe_Impure => + -- We can't know this yet. + raise Internal_Error; + when Impure => + null; + when Unknown => + if Get_Callees_List (Subprg) = Null_Iir_List then + -- Since there are no callees, purity state can + -- be updated. + if Get_Impure_Depth (Subprg) = Iir_Depth_Pure then + Set_Purity_State (Spec, Pure); + else + Set_Purity_State (Spec, Maybe_Impure); + end if; + end if; + end case; + + -- Update wait state if the state of all callees is known. + if Get_Wait_State (Spec) = Unknown then + declare + Callees : Iir_List; + Callee : Iir; + State : Tri_State_Type; + begin + Callees := Get_Callees_List (Subprg); + -- Per default, has no wait. + Set_Wait_State (Spec, False); + if Callees /= Null_Iir_List then + for I in Natural loop + Callee := Get_Nth_Element (Callees, I); + exit when Callee = Null_Iir; + case Get_Kind (Callee) is + when Iir_Kinds_Function_Declaration => + null; + when Iir_Kind_Procedure_Declaration => + State := Get_Wait_State (Callee); + case State is + when False => + null; + when Unknown => + -- Yet unknown, but can be TRUE. + Set_Wait_State (Spec, Unknown); + when True => + -- Can this happen ? + raise Internal_Error; + --Set_Wait_State (Spec, True); + --exit; + end case; + when Iir_Kind_Implicit_Procedure_Declaration => + null; + when others => + Error_Kind ("sem_subprogram_body(2)", Callee); + end case; + end loop; + end if; + end; + end if; + + -- Set All_Sensitized_State in trivial cases. + if Get_All_Sensitized_State (Spec) = Unknown + and then Get_Callees_List (Subprg) = Null_Iir_List + then + Set_All_Sensitized_State (Spec, No_Signal); + end if; + + -- Do not add to Analysis_Check_List as procedures can't + -- generate purity/wait/all-sensitized errors by themselves. + + when Iir_Kind_Function_Declaration => + if Get_Callees_List (Subprg) /= Null_Iir_List then + -- Purity calls to be checked later. + -- No wait statements in procedures called. + Add_Analysis_Checks_List (Spec); + end if; + when others => + Error_Kind ("sem_subprogram_body", Spec); + end case; + end Sem_Subprogram_Body; + + -- Status of Update_And_Check_Pure_Wait. + type Update_Pure_Status is + ( + -- The purity/wait/all-sensitized are computed and known. + Update_Pure_Done, + -- A missing body prevents from computing the purity/wait/all-sensitized + Update_Pure_Missing, + -- Purity/wait/all-sensitized is unknown (recursion). + Update_Pure_Unknown + ); + + function Update_And_Check_Pure_Wait (Subprg : Iir) return Update_Pure_Status + is + procedure Error_Wait (Caller : Iir; Callee : Iir) is + begin + Error_Msg_Sem + (Disp_Node (Caller) & " must not contain wait statement, but calls", + Caller); + Error_Msg_Sem + (Disp_Node (Callee) & " which has (indirectly) a wait statement", + Callee); + end Error_Wait; + + -- Kind of subprg. + type Caller_Kind is (K_Function, K_Process, K_Procedure); + Kind : Caller_Kind; + + Callees_List : Iir_List; + Callees_List_Holder : Iir; + Callee : Iir; + Callee_Orig : Iir; + Callee_Bod : Iir; + Subprg_Depth : Iir_Int32; + Subprg_Bod : Iir; + -- Current purity depth of SUBPRG. + Depth : Iir_Int32; + Depth_Callee : Iir_Int32; + Has_Wait_Errors : Boolean := False; + Npos : Natural; + Res, Res1 : Update_Pure_Status; + begin + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration => + Kind := K_Function; + Subprg_Bod := Get_Subprogram_Body (Subprg); + Subprg_Depth := Get_Subprogram_Depth (Subprg); + Callees_List_Holder := Subprg_Bod; + if Get_Pure_Flag (Subprg) then + Depth := Iir_Depth_Pure; + else + Depth := Iir_Depth_Impure; + end if; + + when Iir_Kind_Procedure_Declaration => + Kind := K_Procedure; + Subprg_Bod := Get_Subprogram_Body (Subprg); + if Get_Purity_State (Subprg) = Impure + and then Get_Wait_State (Subprg) /= Unknown + and then Get_All_Sensitized_State (Subprg) /= Unknown + then + -- No need to go further. + if Get_All_Sensitized_State (Subprg) = No_Signal + or else Vhdl_Std < Vhdl_08 + then + Callees_List := Get_Callees_List (Subprg_Bod); + Destroy_Iir_List (Callees_List); + Set_Callees_List (Subprg_Bod, Null_Iir_List); + end if; + return Update_Pure_Done; + end if; + Subprg_Depth := Get_Subprogram_Depth (Subprg); + Depth := Get_Impure_Depth (Subprg_Bod); + Callees_List_Holder := Subprg_Bod; + + when Iir_Kind_Sensitized_Process_Statement => + Kind := K_Process; + Subprg_Bod := Null_Iir; + Subprg_Depth := Iir_Depth_Top; + Depth := Iir_Depth_Impure; + Callees_List_Holder := Subprg; + + when others => + Error_Kind ("update_and_check_pure_wait(1)", Subprg); + end case; + + -- If the subprogram has no callee list, there is nothing to do. + Callees_List := Get_Callees_List (Callees_List_Holder); + if Callees_List = Null_Iir_List then + -- There are two reasons why a callees_list is null: + -- * either because SUBPRG does not call any procedure + -- in this case, the status are already known and we should have + -- returned in the above case. + -- * or because of a recursion + -- in this case the status are still unknown here. + return Update_Pure_Unknown; + end if; + + -- By default we don't know the status. + Res := Update_Pure_Unknown; + + -- This subprogram is being considered. + -- To avoid infinite loop, suppress its callees list. + Set_Callees_List (Callees_List_Holder, Null_Iir_List); + + -- First loop: check without recursion. + -- Second loop: recurse if necessary. + for J in 0 .. 1 loop + Npos := 0; + for I in Natural loop + Callee := Get_Nth_Element (Callees_List, I); + exit when Callee = Null_Iir; + + -- Note: + -- Pure functions should not be in the list. + -- Impure functions must have directly set Purity_State. + + -- Check pure. + Callee_Bod := Get_Subprogram_Body (Callee); + + if Callee_Bod = Null_Iir then + -- The body of subprograms may not be set for instances. + -- Use the body from the generic (if any). + Callee_Orig := Sem_Inst.Get_Origin (Callee); + if Callee_Orig /= Null_Iir then + Callee_Bod := Get_Subprogram_Body (Callee_Orig); + Set_Subprogram_Body (Callee, Callee_Bod); + end if; + end if; + + if Callee_Bod = Null_Iir then + -- No body yet for the subprogram called. + -- Nothing can be extracted from it, postpone the checks until + -- elaboration. + Res := Update_Pure_Missing; + else + -- Second loop: recurse if a state is not known. + if J = 1 + and then + ((Get_Kind (Callee) = Iir_Kind_Procedure_Declaration + and then Get_Purity_State (Callee) = Unknown) + or else Get_Wait_State (Callee) = Unknown + or else Get_All_Sensitized_State (Callee) = Unknown) + then + Res1 := Update_And_Check_Pure_Wait (Callee); + if Res1 = Update_Pure_Missing then + Res := Update_Pure_Missing; + end if; + end if; + + -- Check purity only if the subprogram is not impure. + if Depth /= Iir_Depth_Impure then + Depth_Callee := Get_Impure_Depth (Callee_Bod); + + -- Check purity depth. + if Depth_Callee < Subprg_Depth then + -- The call is an impure call because it calls an outer + -- subprogram (or an impure subprogram). + -- FIXME: check the compare. + Depth_Callee := Iir_Depth_Impure; + if Kind = K_Function then + -- FIXME: report call location + Error_Pure (Subprg_Bod, Callee, Null_Iir); + end if; + end if; + + -- Update purity depth. + if Depth_Callee < Depth then + Depth := Depth_Callee; + if Kind = K_Procedure then + -- Update for recursivity. + Set_Impure_Depth (Subprg_Bod, Depth); + if Depth = Iir_Depth_Impure then + Set_Purity_State (Subprg, Impure); + end if; + end if; + end if; + end if; + end if; + + -- Check wait. + if Has_Wait_Errors = False + and then Get_Wait_State (Callee) = True + then + if Kind = K_Procedure then + Set_Wait_State (Subprg, True); + else + Error_Wait (Subprg, Callee); + Has_Wait_Errors := True; + end if; + end if; + + if Get_All_Sensitized_State (Callee) = Invalid_Signal then + case Kind is + when K_Function | K_Procedure => + Set_All_Sensitized_State (Subprg, Invalid_Signal); + when K_Process => + -- LRM08 11.3 + -- + -- It is an error if a process statement with the + -- reserved word ALL as its process sensitivity list + -- is the parent of a subprogram declared in a design + -- unit other than that containing the process statement + -- and the subprogram reads an explicitly declared + -- signal that is not a formal signal parameter or + -- member of a formal signal parameter of the + -- subprogram or of any of its parents. Similarly, + -- it is an error if such subprogram reads an implicit + -- signal whose explicit ancestor is not a formal signal + -- parameter or member of a formal parameter of + -- the subprogram or of any of its parents. + Error_Msg_Sem + ("all-sensitized " & Disp_Node (Subprg) + & " can't call " & Disp_Node (Callee), Subprg); + Error_Msg_Sem + (" (as this subprogram reads (indirectly) a signal)", + Subprg); + end case; + end if; + + -- Keep in list. + if Callee_Bod = Null_Iir + or else + (Get_Kind (Callee) = Iir_Kind_Procedure_Declaration + and then Get_Purity_State (Callee) = Unknown + and then Depth /= Iir_Depth_Impure) + or else + (Get_Wait_State (Callee) = Unknown + and then (Kind /= K_Procedure + or else Get_Wait_State (Subprg) = Unknown)) + or else + (Vhdl_Std >= Vhdl_08 + and then + (Get_All_Sensitized_State (Callee) = Unknown + or else Get_All_Sensitized_State (Callee) = Read_Signal)) + then + Replace_Nth_Element (Callees_List, Npos, Callee); + Npos := Npos + 1; + end if; + end loop; + + -- End of callee loop. + if Npos = 0 then + Destroy_Iir_List (Callees_List); + Callees_List := Null_Iir_List; + if Kind = K_Procedure then + if Get_Purity_State (Subprg) = Unknown then + Set_Purity_State (Subprg, Maybe_Impure); + end if; + if Get_Wait_State (Subprg) = Unknown then + Set_Wait_State (Subprg, False); + end if; + end if; + if Kind = K_Procedure or Kind = K_Function then + if Get_All_Sensitized_State (Subprg) = Unknown then + Set_All_Sensitized_State (Subprg, No_Signal); + end if; + end if; + Res := Update_Pure_Done; + exit; + else + Set_Nbr_Elements (Callees_List, Npos); + end if; + end loop; + + Set_Callees_List (Callees_List_Holder, Callees_List); + + return Res; + end Update_And_Check_Pure_Wait; + + -- Check pure/wait/all-sensitized issues for SUBPRG (subprogram or + -- process). Return False if the analysis is incomplete (and must + -- be deferred). + function Root_Update_And_Check_Pure_Wait (Subprg : Iir) return Boolean + is + Res : Update_Pure_Status; + begin + Res := Update_And_Check_Pure_Wait (Subprg); + case Res is + when Update_Pure_Done => + return True; + when Update_Pure_Missing => + return False; + when Update_Pure_Unknown => + -- The purity/wait is unknown, but all callee were walked. + -- This means there are recursive calls but without violations. + if Get_Kind (Subprg) = Iir_Kind_Procedure_Declaration then + if Get_Purity_State (Subprg) = Unknown then + Set_Purity_State (Subprg, Maybe_Impure); + end if; + if Get_Wait_State (Subprg) = Unknown then + Set_Wait_State (Subprg, False); + end if; + end if; + if Get_Kind (Subprg) in Iir_Kinds_Subprogram_Declaration then + if Get_All_Sensitized_State (Subprg) = Unknown then + Set_All_Sensitized_State (Subprg, No_Signal); + end if; + end if; + return True; + end case; + end Root_Update_And_Check_Pure_Wait; + + procedure Sem_Analysis_Checks_List (Unit : Iir_Design_Unit; + Emit_Warnings : Boolean) + is + List : Iir_List := Get_Analysis_Checks_List (Unit); + El : Iir; + Npos : Natural; + Keep : Boolean; + Callees : Iir_List; + Callee : Iir; + begin + if List = Null_Iir_List then + -- Return now if there is nothing to check. + return; + end if; + + Npos := 0; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Keep := False; + case Get_Kind (El) is + when Iir_Kind_Function_Declaration => + -- FIXME: remove from list if fully tested ? + if not Root_Update_And_Check_Pure_Wait (El) then + Keep := True; + if Emit_Warnings then + Callees := Get_Callees_List (El); + pragma Assert (Callees /= Null_Iir_List); + Warning_Msg_Sem + ("can't assert that all calls in " & Disp_Node (El) + & " are pure or have not wait; " + & "will be checked at elaboration", El); + Callee := Get_Nth_Element (Callees, 0); + -- FIXME: could improve this message by displaying the + -- chain of calls until the first subprograms in + -- unknown state. + Warning_Msg_Sem + ("(first such call is to " & Disp_Node (Callee) & ")", + Callee); + end if; + end if; + when Iir_Kind_Sensitized_Process_Statement => + if not Root_Update_And_Check_Pure_Wait (El) then + Keep := True; + if Emit_Warnings then + Warning_Msg_Sem + ("can't assert that " & Disp_Node (El) + & " has not wait; will be checked at elaboration", El); + end if; + end if; + when others => + Error_Kind ("sem_analysis_checks_list", El); + end case; + if Keep then + Replace_Nth_Element (List, Npos, El); + Npos := Npos + 1; + end if; + end loop; + if Npos = 0 then + Destroy_Iir_List (List); + Set_Analysis_Checks_List (Unit, Null_Iir_List); + else + Set_Nbr_Elements (List, Npos); + end if; + end Sem_Analysis_Checks_List; + + -- Return true if package declaration DECL needs a body. + -- Ie, it contains subprogram specification or deferred constants. + function Package_Need_Body_P (Decl: Iir_Package_Declaration) + return Boolean + is + El: Iir; + Def : Iir; + begin + El := Get_Declaration_Chain (Decl); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when Iir_Kind_Constant_Declaration => + if Get_Default_Value (El) = Null_Iir then + return True; + end if; + when Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + when Iir_Kind_Type_Declaration => + Def := Get_Type_Definition (El); + if Def /= Null_Iir + and then Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration + then + return True; + end if; + when Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration => + null; + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + null; + when Iir_Kind_Attribute_Declaration + | Iir_Kind_Attribute_Specification => + null; + when Iir_Kind_Disconnection_Specification => + null; + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Component_Declaration => + null; + when Iir_Kind_Protected_Type_Body => + null; + when Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration => + null; + when Iir_Kind_Terminal_Declaration => + null; + when others => + Error_Kind ("package_need_body_p", El); + end case; + El := Get_Chain (El); + end loop; + return False; + end Package_Need_Body_P; + + -- LRM 2.5 Package Declarations. + procedure Sem_Package_Declaration (Decl: Iir_Package_Declaration) + is + Unit : Iir_Design_Unit; + Implicit : Implicit_Signal_Declaration_Type; + Header : constant Iir := Get_Package_Header (Decl); + begin + Unit := Get_Design_Unit (Decl); + Sem_Scopes.Add_Name (Decl); + Set_Visible_Flag (Decl, True); + Xref_Decl (Decl); + + -- Identify IEEE.Std_Logic_1164 for VHDL08. + if Get_Identifier (Decl) = Std_Names.Name_Std_Logic_1164 + and then (Get_Identifier (Get_Library (Get_Design_File (Unit))) + = Std_Names.Name_Ieee) + then + Ieee.Std_Logic_1164.Std_Logic_1164_Pkg := Decl; + end if; + + -- LRM93 10.1 Declarative Region + -- 4. A package declaration, together with the corresponding + -- body (if any). + Open_Declarative_Region; + + Push_Signals_Declarative_Part (Implicit, Decl); + + if Header /= Null_Iir then + Sem_Interface_Chain + (Get_Generic_Chain (Header), Generic_Interface_List); + if Get_Generic_Map_Aspect_Chain (Header) /= Null_Iir then + -- FIXME: todo + raise Internal_Error; + end if; + end if; + + Sem_Declaration_Chain (Decl); + -- GHDL: subprogram bodies appear in package body. + + Pop_Signals_Declarative_Part (Implicit); + Close_Declarative_Region; + Set_Need_Body (Decl, Package_Need_Body_P (Decl)); + end Sem_Package_Declaration; + + -- LRM 2.6 Package Bodies. + procedure Sem_Package_Body (Decl: Iir) + is + Package_Ident: Name_Id; + Design_Unit: Iir_Design_Unit; + Package_Decl: Iir; + begin + -- First, find the package declaration. + Package_Ident := Get_Identifier (Decl); + Design_Unit := Libraries.Load_Primary_Unit + (Get_Library (Get_Design_File (Get_Current_Design_Unit)), + Package_Ident, Decl); + if Design_Unit = Null_Iir then + Error_Msg_Sem ("package '" & Name_Table.Image (Package_Ident) + & "' was not analysed", + Decl); + return; + end if; + Package_Decl := Get_Library_Unit (Design_Unit); + if Get_Kind (Package_Decl) /= Iir_Kind_Package_Declaration then + Error_Msg_Sem + ("primary unit '" & Name_Table.Image (Package_Ident) + & "' is not a package", Decl); + return; + end if; + + -- Emit a warning is a body is not necessary. + if not Get_Need_Body (Package_Decl) then + Warning_Msg_Sem + (Disp_Node (Package_Decl) & " does not require a body", Decl); + end if; + + Set_Package (Decl, Package_Decl); + Xref_Body (Decl, Package_Decl); + Set_Package_Body (Package_Decl, Decl); + Add_Dependence (Design_Unit); + + Add_Name (Design_Unit); + + -- Add the context clauses from the primary unit. + Add_Context_Clauses (Design_Unit); + + -- LRM93 10.1 Declarative Region + -- 4. A package declaration, together with the corresponding + -- body (if any). + Open_Declarative_Region; + + Sem_Scopes.Add_Package_Declarations (Package_Decl); + + Sem_Declaration_Chain (Decl); + Check_Full_Declaration (Decl, Decl); + Check_Full_Declaration (Package_Decl, Decl); + + Close_Declarative_Region; + end Sem_Package_Body; + + function Sem_Uninstantiated_Package_Name (Decl : Iir) return Iir + is + Name : Iir; + Pkg : Iir; + begin + Name := Sem_Denoting_Name (Get_Uninstantiated_Package_Name (Decl)); + Set_Uninstantiated_Package_Name (Decl, Name); + Pkg := Get_Named_Entity (Name); + if Get_Kind (Pkg) /= Iir_Kind_Package_Declaration then + Error_Class_Match (Name, "package"); + + -- What could be done ? + return Null_Iir; + elsif not Is_Uninstantiated_Package (Pkg) then + Error_Msg_Sem + (Disp_Node (Pkg) & " is not an uninstantiated package", Name); + + -- What could be done ? + return Null_Iir; + end if; + + return Pkg; + end Sem_Uninstantiated_Package_Name; + + -- LRM08 4.9 Package Instantiation Declaration + procedure Sem_Package_Instantiation_Declaration (Decl : Iir) + is + Hdr : Iir; + Pkg : Iir; + Bod : Iir_Design_Unit; + begin + Sem_Scopes.Add_Name (Decl); + Set_Visible_Flag (Decl, True); + Xref_Decl (Decl); + + -- LRM08 4.9 + -- The uninstantiated package name shall denote an uninstantiated + -- package declared in a package declaration. + Pkg := Sem_Uninstantiated_Package_Name (Decl); + if Pkg = Null_Iir then + -- What could be done ? + return; + end if; + + -- LRM08 4.9 + -- The generic map aspect, if present, optionally associates a single + -- actual with each formal generic (or member thereof) in the + -- corresponding package declaration. Each formal generic (or member + -- thereof) shall be associated at most once. + + -- GHDL: the generics are first instantiated (ie copied) and then + -- the actuals are associated with the instantiated formal. + -- FIXME: do it in Instantiate_Package_Declaration ? + Hdr := Get_Package_Header (Pkg); + if Sem_Generic_Association_Chain (Hdr, Decl) then + Sem_Inst.Instantiate_Package_Declaration (Decl, Pkg); + else + -- FIXME: stop analysis here ? + null; + end if; + + -- FIXME: unless the parent is a package declaration library unit, the + -- design unit depends on the body. + Bod := Libraries.Load_Secondary_Unit + (Get_Design_Unit (Pkg), Null_Identifier, Decl); + if Bod /= Null_Iir then + Add_Dependence (Bod); + end if; + end Sem_Package_Instantiation_Declaration; + + -- LRM 10.4 Use Clauses. + procedure Sem_Use_Clause (Clauses: Iir_Use_Clause) + is + Clause : Iir_Use_Clause; + Name: Iir; + Prefix: Iir; + Name_Prefix : Iir; + begin + Clause := Clauses; + loop + -- LRM93 10.4 + -- A use clause achieves direct visibility of declarations that are + -- visible by selection. + -- Each selected name is a use clause identifies one or more + -- declarations that will potentialy become directly visible. + + Name := Get_Selected_Name (Clause); + case Get_Kind (Name) is + when Iir_Kind_Selected_By_All_Name + | Iir_Kind_Selected_Name => + Name_Prefix := Get_Prefix (Name); + when others => + Error_Msg_Sem ("use clause allows only selected name", Name); + return; + end case; + + Name_Prefix := Sem_Denoting_Name (Name_Prefix); + Set_Prefix (Name, Name_Prefix); + Prefix := Get_Named_Entity (Name_Prefix); + if Is_Error (Prefix) then + -- FIXME: continue with the clauses + return; + end if; + + -- LRM 10.4 Use Clauses + -- + -- If the suffix of the selected name is [...], then the + -- selected name identifies only the declaration(s) of that + -- [...] contained within the package or library denoted by + -- the prefix of the selected name. + -- + -- If the suffix is the reserved word ALL, then the selected name + -- identifies all declarations that are contained within the package + -- or library denoted by the prefix of the selected name. + -- + -- GHDL: therefore, the suffix must be either a package or a library. + case Get_Kind (Prefix) is + when Iir_Kind_Library_Declaration => + null; + when Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Interface_Package_Declaration => + null; + when Iir_Kind_Package_Declaration => + -- LRM08 12.4 Use clauses + -- It is an error if the prefix of a selected name in a use + -- clause denotes an uninstantiated package. + if Is_Uninstantiated_Package (Prefix) then + Error_Msg_Sem + ("use of uninstantiated package is not allowed", + Name_Prefix); + return; + end if; + when others => + Error_Msg_Sem + ("prefix must designate a package or a library", Prefix); + return; + end case; + + case Get_Kind (Name) is + when Iir_Kind_Selected_Name => + Sem_Name (Name); + case Get_Kind (Get_Named_Entity (Name)) is + when Iir_Kind_Error => + -- Continue in case of error. + null; + when Iir_Kind_Overload_List => + -- Analyze is correct as is. + null; + when others => + Name := Finish_Sem_Name (Name); + Set_Selected_Name (Clause, Name); + end case; + when Iir_Kind_Selected_By_All_Name => + null; + when others => + raise Internal_Error; + end case; + + Clause := Get_Use_Clause_Chain (Clause); + exit when Clause = Null_Iir; + end loop; + + -- LRM 10.4 + -- For each use clause, there is a certain region of text called the + -- scope of the use clause. This region starts immediatly after the + -- use clause. + Sem_Scopes.Add_Use_Clause (Clauses); + end Sem_Use_Clause; + + -- LRM 11.2 Design Libraries. + procedure Sem_Library_Clause (Decl: Iir_Library_Clause) + is + Ident : Name_Id; + Lib: Iir; + begin + -- GHDL: 'redeclaration' is handled in sem_scopes. + + Ident := Get_Identifier (Decl); + Lib := Libraries.Get_Library (Ident, Get_Location (Decl)); + if Lib = Null_Iir then + Error_Msg_Sem + ("no resource library """ & Name_Table.Image (Ident) & """", Decl); + else + Set_Library_Declaration (Decl, Lib); + Sem_Scopes.Add_Name (Lib, Ident, False); + Set_Visible_Flag (Lib, True); + Xref_Ref (Decl, Lib); + end if; + end Sem_Library_Clause; + + -- LRM 11.3 Context Clauses. + procedure Sem_Context_Clauses (Design_Unit: Iir_Design_Unit) + is + El: Iir; + begin + El := Get_Context_Items (Design_Unit); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause => + Sem_Use_Clause (El); + when Iir_Kind_Library_Clause => + Sem_Library_Clause (El); + when others => + Error_Kind ("sem_context_clauses", El); + end case; + El := Get_Chain (El); + end loop; + end Sem_Context_Clauses; + + -- Access to the current design unit. This is set, saved, restored, cleared + -- by the procedure semantic. + Current_Design_Unit: Iir_Design_Unit := Null_Iir; + + function Get_Current_Design_Unit return Iir_Design_Unit is + begin + return Current_Design_Unit; + end Get_Current_Design_Unit; + + -- LRM 11.1 Design units. + procedure Semantic (Design_Unit: Iir_Design_Unit) + is + El: Iir; + Old_Design_Unit: Iir_Design_Unit; + Implicit : Implicit_Signal_Declaration_Type; + begin + -- Sanity check: can analyze either previously analyzed unit or just + -- parsed unit. + case Get_Date (Design_Unit) is + when Date_Parsed => + Set_Date (Design_Unit, Date_Analyzing); + when Date_Valid => + null; + when Date_Obsolete => + -- This happens only when design files are added into the library + -- and keeping obsolete units (eg: to pretty print a file). + Set_Date (Design_Unit, Date_Analyzing); + when others => + raise Internal_Error; + end case; + + -- Save and set current_design_unit. + Old_Design_Unit := Current_Design_Unit; + Current_Design_Unit := Design_Unit; + Push_Signals_Declarative_Part (Implicit, Null_Iir); + + -- Be sure the name table is empty. + -- It is empty at start-up, or saved before recursing. + pragma Debug (Name_Table.Assert_No_Infos); + + -- LRM02 10.1 Declarative Region. + -- In addition to the above declarative region, there is a root + -- declarative region, not associated with a portion of the text of the + -- description, but encompassing any given primary unit. At the + -- beginning of the analysis of a given primary unit, there are no + -- declarations whose scopes (see 10.2) are within the root declarative + -- region. Moreover, the root declarative region associated with any + -- given secondary unit is the root declarative region of the + -- corresponding primary unit. + -- GHDL: for any revision of VHDL, a root declarative region is created, + -- due to reasons given by LCS 3 (VHDL Issue # 1028). + Open_Declarative_Region; + + -- Set_Dependence_List (Design_Unit, +-- Create_Iir (Iir_Kind_Design_Unit_List)); + + -- LRM 11.2 + -- Every design unit is assumed to contain the following implicit + -- context items as part of its context clause: + -- library STD, WORK; use STD.STANDARD.all; + Sem_Scopes.Add_Name (Libraries.Std_Library, Std_Names.Name_Std, False); + Sem_Scopes.Add_Name (Get_Library (Get_Design_File (Design_Unit)), + Std_Names.Name_Work, + False); + Sem_Scopes.Use_All_Names (Standard_Package); + if Get_Dependence_List (Design_Unit) = Null_Iir_List then + Set_Dependence_List (Design_Unit, Create_Iir_List); + end if; + Add_Dependence (Std_Standard_Unit); + + -- Semantic on context clauses. + Sem_Context_Clauses (Design_Unit); + + -- semantic on the library unit. + El := Get_Library_Unit (Design_Unit); + case Get_Kind (El) is + when Iir_Kind_Entity_Declaration => + Sem_Entity_Declaration (El); + when Iir_Kind_Architecture_Body => + Sem_Architecture_Body (El); + when Iir_Kind_Package_Declaration => + Sem_Package_Declaration (El); + when Iir_Kind_Package_Body => + Sem_Package_Body (El); + when Iir_Kind_Configuration_Declaration => + Sem_Configuration_Declaration (El); + when Iir_Kind_Package_Instantiation_Declaration => + Sem_Package_Instantiation_Declaration (El); + when others => + Error_Kind ("semantic", El); + end case; + + Close_Declarative_Region; + + if Get_Date (Design_Unit) = Date_Analyzing then + Set_Date (Design_Unit, Date_Analyzed); + end if; + + if Get_Analysis_Checks_List (Design_Unit) /= Null_Iir_List then + Sem_Analysis_Checks_List (Design_Unit, False); + end if; + + -- Restore current_design_unit. + Current_Design_Unit := Old_Design_Unit; + Pop_Signals_Declarative_Part (Implicit); + end Semantic; +end Sem; diff --git a/src/vhdl/sem.ads b/src/vhdl/sem.ads new file mode 100644 index 000000000..5586483a1 --- /dev/null +++ b/src/vhdl/sem.ads @@ -0,0 +1,82 @@ +-- Semantic analysis pass. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; +with Types; use Types; + +package Sem is + -- Semantic analysis for chapters 1, 2, 10 (uses clauses) and 11. + + -- Do the semantic analysis of design unit DESIGN_UNIT. + -- Also add a few node or change some nodes, when for exemple an + -- identifier is changed into an access to the type. + procedure Semantic (Design_Unit: Iir_Design_Unit); + + -- Get the current design unit, ie, the parameter of the procedure semantic. + function Get_Current_Design_Unit return Iir_Design_Unit; + + -- Makes the current design unit depends on UNIT. + -- UNIT must be either an entity_aspect or a design_unit. + procedure Add_Dependence (Unit : Iir); + + -- Add EL in the current design unit list of items to be checked later. + procedure Add_Analysis_Checks_List (El : Iir); + + -- INTER_PARENT contains generics and ports interfaces; + -- ASSOC_PARENT constains generics and ports map aspects. + procedure Sem_Generic_Port_Association_Chain + (Inter_Parent : Iir; Assoc_Parent : Iir); + + -- Return TRUE iff the actual of ASSOC can be the formal FORMAL. + -- ASSOC must be an association_element_by_expression. + function Can_Collapse_Signals (Assoc : Iir; Formal : Iir) return Boolean; + + -- Return TRUE iff LEFT and RIGHT are (in depth) equal. + -- This corresponds to conformance rules, LRM 2.7 + function Are_Trees_Equal (Left, Right : Iir) return Boolean; + + -- Check requirements on number of interfaces for subprogram specification + -- SUBPRG for a symbol operator ID. Requirements only concern operators, + -- and are defined in LRM 2.3.1. + -- If ID is not an operator name, this subprogram does no checks. + -- ID might be different from the identifier of SUBPRG when non object + -- aliases are checked. + procedure Check_Operator_Requirements (Id : Name_Id; Subprg : Iir); + + -- Semantize an use clause. + -- This may adds use clauses to the chain. + procedure Sem_Use_Clause (Clauses : Iir_Use_Clause); + + -- Compute and set the hash profile of a subprogram or enumeration clause. + procedure Compute_Subprogram_Hash (Subprg : Iir); + + -- LRM 2.1 Subprogram Declarations. + procedure Sem_Subprogram_Declaration (Subprg: Iir); + + -- LRM 2.2 Subprogram Bodies. + procedure Sem_Subprogram_Body (Subprg: Iir); + + -- Do late analysis checks (pure rules). + procedure Sem_Analysis_Checks_List (Unit : Iir_Design_Unit; + Emit_Warnings : Boolean); + + -- Analyze the uninstantiated package name of DECL, and return the + -- package declaration. Return Null_Iir if the name doesn't denote an + -- uninstantiated package. + function Sem_Uninstantiated_Package_Name (Decl : Iir) return Iir; + +end Sem; diff --git a/src/vhdl/sem_assocs.adb b/src/vhdl/sem_assocs.adb new file mode 100644 index 000000000..96e660875 --- /dev/null +++ b/src/vhdl/sem_assocs.adb @@ -0,0 +1,1903 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Evaluation; use Evaluation; +with Errorout; use Errorout; +with Flags; use Flags; +with Types; use Types; +with Iirs_Utils; use Iirs_Utils; +with Sem_Names; use Sem_Names; +with Sem_Expr; use Sem_Expr; +with Iir_Chains; use Iir_Chains; +with Xrefs; + +package body Sem_Assocs is + function Rewrite_Non_Object_Association (Assoc : Iir; Inter : Iir) + return Iir + is + N_Assoc : Iir; + begin + case Get_Kind (Inter) is + when Iir_Kind_Interface_Package_Declaration => + N_Assoc := Create_Iir (Iir_Kind_Association_Element_Package); + when others => + Error_Kind ("rewrite_non_object_association", Inter); + end case; + Location_Copy (N_Assoc, Assoc); + Set_Formal (N_Assoc, Get_Formal (Assoc)); + Set_Actual (N_Assoc, Get_Actual (Assoc)); + Set_Chain (N_Assoc, Get_Chain (Assoc)); + Set_Associated_Interface (N_Assoc, Inter); + Set_Whole_Association_Flag (N_Assoc, True); + Free_Iir (Assoc); + return N_Assoc; + end Rewrite_Non_Object_Association; + + function Extract_Non_Object_Association + (Assoc_Chain : Iir; Inter_Chain : Iir) return Iir + is + Inter : Iir; + Assoc : Iir; + -- N_Assoc : Iir; + Prev_Assoc : Iir; + Formal : Iir; + Res : Iir; + begin + Inter := Inter_Chain; + Assoc := Assoc_Chain; + Prev_Assoc := Null_Iir; + Res := Null_Iir; + + -- Common case: only objects in interfaces. + while Inter /= Null_Iir loop + exit when Get_Kind (Inter) + not in Iir_Kinds_Interface_Object_Declaration; + Inter := Get_Chain (Inter); + end loop; + if Inter = Null_Iir then + return Assoc_Chain; + end if; + + loop + -- Don't try to detect errors. + if Assoc = Null_Iir then + return Res; + end if; + + Formal := Get_Formal (Assoc); + if Formal = Null_Iir then + -- Positional association. + + if Inter = Null_Iir then + -- But after a named one. Be silent on that error. + null; + elsif Get_Kind (Inter) + not in Iir_Kinds_Interface_Object_Declaration + then + Assoc := Rewrite_Non_Object_Association (Assoc, Inter); + end if; + else + if Get_Kind (Formal) = Iir_Kind_Simple_Name then + -- A candidate. Search the corresponding interface. + Inter := Find_Name_In_Chain + (Inter_Chain, Get_Identifier (Formal)); + if Inter /= Null_Iir + and then + Get_Kind (Inter) not in Iir_Kinds_Interface_Object_Declaration + then + Assoc := Rewrite_Non_Object_Association (Assoc, Inter); + end if; + end if; + + -- No more association by position. + Inter := Null_Iir; + end if; + + if Prev_Assoc = Null_Iir then + Res := Assoc; + else + Set_Chain (Prev_Assoc, Assoc); + end if; + Prev_Assoc := Assoc; + Assoc := Get_Chain (Assoc); + end loop; + end Extract_Non_Object_Association; + + -- Semantize all arguments of ASSOC_CHAIN + -- Return TRUE if no error. + function Sem_Actual_Of_Association_Chain (Assoc_Chain : Iir) + return Boolean + is + Has_Named : Boolean; + Ok : Boolean; + Assoc : Iir; + Res : Iir; + Formal : Iir; + begin + -- Semantize all arguments + -- OK is false if there is an error during semantic of one of the + -- argument, but continue semantisation. + Has_Named := False; + Ok := True; + Assoc := Assoc_Chain; + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + if Formal /= Null_Iir then + Has_Named := True; + -- FIXME: check FORMAL is well composed. + elsif Has_Named then + -- FIXME: do the check in parser. + Error_Msg_Sem ("positional argument after named argument", Assoc); + Ok := False; + end if; + if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression then + Res := Sem_Expression_Ov (Get_Actual (Assoc), Null_Iir); + if Res = Null_Iir then + Ok := False; + else + Set_Actual (Assoc, Res); + end if; + end if; + Assoc := Get_Chain (Assoc); + end loop; + return Ok; + end Sem_Actual_Of_Association_Chain; + + procedure Check_Parameter_Association_Restriction + (Inter : Iir; Base_Actual : Iir; Loc : Iir) + is + Act_Mode : Iir_Mode; + For_Mode : Iir_Mode; + begin + Act_Mode := Get_Mode (Base_Actual); + For_Mode := Get_Mode (Inter); + case Get_Mode (Inter) is + when Iir_In_Mode => + if Act_Mode in Iir_In_Modes or Act_Mode = Iir_Buffer_Mode then + return; + end if; + when Iir_Out_Mode => + -- FIXME: should buffer also be accepted ? + if Act_Mode in Iir_Out_Modes or Act_Mode = Iir_Buffer_Mode then + return; + end if; + when Iir_Inout_Mode => + if Act_Mode = Iir_Inout_Mode then + return; + end if; + when others => + Error_Kind ("check_parameter_association_restriction", Inter); + end case; + Error_Msg_Sem + ("cannot associate an " & Get_Mode_Name (Act_Mode) + & " object with " & Get_Mode_Name (For_Mode) & " " + & Disp_Node (Inter), Loc); + end Check_Parameter_Association_Restriction; + + procedure Check_Subprogram_Associations + (Inter_Chain : Iir; Assoc_Chain : Iir) + is + Assoc : Iir; + Formal : Iir; + Formal_Inter : Iir; + Actual : Iir; + Prefix : Iir; + Object : Iir; + Inter : Iir; + begin + Assoc := Assoc_Chain; + Inter := Inter_Chain; + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + if Formal = Null_Iir then + -- Association by position. + Formal_Inter := Inter; + Inter := Get_Chain (Inter); + else + -- Association by name. + Formal_Inter := Get_Association_Interface (Assoc); + Inter := Null_Iir; + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_Open => + if Get_Default_Value (Formal_Inter) = Null_Iir then + Error_Msg_Sem + ("no parameter for " & Disp_Node (Formal_Inter), Assoc); + end if; + when Iir_Kind_Association_Element_By_Expression => + Actual := Get_Actual (Assoc); + Object := Name_To_Object (Actual); + if Object /= Null_Iir then + Prefix := Get_Object_Prefix (Object); + else + Prefix := Actual; + end if; + + case Get_Kind (Formal_Inter) is + when Iir_Kind_Interface_Signal_Declaration => + -- LRM93 2.1.1 + -- In a subprogram call, the actual designator + -- associated with a formal parameter of class + -- signal must be a signal. + case Get_Kind (Prefix) is + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kinds_Signal_Attribute => + -- LRM93 2.1.1.2 + -- If an actual signal is associated with + -- a signal parameter of any mode, the actual + -- must be denoted by a static signal name. + if Get_Name_Staticness (Object) < Globally then + Error_Msg_Sem + ("actual signal must be a static name", + Actual); + else + -- Inherit has_active_flag. + Set_Has_Active_Flag + (Prefix, Get_Has_Active_Flag (Formal_Inter)); + end if; + when others => + Error_Msg_Sem + ("signal parameter requires a signal expression", + Assoc); + end case; + + case Get_Kind (Prefix) is + when Iir_Kind_Interface_Signal_Declaration => + Check_Parameter_Association_Restriction + (Formal_Inter, Prefix, Assoc); + when Iir_Kind_Guard_Signal_Declaration => + if Get_Mode (Formal_Inter) /= Iir_In_Mode then + Error_Msg_Sem + ("cannot associate a guard signal with " + & Get_Mode_Name (Get_Mode (Formal_Inter)) + & " " & Disp_Node (Formal_Inter), Assoc); + end if; + when Iir_Kinds_Signal_Attribute => + if Get_Mode (Formal_Inter) /= Iir_In_Mode then + Error_Msg_Sem + ("cannot associate a signal attribute with " + & Get_Mode_Name (Get_Mode (Formal_Inter)) + & " " & Disp_Node (Formal_Inter), Assoc); + end if; + when others => + null; + end case; + + -- LRM 2.1.1.2 Signal parameters + -- It is an error if a conversion function or type + -- conversion appears in either the formal part or the + -- actual part of an association element that associates + -- an actual signal with a formal signal parameter. + if Get_In_Conversion (Assoc) /= Null_Iir + or Get_Out_Conversion (Assoc) /= Null_Iir + then + Error_Msg_Sem ("conversion are not allowed for " + & "signal parameters", Assoc); + end if; + when Iir_Kind_Interface_Variable_Declaration => + -- LRM93 2.1.1 + -- The actual designator associated with a formal of + -- class variable must be a variable. + case Get_Kind (Prefix) is + when Iir_Kind_Interface_Variable_Declaration => + Check_Parameter_Association_Restriction + (Formal_Inter, Prefix, Assoc); + when Iir_Kind_Variable_Declaration + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference => + null; + when Iir_Kind_Interface_File_Declaration + | Iir_Kind_File_Declaration => + -- LRM87 4.3.1.4 + -- Such an object is a member of the variable + -- class of objects; + if Flags.Vhdl_Std >= Vhdl_93 then + Error_Msg_Sem ("in vhdl93, variable parameter " + & "cannot be a file", Assoc); + end if; + when others => + Error_Msg_Sem + ("variable parameter must be a variable", Assoc); + end case; + when Iir_Kind_Interface_File_Declaration => + -- LRM93 2.1.1 + -- The actual designator associated with a formal + -- of class file must be a file. + case Get_Kind (Prefix) is + when Iir_Kind_Interface_File_Declaration + | Iir_Kind_File_Declaration => + null; + when Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration => + if Flags.Vhdl_Std >= Vhdl_93 then + Error_Msg_Sem ("in vhdl93, file parameter " + & "must be a file", Assoc); + end if; + when others => + Error_Msg_Sem + ("file parameter must be a file", Assoc); + end case; + + -- LRM 2.1.1.3 File parameters + -- It is an error if an association element associates + -- an actual with a formal parameter of a file type and + -- that association element contains a conversion + -- function or type conversion. + if Get_In_Conversion (Assoc) /= Null_Iir + or Get_Out_Conversion (Assoc) /= Null_Iir + then + Error_Msg_Sem ("conversion are not allowed for " + & "file parameters", Assoc); + end if; + when Iir_Kind_Interface_Constant_Declaration => + -- LRM93 2.1.1 + -- The actual designator associated with a formal of + -- class constant must be an expression. + Check_Read (Actual); + when others => + Error_Kind + ("check_subprogram_association(3)", Formal_Inter); + end case; + when Iir_Kind_Association_Element_By_Individual => + null; + when others => + Error_Kind ("check_subprogram_associations", Assoc); + end case; + Assoc := Get_Chain (Assoc); + end loop; + end Check_Subprogram_Associations; + + -- Assocs_Right_Map (FORMAL_MODE, ACTUAL_MODE) is true iff it is allowed + -- to associate a formal port of mode FORMAL_MODE with an actual port of + -- mode ACTUAL_MODE. + subtype Iir_Known_Mode is Iir_Mode range Iir_Linkage_Mode .. Iir_In_Mode; + type Assocs_Right_Map is array (Iir_Known_Mode, Iir_Known_Mode) of Boolean; + + Vhdl93_Assocs_Map : constant Assocs_Right_Map := + (Iir_Linkage_Mode => (others => True), + Iir_Buffer_Mode => (Iir_Buffer_Mode => True, others => False), + Iir_Out_Mode => (Iir_Out_Mode | Iir_Inout_Mode => True, + others => False), + Iir_Inout_Mode => (Iir_Inout_Mode => True, + others => False), + Iir_In_Mode => (Iir_In_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False)); + + Vhdl02_Assocs_Map : constant Assocs_Right_Map := + (Iir_Linkage_Mode => (others => True), + Iir_Buffer_Mode => (Iir_Out_Mode | Iir_Inout_Mode + | Iir_Buffer_Mode => True, + others => False), + Iir_Out_Mode => (Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False), + Iir_Inout_Mode => (Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False), + Iir_In_Mode => (Iir_In_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False)); + + -- Check for restrictions in LRM 1.1.1.2 + -- Return FALSE in case of error. + function Check_Port_Association_Restriction + (Formal : Iir_Interface_Signal_Declaration; + Actual : Iir_Interface_Signal_Declaration; + Assoc : Iir) + return Boolean + is + Fmode : constant Iir_Mode := Get_Mode (Formal); + Amode : constant Iir_Mode := Get_Mode (Actual); + begin + pragma Assert (Fmode /= Iir_Unknown_Mode); + pragma Assert (Amode /= Iir_Unknown_Mode); + + if Flags.Vhdl_Std < Vhdl_02 then + if Vhdl93_Assocs_Map (Fmode, Amode) then + return True; + end if; + else + if Vhdl02_Assocs_Map (Fmode, Amode) then + return True; + end if; + end if; + + if Assoc /= Null_Iir then + Error_Msg_Sem + ("cannot associate " & Get_Mode_Name (Fmode) & " " + & Disp_Node (Formal) & " with actual port of mode " + & Get_Mode_Name (Amode), Assoc); + end if; + return False; + end Check_Port_Association_Restriction; + + -- Handle indexed name + -- FORMAL is the formal name to be handled. + -- SUB_ASSOC is an association_by_individual in which the formal will be + -- inserted. + -- Update SUB_ASSOC so that it designates FORMAL. + procedure Add_Individual_Assoc_Indexed_Name + (Sub_Assoc : in out Iir; Formal : Iir) + is + Choice : Iir; + Last_Choice : Iir; + Index_List : Iir_List; + Index : Iir; + Nbr : Natural; + begin + -- Find element. + Index_List := Get_Index_List (Formal); + Nbr := Get_Nbr_Elements (Index_List); + for I in 0 .. Nbr - 1 loop + Index := Get_Nth_Element (Index_List, I); + + -- Evaluate index. + Index := Eval_Expr (Index); + Replace_Nth_Element (Index_List, I, Index); + + -- Find index in choice list. + Last_Choice := Null_Iir; + Choice := Get_Individual_Association_Chain (Sub_Assoc); + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Expression => + if Eval_Pos (Get_Choice_Expression (Choice)) + = Eval_Pos (Index) + then + goto Found; + end if; + when Iir_Kind_Choice_By_Range => + declare + Choice_Range : constant Iir := Get_Choice_Range (Choice); + begin + if Get_Expr_Staticness (Choice_Range) = Locally + and then + Eval_Int_In_Range (Eval_Pos (Index), Choice_Range) + then + -- FIXME: overlap. + raise Internal_Error; + end if; + end; + when others => + Error_Kind ("add_individual_assoc_index_name", Choice); + end case; + Last_Choice := Choice; + Choice := Get_Chain (Choice); + end loop; + + -- If not found, append it. + Choice := Create_Iir (Iir_Kind_Choice_By_Expression); + Set_Choice_Expression (Choice, Index); + Location_Copy (Choice, Formal); + if Last_Choice = Null_Iir then + Set_Individual_Association_Chain (Sub_Assoc, Choice); + else + Set_Chain (Last_Choice, Choice); + end if; + + << Found >> null; + + if I < Nbr - 1 then + Sub_Assoc := Get_Associated_Expr (Choice); + if Sub_Assoc = Null_Iir then + Sub_Assoc := Create_Iir + (Iir_Kind_Association_Element_By_Individual); + Location_Copy (Sub_Assoc, Index); + Set_Associated_Expr (Choice, Sub_Assoc); + end if; + else + Sub_Assoc := Choice; + end if; + end loop; + end Add_Individual_Assoc_Indexed_Name; + + procedure Add_Individual_Assoc_Slice_Name + (Sub_Assoc : in out Iir; Formal : Iir) + is + Choice : Iir; + Index : Iir; + begin + -- FIXME: handle cases such as param(5 to 6)(5) + + -- Find element. + Index := Get_Suffix (Formal); + + -- Evaluate index. + if Get_Expr_Staticness (Index) = Locally then + Index := Eval_Range (Index); + Set_Suffix (Formal, Index); + end if; + + Choice := Create_Iir (Iir_Kind_Choice_By_Range); + Location_Copy (Choice, Formal); + Set_Choice_Range (Choice, Index); + Set_Chain (Choice, Get_Individual_Association_Chain (Sub_Assoc)); + Set_Individual_Association_Chain (Sub_Assoc, Choice); + + Sub_Assoc := Choice; + end Add_Individual_Assoc_Slice_Name; + + procedure Add_Individual_Assoc_Selected_Name + (Sub_Assoc : in out Iir; Formal : Iir) + is + Choice : Iir; + begin + Choice := Create_Iir (Iir_Kind_Choice_By_Name); + Location_Copy (Choice, Formal); + Set_Choice_Name (Choice, Get_Selected_Element (Formal)); + Set_Chain (Choice, Get_Individual_Association_Chain (Sub_Assoc)); + Set_Individual_Association_Chain (Sub_Assoc, Choice); + + Sub_Assoc := Choice; + end Add_Individual_Assoc_Selected_Name; + + procedure Add_Individual_Association_1 (Iassoc : in out Iir; Formal : Iir) + is + Sub : Iir; + Formal_Object : Iir; + begin + -- Recurse. + Formal_Object := Name_To_Object (Formal); + case Get_Kind (Formal_Object) is + when Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element => + Add_Individual_Association_1 (Iassoc, Get_Prefix (Formal_Object)); + when Iir_Kinds_Interface_Object_Declaration => + return; + when others => + Error_Kind ("add_individual_association_1", Formal); + end case; + + case Get_Kind (Iassoc) is + when Iir_Kind_Association_Element_By_Individual => + null; + when Iir_Kind_Choice_By_Expression => + Sub := Get_Associated_Expr (Iassoc); + if Sub = Null_Iir then + Sub := Create_Iir (Iir_Kind_Association_Element_By_Individual); + Location_Copy (Sub, Formal); + Set_Formal (Sub, Iassoc); + Set_Associated_Expr (Iassoc, Sub); + Iassoc := Sub; + else + case Get_Kind (Sub) is + when Iir_Kind_Association_Element_By_Individual => + Iassoc := Sub; + when others => + Error_Msg_Sem + ("individual association of " + & Disp_Node (Get_Association_Interface (Iassoc)) + & " conflicts with that at " & Disp_Location (Sub), + Formal); + return; + end case; + end if; + when others => + Error_Kind ("add_individual_association_1(2)", Iassoc); + end case; + + case Get_Kind (Formal_Object) is + when Iir_Kind_Indexed_Name => + Add_Individual_Assoc_Indexed_Name (Iassoc, Formal_Object); + when Iir_Kind_Slice_Name => + Add_Individual_Assoc_Slice_Name (Iassoc, Formal_Object); + when Iir_Kind_Selected_Element => + Add_Individual_Assoc_Selected_Name (Iassoc, Formal_Object); + when others => + Error_Kind ("add_individual_association_1(3)", Formal); + end case; + end Add_Individual_Association_1; + + -- Insert ASSOC into the tree of individual assoc rooted by IASSOC. + procedure Add_Individual_Association (Iassoc : Iir; Assoc : Iir) + is + Formal : Iir; + Iass : Iir; + Prev : Iir; + begin + Formal := Get_Formal (Assoc); + Iass := Iassoc; + Add_Individual_Association_1 (Iass, Formal); + Prev := Get_Associated_Expr (Iass); + if Prev /= Null_Iir then + Error_Msg_Sem ("individual association of " + & Disp_Node (Get_Association_Interface (Assoc)) + & " conflicts with that at " & Disp_Location (Prev), + Assoc); + else + Set_Associated_Expr (Iass, Assoc); + end if; + end Add_Individual_Association; + + procedure Finish_Individual_Assoc_Array_Subtype + (Assoc : Iir; Atype : Iir; Dim : Positive) + is + Index_Tlist : constant Iir_List := Get_Index_Subtype_List (Atype); + Nbr_Dims : constant Natural := Get_Nbr_Elements (Index_Tlist); + Index_Type : Iir; + Low, High : Iir; + Chain : Iir; + El : Iir; + begin + Index_Type := Get_Nth_Element (Index_Tlist, Dim - 1); + Chain := Get_Individual_Association_Chain (Assoc); + Sem_Choices_Range + (Chain, Index_Type, False, False, Get_Location (Assoc), Low, High); + Set_Individual_Association_Chain (Assoc, Chain); + if Dim < Nbr_Dims then + El := Chain; + while El /= Null_Iir loop + pragma Assert (Get_Kind (El) = Iir_Kind_Choice_By_Expression); + Finish_Individual_Assoc_Array_Subtype + (Get_Associated_Expr (El), Atype, Dim + 1); + El := Get_Chain (El); + end loop; + end if; + end Finish_Individual_Assoc_Array_Subtype; + + procedure Finish_Individual_Assoc_Array + (Actual : Iir; Assoc : Iir; Dim : Natural) + is + Actual_Type : Iir; + Actual_Index : Iir; + Base_Type : Iir; + Base_Index : Iir; + Low, High : Iir; + Chain : Iir; + begin + Actual_Type := Get_Actual_Type (Actual); + Actual_Index := Get_Nth_Element (Get_Index_Subtype_List (Actual_Type), + Dim - 1); + if Actual_Index /= Null_Iir then + Base_Index := Actual_Index; + else + Base_Type := Get_Base_Type (Actual_Type); + Base_Index := Get_Index_Type (Base_Type, Dim - 1); + end if; + Chain := Get_Individual_Association_Chain (Assoc); + Sem_Choices_Range + (Chain, Base_Index, True, False, Get_Location (Assoc), Low, High); + Set_Individual_Association_Chain (Assoc, Chain); + if Actual_Index = Null_Iir then + declare + Index_Constraint : Iir; + Index_Subtype_Constraint : Iir; + begin + -- Create an index subtype. + case Get_Kind (Base_Index) is + when Iir_Kind_Integer_Subtype_Definition => + Actual_Index := + Create_Iir (Iir_Kind_Integer_Subtype_Definition); + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Actual_Index := + Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + when others => + Error_Kind ("finish_individual_assoc_array", Base_Index); + end case; + Location_Copy (Actual_Index, Actual); + Set_Base_Type (Actual_Index, Get_Base_Type (Base_Index)); + Index_Constraint := Get_Range_Constraint (Base_Index); + + Index_Subtype_Constraint := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Index_Subtype_Constraint, Actual); + Set_Range_Constraint (Actual_Index, Index_Subtype_Constraint); + Set_Type_Staticness (Actual_Index, Locally); + 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); + Set_Right_Limit (Index_Subtype_Constraint, High); + when Iir_Downto => + Set_Left_Limit (Index_Subtype_Constraint, High); + Set_Right_Limit (Index_Subtype_Constraint, Low); + end case; + Set_Expr_Staticness (Index_Subtype_Constraint, Locally); + Append_Element (Get_Index_Subtype_List (Actual_Type), + Actual_Index); + end; + else + declare + Act_High, Act_Low : Iir; + begin + Get_Low_High_Limit (Get_Range_Constraint (Actual_Type), + Act_Low, Act_High); + if Eval_Pos (Act_Low) /= Eval_Pos (Low) + or Eval_Pos (Act_High) /= Eval_Pos (High) + then + Error_Msg_Sem ("indexes of individual association mismatch", + Assoc); + end if; + end; + end if; + end Finish_Individual_Assoc_Array; + + procedure Finish_Individual_Assoc_Record (Assoc : Iir; Atype : Iir) + is + 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 + Matches := (others => Null_Iir); + Ch := Get_Individual_Association_Chain (Assoc); + while Ch /= Null_Iir loop + Rec_El := Get_Choice_Name (Ch); + Pos := Natural (Get_Element_Position (Rec_El)); + if Matches (Pos) /= Null_Iir then + Error_Msg_Sem ("individual " & Disp_Node (Rec_El) + & " already associated at " + & Disp_Location (Matches (Pos)), Ch); + else + Matches (Pos) := Ch; + end if; + Ch := Get_Chain (Ch); + end loop; + 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; + end loop; + Set_Actual_Type (Assoc, Atype); + end Finish_Individual_Assoc_Record; + + -- Called by sem_individual_association to finish the semantization of + -- individual association ASSOC. + procedure Finish_Individual_Association (Assoc : Iir) + is + Formal : Iir; + Atype : Iir; + begin + -- Guard. + if Assoc = Null_Iir then + return; + end if; + + Formal := Get_Association_Interface (Assoc); + Atype := Get_Type (Formal); + + case Get_Kind (Atype) is + when Iir_Kind_Array_Subtype_Definition => + Finish_Individual_Assoc_Array_Subtype (Assoc, Atype, 1); + Set_Actual_Type (Assoc, Atype); + 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 => + Finish_Individual_Assoc_Record (Assoc, Atype); + when others => + Error_Kind ("finish_individual_association", Atype); + end case; + end Finish_Individual_Association; + + -- Sem individual associations of ASSOCS: + -- Add an Iir_Kind_Association_Element_By_Individual before each + -- group of individual association for the same formal, and call + -- Finish_Individual_Association with each of these added nodes. + procedure Sem_Individual_Association (Assoc_Chain : in out Iir) + is + Assoc : Iir; + Prev_Assoc : Iir; + Iassoc : Iir_Association_Element_By_Individual; + Cur_Iface : Iir; + Formal : Iir; + begin + Iassoc := Null_Iir; + Cur_Iface := Null_Iir; + Prev_Assoc := Null_Iir; + Assoc := Assoc_Chain; + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + if Formal /= Null_Iir then + Formal := Get_Object_Prefix (Formal); + end if; + if Formal = Null_Iir or else Formal /= Cur_Iface then + -- New formal name, sem the current assoc. + Finish_Individual_Association (Iassoc); + Cur_Iface := Formal; + Iassoc := Null_Iir; + end if; + if Get_Whole_Association_Flag (Assoc) = False then + -- New individual association. + if Iassoc = Null_Iir then + Iassoc := + Create_Iir (Iir_Kind_Association_Element_By_Individual); + Location_Copy (Iassoc, Assoc); + if Cur_Iface = Null_Iir then + raise Internal_Error; + end if; + Set_Formal (Iassoc, Cur_Iface); + -- Insert IASSOC. + if Prev_Assoc = Null_Iir then + Assoc_Chain := Iassoc; + else + Set_Chain (Prev_Assoc, Iassoc); + end if; + Set_Chain (Iassoc, Assoc); + end if; + Add_Individual_Association (Iassoc, Assoc); + end if; + Prev_Assoc := Assoc; + Assoc := Get_Chain (Assoc); + end loop; + -- There is maybe a remaining iassoc. + Finish_Individual_Association (Iassoc); + end Sem_Individual_Association; + + function Is_Conversion_Function (Assoc_Chain : Iir) return Boolean + is + begin + -- [...] whose single parameter of the function [...] + if not Is_Chain_Length_One (Assoc_Chain) then + return False; + end if; + if Get_Kind (Assoc_Chain) /= Iir_Kind_Association_Element_By_Expression + then + return False; + end if; + -- FIXME: unfortunatly, the formal may already be set with the + -- interface. +-- if Get_Formal (Assoc_Chain) /= Null_Iir then +-- return Null_Iir; +-- end if; + return True; + end Is_Conversion_Function; + + function Is_Expanded_Name (Name : Iir) return Boolean + is + Pfx : Iir; + begin + Pfx := Name; + loop + case Get_Kind (Pfx) is + when Iir_Kind_Simple_Name => + return True; + when Iir_Kind_Selected_Name => + Pfx := Get_Prefix (Pfx); + when others => + return False; + end case; + end loop; + end Is_Expanded_Name; + + function Extract_Type_Of_Conversions (Convs : Iir) return Iir + is + -- Return TRUE iff FUNC is valid as a conversion function/type. + function Extract_Type_Of_Conversion (Func : Iir) return Iir is + begin + case Get_Kind (Func) is + when Iir_Kinds_Function_Declaration => + if Is_Chain_Length_One (Get_Interface_Declaration_Chain (Func)) + then + return Get_Type (Func); + else + return Null_Iir; + end if; + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + if Flags.Vhdl_Std = Vhdl_87 then + return Null_Iir; + end if; + return Get_Type (Func); + when others => + return Null_Iir; + end case; + end Extract_Type_Of_Conversion; + + Res_List : Iir_List; + Ov_List : Iir_List; + El : Iir; + Conv_Type : Iir; + begin + if not Is_Overload_List (Convs) then + return Extract_Type_Of_Conversion (Convs); + else + Ov_List := Get_Overload_List (Convs); + Res_List := Create_Iir_List; + for I in Natural loop + El := Get_Nth_Element (Ov_List, I); + exit when El = Null_Iir; + Conv_Type := Extract_Type_Of_Conversion (El); + if Conv_Type /= Null_Iir then + Add_Element (Res_List, Conv_Type); + end if; + end loop; + return Simplify_Overload_List (Res_List); + end if; + end Extract_Type_Of_Conversions; + + -- ASSOC is an association element not semantized and whose formal is a + -- parenthesis name. Try to extract a conversion function/type. In case + -- of success, return a new association element. In case of failure, + -- return NULL_IIR. + function Sem_Formal_Conversion (Assoc : Iir) return Iir + is + Formal : constant Iir := Get_Formal (Assoc); + Assoc_Chain : constant Iir := Get_Association_Chain (Formal); + Res : Iir; + Conv : Iir; + Name : Iir; + Conv_Func : Iir; + Conv_Type : Iir; + begin + -- Nothing to do if the formal isn't a conversion. + if not Is_Conversion_Function (Assoc_Chain) then + return Null_Iir; + end if; + + -- Both the conversion function and the formal name must be names. + Conv := Get_Prefix (Formal); + -- FIXME: what about operator names (such as "not"). + if Get_Kind (Conv) /= Iir_Kind_Simple_Name + and then not Is_Expanded_Name (Conv) + then + return Null_Iir; + end if; + Name := Get_Actual (Assoc_Chain); + if Get_Kind (Name) not in Iir_Kinds_Name then + return Null_Iir; + end if; + + Sem_Name_Soft (Conv); + Conv_Func := Get_Named_Entity (Conv); + if Get_Kind (Conv_Func) = Iir_Kind_Error then + Conv_Type := Null_Iir; + else + Conv_Type := Extract_Type_Of_Conversions (Conv_Func); + end if; + if Conv_Type = Null_Iir then + Sem_Name_Clean (Conv); + return Null_Iir; + end if; + Set_Type (Conv, Conv_Type); + + -- Create a new association with a conversion function. + Res := Create_Iir (Iir_Kind_Association_Element_By_Expression); + Set_Out_Conversion (Res, Conv); + Set_Formal (Res, Name); + Set_Actual (Res, Get_Actual (Assoc)); + return Res; + end Sem_Formal_Conversion; + + -- NAME is the formal name of an association, without any conversion + -- function or type. + -- Try to semantize NAME with INTERFACE. + -- In case of success, set PREFIX to the most prefix of NAME and NAME_TYPE + -- to the type of NAME. + -- In case of failure, set NAME_TYPE to NULL_IIR. + procedure Sem_Formal_Name (Name : Iir; + Inter : Iir; + Prefix : out Iir; + Name_Type : out Iir) + is + Base_Type : Iir; + Rec_El : Iir; + begin + case Get_Kind (Name) is + when Iir_Kind_Simple_Name => + if Get_Identifier (Name) = Get_Identifier (Inter) then + Prefix := Name; + Name_Type := Get_Type (Inter); + else + Name_Type := Null_Iir; + end if; + return; + when Iir_Kind_Selected_Name => + Sem_Formal_Name (Get_Prefix (Name), Inter, Prefix, Name_Type); + if Name_Type = Null_Iir then + return; + end if; + Base_Type := Get_Base_Type (Name_Type); + if Get_Kind (Base_Type) /= Iir_Kind_Record_Type_Definition then + Name_Type := Null_Iir; + return; + end if; + Rec_El := Find_Name_In_List + (Get_Elements_Declaration_List (Base_Type), + Get_Identifier (Name)); + if Rec_El = Null_Iir then + Name_Type := Null_Iir; + return; + end if; + Name_Type := Get_Type (Rec_El); + return; + when Iir_Kind_Parenthesis_Name => + -- More difficult: slice or indexed array. + Sem_Formal_Name (Get_Prefix (Name), Inter, Prefix, Name_Type); + if Name_Type = Null_Iir then + return; + end if; + Base_Type := Get_Base_Type (Name_Type); + if Get_Kind (Base_Type) /= Iir_Kind_Array_Type_Definition then + Name_Type := Null_Iir; + return; + end if; + declare + Chain : Iir; + Index_List : Iir_List; + Idx : Iir; + begin + Chain := Get_Association_Chain (Name); + Index_List := Get_Index_Subtype_List (Base_Type); + -- Check for matching length. + if Get_Chain_Length (Chain) /= Get_Nbr_Elements (Index_List) + then + Name_Type := Null_Iir; + return; + end if; + if Get_Kind (Chain) + /= Iir_Kind_Association_Element_By_Expression + then + Name_Type := Null_Iir; + return; + end if; + Idx := Get_Actual (Chain); + if (not Is_Chain_Length_One (Chain)) + or else (Get_Kind (Idx) /= Iir_Kind_Range_Expression + and then not Is_Range_Attribute_Name (Idx)) + -- FIXME: what about subtype ! + then + -- Indexed name. + Name_Type := Get_Element_Subtype (Base_Type); + return; + end if; + -- Slice. + return; + end; + when others => + Error_Kind ("sem_formal_name", Name); + end case; + end Sem_Formal_Name; + + -- Return a type or a list of types for a formal expression FORMAL + -- corresponding to INTERFACE. Possible cases are: + -- * FORMAL is the simple name with the same identifier as INTERFACE, + -- FORMAL_TYPE is set to the type of INTERFACE and CONV_TYPE is set + -- to NULL_IIR. + -- * FORMAL is a selected, indexed or slice name whose extreme prefix is + -- a simple name with the same identifier as INTERFACE, FORMAL_TYPE + -- is set to the type of the name, and CONV_TYPE is set to NULL_IIR. + -- * FORMAL is a function call, whose only argument is an + -- association_element_by_expression, whose actual is a name + -- whose prefix is the same identifier as INTERFACE (note, since FORMAL + -- is not semantized, this is parenthesis name), CONV_TYPE is set to + -- the type or list of type of return type of conversion functions and + -- FORMAL_TYPE is set to the type of the name. + -- * otherwise, FORMAL cannot match INTERFACE and both FORMAL_TYPE and + -- CONV_TYPE are set to NULL_IIR. + -- If FINISH is true, the simple name is replaced by INTERFACE. + + type Param_Assoc_Type is (None, Open, Individual, Whole); + + function Sem_Formal (Formal : Iir; Inter : Iir) return Param_Assoc_Type + is + Prefix : Iir; + Formal_Type : Iir; + begin + case Get_Kind (Formal) is + when Iir_Kind_Simple_Name => + -- Certainly the most common case: FORMAL_NAME => VAL. + -- It is also the easiest. So, handle it completly now. + if Get_Identifier (Formal) = Get_Identifier (Inter) then + Formal_Type := Get_Type (Inter); + Set_Named_Entity (Formal, Inter); + Set_Type (Formal, Formal_Type); + Set_Base_Name (Formal, Inter); + return Whole; + end if; + return None; + when Iir_Kind_Selected_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Parenthesis_Name => + null; + when others => + -- Should have been caught by sem_association_list. + Error_Kind ("sem_formal", Formal); + end case; + -- Check for a sub-element. + Sem_Formal_Name (Formal, Inter, Prefix, Formal_Type); + if Formal_Type /= Null_Iir then + Set_Type (Formal, Formal_Type); + Set_Named_Entity (Prefix, Inter); + return Individual; + else + return None; + end if; + end Sem_Formal; + + function Is_Valid_Conversion + (Func : Iir; Res_Base_Type : Iir; Param_Base_Type : Iir) + return Boolean + is + R_Type : Iir; + P_Type : Iir; + begin + case Get_Kind (Func) is + when Iir_Kinds_Function_Declaration => + R_Type := Get_Type (Func); + P_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); + if Get_Base_Type (R_Type) = Res_Base_Type + and then Get_Base_Type (P_Type) = Param_Base_Type + then + return True; + else + return False; + end if; + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + R_Type := Get_Type (Func); + if Get_Base_Type (R_Type) = Res_Base_Type + and then Are_Types_Closely_Related (R_Type, Param_Base_Type) + then + return True; + else + return False; + end if; + when Iir_Kind_Function_Call => + return Is_Valid_Conversion (Get_Implementation (Func), + Res_Base_Type, Param_Base_Type); + when Iir_Kind_Type_Conversion => + return Is_Valid_Conversion (Get_Type_Mark (Func), + Res_Base_Type, Param_Base_Type); + when Iir_Kinds_Denoting_Name => + return Is_Valid_Conversion (Get_Named_Entity (Func), + Res_Base_Type, Param_Base_Type); + when others => + Error_Kind ("is_valid_conversion(2)", Func); + end case; + end Is_Valid_Conversion; + + function Extract_Conversion + (Conv : Iir; Res_Type : Iir; Param_Type : Iir; Loc : Iir) + return Iir + is + List : Iir_List; + Res_Base_Type : Iir; + Param_Base_Type : Iir; + El : Iir; + Res : Iir; + begin + Res_Base_Type := Get_Base_Type (Res_Type); + if Param_Type = Null_Iir then + -- In case of error. + return Null_Iir; + end if; + Param_Base_Type := Get_Base_Type (Param_Type); + if Is_Overload_List (Conv) then + List := Get_Overload_List (Conv); + Res := Null_Iir; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if Is_Valid_Conversion (El, Res_Base_Type, Param_Base_Type) then + if Res /= Null_Iir then + raise Internal_Error; + end if; + Free_Iir (Conv); + Res := El; + end if; + end loop; + else + if Is_Valid_Conversion (Conv, Res_Base_Type, Param_Base_Type) then + Res := Conv; + else + Res := Null_Iir; + Error_Msg_Sem ("conversion function or type does not match", Loc); + end if; + end if; + return Res; + end Extract_Conversion; + + function Extract_In_Conversion (Conv : Iir; + Res_Type : Iir; Param_Type : Iir) + return Iir + is + Func : Iir; + begin + if Conv = Null_Iir then + return Null_Iir; + end if; + Func := Extract_Conversion (Conv, Res_Type, Param_Type, Conv); + if Func = Null_Iir then + return Null_Iir; + end if; + case Get_Kind (Func) is + when Iir_Kind_Function_Call + | Iir_Kind_Type_Conversion => + return Func; + when others => + Error_Kind ("extract_in_conversion", Func); + end case; + end Extract_In_Conversion; + + function Extract_Out_Conversion (Conv : Iir; + Res_Type : Iir; Param_Type : Iir) + return Iir + is + Func : Iir; + Res : Iir; + begin + if Conv = Null_Iir then + return Null_Iir; + end if; + Func := Extract_Conversion (Get_Named_Entity (Conv), + Res_Type, Param_Type, Conv); + if Func = Null_Iir then + return Null_Iir; + end if; + pragma Assert (Get_Kind (Conv) in Iir_Kinds_Denoting_Name); + Set_Named_Entity (Conv, Func); + + case Get_Kind (Func) is + when Iir_Kinds_Function_Declaration => + Res := Create_Iir (Iir_Kind_Function_Call); + Location_Copy (Res, Conv); + Set_Implementation (Res, Func); + Set_Prefix (Res, Conv); + Set_Base_Name (Res, Res); + Set_Parameter_Association_Chain (Res, Null_Iir); + Set_Type (Res, Get_Return_Type (Func)); + Set_Expr_Staticness (Res, None); + Mark_Subprogram_Used (Func); + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration => + Res := Create_Iir (Iir_Kind_Type_Conversion); + Location_Copy (Res, Conv); + Set_Type_Mark (Res, Conv); + Set_Type (Res, Get_Type (Func)); + Set_Expression (Res, Null_Iir); + Set_Expr_Staticness (Res, None); + when others => + Error_Kind ("extract_out_conversion", Res); + end case; + Xrefs.Xref_Name (Conv); + return Res; + end Extract_Out_Conversion; + + procedure Sem_Association_Open + (Assoc : Iir; + Inter : Iir; + Finish : Boolean; + Match : out Boolean) + is + Formal : Iir; + Assoc_Kind : Param_Assoc_Type; + begin + Formal := Get_Formal (Assoc); + + if Formal /= Null_Iir then + Assoc_Kind := Sem_Formal (Formal, Inter); + if Assoc_Kind = None then + Match := False; + return; + end if; + Set_Whole_Association_Flag (Assoc, Assoc_Kind = Whole); + if Finish then + Sem_Name (Formal); + Formal := Finish_Sem_Name (Formal); + Set_Formal (Assoc, Formal); + if Get_Kind (Formal) in Iir_Kinds_Denoting_Name + and then Is_Error (Get_Named_Entity (Formal)) + then + Match := False; + return; + end if; + + -- LRM 4.3.3.2 Associations lists + -- It is an error if an actual of open is associated with a + -- formal that is associated individually. + if Assoc_Kind = Individual then + Error_Msg_Sem ("cannot associate individually with open", + Assoc); + end if; + end if; + else + Set_Whole_Association_Flag (Assoc, True); + end if; + Match := True; + end Sem_Association_Open; + + procedure Sem_Association_Package + (Assoc : Iir; + Inter : Iir; + Finish : Boolean; + Match : out Boolean) + is + Formal : constant Iir := Get_Formal (Assoc); + Actual : Iir; + Package_Inter : Iir; + begin + if not Finish then + Match := Get_Associated_Interface (Assoc) = Inter; + return; + end if; + + -- Always match (as this is a generic association, there is no + -- need to resolve overload). + pragma Assert (Get_Associated_Interface (Assoc) = Inter); + Match := True; + + if Formal /= Null_Iir then + pragma Assert (Get_Kind (Formal) = Iir_Kind_Simple_Name); + pragma Assert (Get_Identifier (Formal) = Get_Identifier (Inter)); + Set_Named_Entity (Formal, Inter); + Set_Base_Name (Formal, Inter); + end if; + + -- Analyze actual. + Actual := Get_Actual (Assoc); + Actual := Sem_Denoting_Name (Actual); + Set_Actual (Assoc, Actual); + + Actual := Get_Named_Entity (Actual); + if Is_Error (Actual) then + return; + end if; + + -- LRM08 6.5.7.2 Generic map aspects + -- An actual associated with a formal generic package in a + -- generic map aspect shall be the name that denotes an instance + -- of the uninstantiated package named in the formal generic + -- package declaration [...] + if Get_Kind (Actual) /= Iir_Kind_Package_Instantiation_Declaration then + Error_Msg_Sem + ("actual of association is not a package instantiation", Assoc); + return; + end if; + + Package_Inter := + Get_Named_Entity (Get_Uninstantiated_Package_Name (Inter)); + if Get_Named_Entity (Get_Uninstantiated_Package_Name (Actual)) + /= Package_Inter + then + Error_Msg_Sem + ("actual package name is not an instance of interface package", + Assoc); + return; + end if; + + -- LRM08 6.5.7.2 Generic map aspects + -- b) If the formal generic package declaration includes an interface + -- generic map aspect in the form that includes the box (<>) symbol, + -- then the instantiaed package denotes by the actual may be any + -- instance of the uninstantiated package named in the formal + -- generic package declaration. + if Get_Generic_Map_Aspect_Chain (Inter) = Null_Iir then + null; + else + -- Other cases not yet handled. + raise Internal_Error; + end if; + + return; + end Sem_Association_Package; + + -- Associate ASSOC with interface INTERFACE + -- This sets MATCH. + procedure Sem_Association_By_Expression + (Assoc : Iir; + Inter : Iir; + Finish : Boolean; + Match : out Boolean) + is + Formal : Iir; + Formal_Type : Iir; + Actual: Iir; + Out_Conv, In_Conv : Iir; + Expr : Iir; + Res_Type : Iir; + Assoc_Kind : Param_Assoc_Type; + begin + Formal := Get_Formal (Assoc); + + -- Pre-semantize formal and extract out conversion. + if Formal /= Null_Iir then + Assoc_Kind := Sem_Formal (Formal, Inter); + if Assoc_Kind = None then + Match := False; + return; + end if; + Set_Whole_Association_Flag (Assoc, Assoc_Kind = Whole); + Formal := Get_Formal (Assoc); + + Out_Conv := Get_Out_Conversion (Assoc); + else + Set_Whole_Association_Flag (Assoc, True); + Out_Conv := Null_Iir; + Formal := Inter; + end if; + Formal_Type := Get_Type (Formal); + + -- Extract conversion from actual. + Actual := Get_Actual (Assoc); + In_Conv := Null_Iir; + if Get_Kind (Inter) /= Iir_Kind_Interface_Constant_Declaration then + case Get_Kind (Actual) is + when Iir_Kind_Function_Call => + Expr := Get_Parameter_Association_Chain (Actual); + if Is_Conversion_Function (Expr) then + In_Conv := Actual; + Actual := Get_Actual (Expr); + end if; + when Iir_Kind_Type_Conversion => + if Flags.Vhdl_Std > Vhdl_87 then + In_Conv := Actual; + Actual := Get_Expression (Actual); + end if; + when others => + null; + end case; + end if; + + -- 4 cases: F:out_conv, G:in_conv. + -- A => B type of A = type of B + -- F(A) => B type of B = type of F + -- A => G(B) type of A = type of G + -- F(A) => G(B) type of B = type of F, type of A = type of G + if Out_Conv = Null_Iir and then In_Conv = Null_Iir then + Match := Is_Expr_Compatible (Formal_Type, Actual); + else + Match := True; + if In_Conv /= Null_Iir then + if not Is_Expr_Compatible (Formal_Type, In_Conv) then + Match := False; + end if; + end if; + if Out_Conv /= Null_Iir then + if not Is_Expr_Compatible (Get_Type (Out_Conv), Actual) then + Match := False; + end if; + end if; + end if; + + if not Match then + if Finish then + Error_Msg_Sem + ("can't associate " & Disp_Node (Actual) & " with " + & Disp_Node (Inter), Assoc); + Error_Msg_Sem + ("(type of " & Disp_Node (Actual) & " is " + & Disp_Type_Of (Actual) & ")", Assoc); + Error_Msg_Sem + ("(type of " & Disp_Node (Inter) & " is " + & Disp_Type_Of (Inter) & ")", Inter); + end if; + return; + end if; + + if not Finish then + return; + end if; + + -- At that point, the analysis is being finished. + + if Out_Conv = Null_Iir and then In_Conv = Null_Iir then + Res_Type := Formal_Type; + else + if Out_Conv /= Null_Iir then + Res_Type := Search_Compatible_Type (Get_Type (Out_Conv), + Get_Type (Actual)); + else + Res_Type := Get_Type (Actual); + end if; + + if In_Conv /= Null_Iir then + In_Conv := Extract_In_Conversion (In_Conv, Formal_Type, Res_Type); + end if; + if Out_Conv /= Null_Iir then + Out_Conv := Extract_Out_Conversion (Out_Conv, + Res_Type, Formal_Type); + end if; + end if; + + if Res_Type = Null_Iir then + -- In case of error, do not go farther. + Match := False; + return; + end if; + + -- Semantize formal. + if Get_Formal (Assoc) /= Null_Iir then + Set_Type (Formal, Null_Iir); + Sem_Name (Formal); + Expr := Get_Named_Entity (Formal); + if Get_Kind (Expr) = Iir_Kind_Error then + return; + end if; + Formal := Finish_Sem_Name (Formal); + Set_Formal (Assoc, Formal); + Formal_Type := Get_Type (Expr); + if Out_Conv = Null_Iir and In_Conv = Null_Iir then + Res_Type := Formal_Type; + 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_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 + Error_Msg_Sem ("actual length does not match formal length", + Assoc); + end if; + end if; + end if; + end Sem_Association_By_Expression; + + -- Associate ASSOC with interface INTERFACE + -- This sets MATCH. + procedure Sem_Association + (Assoc : Iir; Inter : Iir; Finish : Boolean; Match : out Boolean) is + begin + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_Open => + Sem_Association_Open (Assoc, Inter, Finish, Match); + + when Iir_Kind_Association_Element_Package => + Sem_Association_Package (Assoc, Inter, Finish, Match); + + when Iir_Kind_Association_Element_By_Expression => + Sem_Association_By_Expression (Assoc, Inter, Finish, Match); + + when others => + Error_Kind ("sem_assocation", Assoc); + end case; + end Sem_Association; + + procedure Sem_Association_Chain + (Interface_Chain : Iir; + Assoc_Chain: in out Iir; + Finish: Boolean; + Missing : Missing_Type; + Loc : Iir; + Match : out Boolean) + is + -- Set POS and INTERFACE to *the* matching interface if any of ASSOC. + procedure Search_Interface (Assoc : Iir; + Inter : out Iir; + Pos : out Integer) + is + I_Match : Boolean; + begin + Inter := Interface_Chain; + Pos := 0; + while Inter /= Null_Iir loop + -- Formal assoc is not necessarily a simple name, it may + -- be a conversion function, or even an indexed or + -- selected name. + Sem_Association (Assoc, Inter, False, I_Match); + if I_Match then + return; + end if; + Inter := Get_Chain (Inter); + Pos := Pos + 1; + end loop; + end Search_Interface; + + Assoc: Iir; + Inter: Iir; + + type Bool_Array is array (Natural range <>) of Param_Assoc_Type; + Nbr_Arg: constant Natural := Get_Chain_Length (Interface_Chain); + Arg_Matched: Bool_Array (0 .. Nbr_Arg - 1) := (others => None); + + Last_Individual : Iir; + Has_Individual : Boolean; + Pos : Integer; + Formal : Iir; + + Interface_1 : Iir; + Pos_1 : Integer; + Assoc_1 : Iir; + begin + Match := True; + Has_Individual := False; + + -- Loop on every assoc element, try to match it. + Inter := Interface_Chain; + Last_Individual := Null_Iir; + Pos := 0; + + Assoc := Assoc_Chain; + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + if Formal = Null_Iir then + -- Positional argument. + if Pos < 0 then + -- Positional after named argument. Already caught by + -- Sem_Actual_Of_Association_Chain (because it is called only + -- once, while sem_association_chain may be called several + -- times). + Match := False; + return; + end if; + -- Try to match actual of ASSOC with the interface. + if Inter = Null_Iir then + if Finish then + Error_Msg_Sem + ("too many actuals for " & Disp_Node (Loc), Assoc); + end if; + Match := False; + return; + end if; + Sem_Association (Assoc, Inter, Finish, Match); + if not Match then + return; + end if; + if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then + Arg_Matched (Pos) := Open; + else + Arg_Matched (Pos) := Whole; + end if; + Set_Whole_Association_Flag (Assoc, True); + Inter := Get_Chain (Inter); + Pos := Pos + 1; + else + -- FIXME: directly search the formal if finish is true. + -- Find the Interface. + case Get_Kind (Formal) is + when Iir_Kind_Parenthesis_Name => + Assoc_1 := Sem_Formal_Conversion (Assoc); + if Assoc_1 /= Null_Iir then + Search_Interface (Assoc_1, Interface_1, Pos_1); + -- LRM 4.3.2.2 Association Lists + -- The formal part of a named element association may be + -- in the form of a function call, [...], if and only + -- if the mode of the formal is OUT, INOUT, BUFFER, or + -- LINKAGE, and the actual is not OPEN. + if Interface_1 = Null_Iir + or else Get_Mode (Interface_1) = Iir_In_Mode + then + Sem_Name_Clean (Get_Out_Conversion (Assoc_1)); + Free_Iir (Assoc_1); + Assoc_1 := Null_Iir; + end if; + end if; + Search_Interface (Assoc, Inter, Pos); + if Inter = Null_Iir then + if Assoc_1 /= Null_Iir then + Inter := Interface_1; + Pos := Pos_1; + Free_Parenthesis_Name + (Get_Formal (Assoc), Get_Out_Conversion (Assoc_1)); + Set_Formal (Assoc, Get_Formal (Assoc_1)); + Set_Out_Conversion + (Assoc, Get_Out_Conversion (Assoc_1)); + Set_Whole_Association_Flag + (Assoc, Get_Whole_Association_Flag (Assoc_1)); + Free_Iir (Assoc_1); + end if; + else + if Assoc_1 /= Null_Iir then + raise Internal_Error; + end if; + end if; + when others => + Search_Interface (Assoc, Inter, Pos); + end case; + + if Inter /= Null_Iir then + if Get_Whole_Association_Flag (Assoc) then + -- Whole association. + Last_Individual := Null_Iir; + if Arg_Matched (Pos) = None then + if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open + then + Arg_Matched (Pos) := Open; + else + Arg_Matched (Pos) := Whole; + end if; + else + if Finish then + Error_Msg_Sem + (Disp_Node (Inter) & " already associated", Assoc); + Match := False; + return; + end if; + end if; + else + -- Individual association. + Has_Individual := True; + if Arg_Matched (Pos) /= Whole then + if Finish + and then Arg_Matched (Pos) = Individual + and then Last_Individual /= Inter + then + Error_Msg_Sem + ("non consecutive individual association for " + & Disp_Node (Inter), Assoc); + Match := False; + return; + end if; + Last_Individual := Inter; + Arg_Matched (Pos) := Individual; + else + if Finish then + Error_Msg_Sem + (Disp_Node (Inter) & " already associated", Assoc); + Match := False; + return; + end if; + end if; + end if; + if Finish then + Sem_Association (Assoc, Inter, True, Match); + -- MATCH can be false du to errors. + end if; + else + -- Not found. + if Finish then + -- FIXME: display the name of subprg or component/entity. + -- FIXME: fetch the interface (for parenthesis_name). + Error_Msg_Sem + ("no interface for " & Disp_Node (Get_Formal (Assoc)) + & " in association", Assoc); + end if; + Match := False; + return; + end if; + end if; + Assoc := Get_Chain (Assoc); + end loop; + + if Finish and then Has_Individual then + Sem_Individual_Association (Assoc_Chain); + end if; + + if Missing = Missing_Allowed then + return; + end if; + + -- LRM93 8.6 Procedure Call Statement + -- For each formal parameter of a procedure, a procedure call must + -- specify exactly one corresponding actual parameter. + -- This actual parameter is specified either explicitly, by an + -- association element (other than the actual OPEN) in the association + -- list, or in the absence of such an association element, by a default + -- expression (see Section 4.3.3.2). + + -- LRM93 7.3.3 Function Calls + -- For each formal parameter of a function, a function call must + -- specify exactly one corresponding actual parameter. + -- This actual parameter is specified either explicitly, by an + -- association element (other than the actual OPEN) in the association + -- list, or in the absence of such an association element, by a default + -- expression (see Section 4.3.3.2). + + -- LRM93 1.1.1.2 / LRM08 6.5.6.3 Port clauses + -- A port of mode IN may be unconnected or unassociated only if its + -- declaration includes a default expression. + -- It is an error if a port of any mode other than IN is unconnected + -- or unassociated and its type is an unconstrained array type. + + -- LRM08 6.5.6.2 Generic clauses + -- It is an error if no such actual [instantiated package] is specified + -- for a given formal generic package (either because the formal generic + -- is unassociated or because the actual is OPEN). + + Inter := Interface_Chain; + Pos := 0; + while Inter /= Null_Iir loop + if Arg_Matched (Pos) <= Open then + case Get_Kind (Inter) is + when Iir_Kinds_Interface_Object_Declaration => + if Get_Default_Value (Inter) = Null_Iir then + case Missing is + when Missing_Parameter + | Missing_Generic => + if Finish then + Error_Msg_Sem + ("no actual for " & Disp_Node (Inter), Loc); + end if; + Match := False; + return; + when Missing_Port => + case Get_Mode (Inter) is + when Iir_In_Mode => + if not Finish then + raise Internal_Error; + end if; + Error_Msg_Sem + (Disp_Node (Inter) + & " of mode IN must be connected", Loc); + Match := False; + return; + when Iir_Out_Mode + | Iir_Linkage_Mode + | Iir_Inout_Mode + | Iir_Buffer_Mode => + if not Finish then + raise Internal_Error; + end if; + if not Is_Fully_Constrained_Type + (Get_Type (Inter)) + then + Error_Msg_Sem + ("unconstrained " & Disp_Node (Inter) + & " must be connected", Loc); + Match := False; + return; + end if; + when Iir_Unknown_Mode => + raise Internal_Error; + end case; + when Missing_Allowed => + null; + end case; + end if; + when Iir_Kind_Interface_Package_Declaration => + Error_Msg_Sem + (Disp_Node (Inter) & " must be associated", Loc); + Match := False; + when others => + Error_Kind ("sem_association_chain", Inter); + end case; + end if; + Inter := Get_Chain (Inter); + Pos := Pos + 1; + end loop; + end Sem_Association_Chain; +end Sem_Assocs; diff --git a/src/vhdl/sem_assocs.ads b/src/vhdl/sem_assocs.ads new file mode 100644 index 000000000..ec460e0e3 --- /dev/null +++ b/src/vhdl/sem_assocs.ads @@ -0,0 +1,60 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +package Sem_Assocs is + -- Change the kind of association corresponding to non-object interfaces. + -- Such an association mustn't be handled an like association for object. + function Extract_Non_Object_Association + (Assoc_Chain : Iir; Inter_Chain : Iir) return Iir; + + -- Semantize actuals of ASSOC_CHAIN. + -- Check all named associations are after positionnal one. + -- Return TRUE if no error. + function Sem_Actual_Of_Association_Chain (Assoc_Chain : Iir) return Boolean; + + -- Semantize association chain ASSOC_CHAIN with interfaces from + -- INTERFACE_CHAIN. + -- Return the level of compatibility between the two chains in LEVEL. + -- If FINISH is true, then ASSOC_CHAIN may be modifies (individual assoc + -- added), and error messages (if any) are displayed. + -- MISSING control unassociated interfaces. + -- LOC is the association. + -- Sem_Actual_Of_Association_Chain must have been called before. + type Missing_Type is (Missing_Parameter, Missing_Port, Missing_Generic, + Missing_Allowed); + procedure Sem_Association_Chain + (Interface_Chain : Iir; + Assoc_Chain: in out Iir; + Finish: Boolean; + Missing : Missing_Type; + Loc : Iir; + Match : out Boolean); + + -- Do port Sem_Association_Chain checks for subprograms. + procedure Check_Subprogram_Associations + (Inter_Chain : Iir; Assoc_Chain : Iir); + + -- Check for restrictions in §1.1.1.2 + -- Return FALSE in case of error. + function Check_Port_Association_Restriction + (Formal : Iir_Interface_Signal_Declaration; + Actual : Iir_Interface_Signal_Declaration; + Assoc : Iir) + return Boolean; +end Sem_Assocs; diff --git a/src/vhdl/sem_decls.adb b/src/vhdl/sem_decls.adb new file mode 100644 index 000000000..a7c0b4b44 --- /dev/null +++ b/src/vhdl/sem_decls.adb @@ -0,0 +1,3018 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Errorout; use Errorout; +with Types; use Types; +with Std_Names; +with Tokens; +with Flags; use Flags; +with Std_Package; use Std_Package; +with Ieee.Std_Logic_1164; +with Iir_Chains; +with Evaluation; use Evaluation; +with Name_Table; +with Iirs_Utils; use Iirs_Utils; +with Sem; use Sem; +with Sem_Expr; use Sem_Expr; +with Sem_Scopes; use Sem_Scopes; +with Sem_Names; use Sem_Names; +with Sem_Specs; use Sem_Specs; +with Sem_Types; use Sem_Types; +with Sem_Inst; +with Xrefs; use Xrefs; +use Iir_Chains; + +package body Sem_Decls is + -- Emit an error if the type of DECL is a file type, access type, + -- protected type or if a subelement of DECL is an access type. + procedure Check_Signal_Type (Decl : Iir) + is + Decl_Type : Iir; + begin + Decl_Type := Get_Type (Decl); + if Get_Signal_Type_Flag (Decl_Type) = False then + Error_Msg_Sem ("type of " & Disp_Node (Decl) + & " cannot be " & Disp_Node (Decl_Type), Decl); + case Get_Kind (Decl_Type) is + when Iir_Kind_File_Type_Definition => + null; + when Iir_Kind_Protected_Type_Declaration => + null; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + null; + when Iir_Kinds_Array_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Error_Msg_Sem ("(" & Disp_Node (Decl_Type) + & " has an access subelement)", Decl); + when others => + Error_Kind ("check_signal_type", Decl_Type); + end case; + end if; + end Check_Signal_Type; + + procedure Sem_Interface_Object_Declaration + (Inter, Last : Iir; Interface_Kind : Interface_Kind_Type) + is + A_Type: Iir; + Default_Value: Iir; + begin + -- Avoid the reanalysed duplicated types. + -- This is not an optimization, since the unanalysed type must have + -- been freed. + A_Type := Get_Subtype_Indication (Inter); + if A_Type = Null_Iir then + pragma Assert (Last /= Null_Iir); + Set_Subtype_Indication (Inter, Get_Subtype_Indication (Last)); + A_Type := Get_Type (Last); + Default_Value := Get_Default_Value (Last); + else + A_Type := Sem_Subtype_Indication (A_Type); + Set_Subtype_Indication (Inter, A_Type); + A_Type := Get_Type_Of_Subtype_Indication (A_Type); + + Default_Value := Get_Default_Value (Inter); + 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; + end if; + + Set_Name_Staticness (Inter, Locally); + Xref_Decl (Inter); + + if A_Type /= Null_Iir then + Set_Type (Inter, A_Type); + + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then + case Get_Signal_Kind (Inter) is + when Iir_No_Signal_Kind => + null; + when Iir_Bus_Kind => + -- FIXME: where this test came from ? + -- FIXME: from 4.3.1.2 ? + if False + and + (Get_Kind (A_Type) not in Iir_Kinds_Subtype_Definition + or else Get_Resolution_Indication (A_Type) = Null_Iir) + then + Error_Msg_Sem + (Disp_Node (A_Type) & " of guarded " & Disp_Node (Inter) + & " is not resolved", Inter); + end if; + + -- LRM 2.1.1.2 Signal parameter + -- It is an error if the declaration of a formal signal + -- parameter includes the reserved word BUS. + if Flags.Vhdl_Std >= Vhdl_93 + and then Interface_Kind in Parameter_Interface_List + then + Error_Msg_Sem + ("signal parameter can't be of kind bus", Inter); + end if; + when Iir_Register_Kind => + Error_Msg_Sem + ("interface signal can't be of kind register", Inter); + end case; + Set_Type_Has_Signal (A_Type); + end if; + + case Get_Kind (Inter) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Signal_Declaration => + -- LRM 4.3.2 Interface declarations + -- For an interface constant declaration or an interface + -- signal declaration, the subtype indication must define + -- a subtype that is neither a file type, an access type, + -- nor a protected type. Moreover, the subtype indication + -- must not denote a composite type with a subelement that + -- is a file type, an access type, or a protected type. + Check_Signal_Type (Inter); + when Iir_Kind_Interface_Variable_Declaration => + case Get_Kind (Get_Base_Type (A_Type)) is + when Iir_Kind_File_Type_Definition => + if Flags.Vhdl_Std >= Vhdl_93 then + Error_Msg_Sem ("variable formal type can't be a " + & "file type (vhdl 93)", Inter); + end if; + when Iir_Kind_Protected_Type_Declaration => + -- LRM 2.1.1.1 Constant and variable parameters + -- It is an error if the mode of the parameter is + -- other that INOUT. + if Get_Mode (Inter) /= Iir_Inout_Mode then + Error_Msg_Sem + ("parameter of protected type must be inout", Inter); + end if; + when others => + null; + end case; + when Iir_Kind_Interface_File_Declaration => + if Get_Kind (Get_Base_Type (A_Type)) + /= Iir_Kind_File_Type_Definition + then + Error_Msg_Sem + ("file formal type must be a file type", Inter); + end if; + when others => + -- Inter is not an interface. + raise Internal_Error; + end case; + + if Default_Value /= Null_Iir then + Set_Default_Value (Inter, Default_Value); + + -- LRM 4.3.2 Interface declarations. + -- It is an error if a default expression appears in an + -- interface declaration and any of the following conditions + -- hold: + -- - The mode is linkage + -- - The interface object is a formal signal parameter + -- - The interface object is a formal variable parameter of + -- mode other than in + -- - The subtype indication of the interface declaration + -- denotes a protected type. + case Get_Kind (Inter) is + when Iir_Kind_Interface_Constant_Declaration => + null; + when Iir_Kind_Interface_Signal_Declaration => + if Get_Mode (Inter) = Iir_Linkage_Mode then + Error_Msg_Sem + ("default expression not allowed for linkage port", + Inter); + elsif Interface_Kind in Parameter_Interface_List then + Error_Msg_Sem ("default expression not allowed" + & " for signal parameter", Inter); + end if; + when Iir_Kind_Interface_Variable_Declaration => + if Get_Mode (Inter) /= Iir_In_Mode then + Error_Msg_Sem + ("default expression not allowed for" + & " out or inout variable parameter", Inter); + elsif Get_Kind (A_Type) = Iir_Kind_Protected_Type_Declaration + then + Error_Msg_Sem + ("default expression not allowed for" + & " variable parameter of protected type", Inter); + end if; + when Iir_Kind_Interface_File_Declaration => + raise Internal_Error; + when others => + null; + end case; + end if; + else + Set_Type (Inter, Error_Type); + end if; + + Sem_Scopes.Add_Name (Inter); + + -- By default, interface are not static. + -- This may be changed just below. + Set_Expr_Staticness (Inter, None); + + case Interface_Kind is + when Generic_Interface_List => + -- LRM93 1.1.1 + -- The generic list in the formal generic clause defines + -- generic constants whose values may be determined by the + -- environment. + if Get_Kind (Inter) /= Iir_Kind_Interface_Constant_Declaration then + Error_Msg_Sem + ("generic " & Disp_Node (Inter) & " must be a constant", + Inter); + else + -- LRM93 7.4.2 (Globally static primaries) + -- 3. a generic constant. + Set_Expr_Staticness (Inter, Globally); + end if; + when Port_Interface_List => + if Get_Kind (Inter) /= Iir_Kind_Interface_Signal_Declaration then + Error_Msg_Sem + ("port " & Disp_Node (Inter) & " must be a signal", Inter); + end if; + when Parameter_Interface_List => + if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration + and then Interface_Kind = Function_Parameter_Interface_List + then + Error_Msg_Sem ("variable interface parameter are not " + & "allowed for a function (use a constant)", + Inter); + end if; + + -- By default, we suppose a subprogram read the activity of + -- a signal. + -- This will be adjusted when the body is analyzed. + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration + and then Get_Mode (Inter) in Iir_In_Modes + then + Set_Has_Active_Flag (Inter, True); + end if; + + case Get_Mode (Inter) is + when Iir_Unknown_Mode => + raise Internal_Error; + when Iir_In_Mode => + null; + when Iir_Inout_Mode + | Iir_Out_Mode => + if Interface_Kind = Function_Parameter_Interface_List + and then + Get_Kind (Inter) /= Iir_Kind_Interface_File_Declaration + then + Error_Msg_Sem ("mode of a function parameter cannot " + & "be inout or out", Inter); + end if; + when Iir_Buffer_Mode + | Iir_Linkage_Mode => + Error_Msg_Sem ("buffer or linkage mode is not allowed " + & "for a subprogram parameter", Inter); + end case; + end case; + end Sem_Interface_Object_Declaration; + + procedure Sem_Interface_Package_Declaration (Inter : Iir) + is + Pkg : Iir; + begin + -- LRM08 6.5.5 Interface package declarations + -- the uninstantiated_package_name shall denote an uninstantiated + -- package declared in a package declaration. + Pkg := Sem_Uninstantiated_Package_Name (Inter); + if Pkg = Null_Iir then + return; + end if; + + Sem_Inst.Instantiate_Package_Declaration (Inter, Pkg); + + if Get_Generic_Map_Aspect_Chain (Inter) /= Null_Iir then + -- TODO + raise Internal_Error; + end if; + + Sem_Scopes.Add_Name (Inter); + end Sem_Interface_Package_Declaration; + + procedure Sem_Interface_Chain (Interface_Chain: Iir; + Interface_Kind : Interface_Kind_Type) + is + Inter : Iir; + + -- LAST is the last interface declaration that has a type. This is + -- used to set type and default value for the following declarations + -- that appeared in a list of identifiers. + Last : Iir; + begin + Last := Null_Iir; + + Inter := Interface_Chain; + while Inter /= Null_Iir loop + case Get_Kind (Inter) is + when Iir_Kinds_Interface_Object_Declaration => + Sem_Interface_Object_Declaration (Inter, Last, Interface_Kind); + Last := Inter; + when Iir_Kind_Interface_Package_Declaration => + Sem_Interface_Package_Declaration (Inter); + when others => + raise Internal_Error; + end case; + Inter := Get_Chain (Inter); + end loop; + + -- LRM 10.3 Visibility + -- A declaration is visible only within a certain part of its scope; + -- this starts at the end of the declaration [...] + + -- LRM 4.3.2.1 Interface List + -- A name that denotes an interface object must not appear in any + -- interface declaration within the interface list containing the + -- denotes interface except to declare this object. + + -- GHDL: this is achieved by making the interface object visible after + -- having analyzed the interface list. + Inter := Interface_Chain; + while Inter /= Null_Iir loop + Name_Visible (Inter); + Inter := Get_Chain (Inter); + end loop; + end Sem_Interface_Chain; + + -- LRM93 7.2.2 + -- A discrete array is a one-dimensional array whose elements are of a + -- discrete type. + function Is_Discrete_Array (Def : Iir) return Boolean + is + begin + case Get_Kind (Def) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + null; + when others => + raise Internal_Error; + -- return False; + end case; + if not Is_One_Dimensional_Array_Type (Def) then + return False; + end if; + if Get_Kind (Get_Element_Subtype (Def)) + not in Iir_Kinds_Discrete_Type_Definition + then + return False; + end if; + return True; + end Is_Discrete_Array; + + procedure Create_Implicit_File_Primitives + (Decl : Iir_Type_Declaration; Type_Definition : Iir_File_Type_Definition) + is + use Iir_Chains.Interface_Declaration_Chain_Handling; + Type_Mark : constant Iir := Get_File_Type_Mark (Type_Definition); + Type_Mark_Type : constant Iir := Get_Type (Type_Mark); + Proc: Iir_Implicit_Procedure_Declaration; + Func: Iir_Implicit_Function_Declaration; + Inter: Iir; + Loc : Location_Type; + File_Interface_Kind : Iir_Kind; + Last_Interface : Iir; + Last : Iir; + begin + Last := Decl; + Loc := Get_Location (Decl); + + if Flags.Vhdl_Std >= Vhdl_93c then + for I in 1 .. 2 loop + -- Create the implicit file_open (form 1) declaration. + -- Create the implicit file_open (form 2) declaration. + Proc := Create_Iir (Iir_Kind_Implicit_Procedure_Declaration); + Set_Location (Proc, Loc); + Set_Parent (Proc, Get_Parent (Decl)); + Set_Identifier (Proc, Std_Names.Name_File_Open); + Set_Type_Reference (Proc, Decl); + Set_Visible_Flag (Proc, True); + Build_Init (Last_Interface); + case I is + when 1 => + Set_Implicit_Definition (Proc, Iir_Predefined_File_Open); + when 2 => + Set_Implicit_Definition (Proc, + Iir_Predefined_File_Open_Status); + -- status : out file_open_status. + Inter := + Create_Iir (Iir_Kind_Interface_Variable_Declaration); + Set_Location (Inter, Loc); + Set_Identifier (Inter, Std_Names.Name_Status); + Set_Type (Inter, + Std_Package.File_Open_Status_Type_Definition); + Set_Mode (Inter, Iir_Out_Mode); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Append (Last_Interface, Proc, Inter); + end case; + -- File F : FT + Inter := Create_Iir (Iir_Kind_Interface_File_Declaration); + Set_Location (Inter, Loc); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Type (Inter, Type_Definition); + Set_Mode (Inter, Iir_Inout_Mode); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Append (Last_Interface, Proc, Inter); + -- External_Name : in STRING + Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); + Set_Location (Inter, Loc); + Set_Identifier (Inter, Std_Names.Name_External_Name); + Set_Type (Inter, Std_Package.String_Type_Definition); + Set_Mode (Inter, Iir_In_Mode); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Append (Last_Interface, Proc, Inter); + -- Open_Kind : in File_Open_Kind := Read_Mode. + Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); + Set_Location (Inter, Loc); + Set_Identifier (Inter, Std_Names.Name_Open_Kind); + Set_Type (Inter, Std_Package.File_Open_Kind_Type_Definition); + Set_Mode (Inter, Iir_In_Mode); + Set_Default_Value (Inter, + Std_Package.File_Open_Kind_Read_Mode); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Append (Last_Interface, Proc, Inter); + Compute_Subprogram_Hash (Proc); + -- Add it to the list. + Insert_Incr (Last, Proc); + end loop; + + -- Create the implicit file_close declaration. + Proc := Create_Iir (Iir_Kind_Implicit_Procedure_Declaration); + Set_Identifier (Proc, Std_Names.Name_File_Close); + Set_Location (Proc, Loc); + Set_Parent (Proc, Get_Parent (Decl)); + Set_Implicit_Definition (Proc, Iir_Predefined_File_Close); + Set_Type_Reference (Proc, Decl); + Set_Visible_Flag (Proc, True); + Build_Init (Last_Interface); + Inter := Create_Iir (Iir_Kind_Interface_File_Declaration); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Location (Inter, Loc); + Set_Type (Inter, Type_Definition); + Set_Mode (Inter, Iir_Inout_Mode); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Append (Last_Interface, Proc, Inter); + Compute_Subprogram_Hash (Proc); + -- Add it to the list. + Insert_Incr (Last, Proc); + end if; + + if Flags.Vhdl_Std = Vhdl_87 then + File_Interface_Kind := Iir_Kind_Interface_Variable_Declaration; + else + File_Interface_Kind := Iir_Kind_Interface_File_Declaration; + end if; + + -- Create the implicit procedure read declaration. + Proc := Create_Iir (Iir_Kind_Implicit_Procedure_Declaration); + Set_Identifier (Proc, Std_Names.Name_Read); + Set_Location (Proc, Loc); + Set_Parent (Proc, Get_Parent (Decl)); + Set_Type_Reference (Proc, Decl); + Set_Visible_Flag (Proc, True); + Build_Init (Last_Interface); + Inter := Create_Iir (File_Interface_Kind); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Location (Inter, Loc); + Set_Type (Inter, Type_Definition); + Set_Mode (Inter, Iir_In_Mode); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Append (Last_Interface, Proc, Inter); + Inter := Create_Iir (Iir_Kind_Interface_Variable_Declaration); + Set_Identifier (Inter, Std_Names.Name_Value); + Set_Location (Inter, Loc); + Set_Subtype_Indication (Inter, Type_Mark); + Set_Type (Inter, Type_Mark_Type); + Set_Mode (Inter, Iir_Out_Mode); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Append (Last_Interface, Proc, Inter); + if Get_Kind (Type_Mark_Type) in Iir_Kinds_Array_Type_Definition + and then Get_Constraint_State (Type_Mark_Type) /= Fully_Constrained + then + Inter := Create_Iir (Iir_Kind_Interface_Variable_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_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + 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); + + -- Create the implicit procedure write declaration. + Proc := Create_Iir (Iir_Kind_Implicit_Procedure_Declaration); + Set_Identifier (Proc, Std_Names.Name_Write); + Set_Location (Proc, Loc); + Set_Parent (Proc, Get_Parent (Decl)); + Set_Type_Reference (Proc, Decl); + Set_Visible_Flag (Proc, True); + Build_Init (Last_Interface); + Inter := Create_Iir (File_Interface_Kind); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Location (Inter, Loc); + Set_Type (Inter, Type_Definition); + Set_Mode (Inter, Iir_Out_Mode); + Set_Name_Staticness (Inter, Locally); + Set_Expr_Staticness (Inter, None); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Append (Last_Interface, Proc, Inter); + Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); + Set_Identifier (Inter, Std_Names.Name_Value); + Set_Location (Inter, Loc); + Set_Subtype_Indication (Inter, Type_Mark); + Set_Type (Inter, Type_Mark_Type); + Set_Mode (Inter, Iir_In_Mode); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Append (Last_Interface, Proc, Inter); + Set_Implicit_Definition (Proc, Iir_Predefined_Write); + Compute_Subprogram_Hash (Proc); + -- Add it to the list. + Insert_Incr (Last, Proc); + + -- Create the implicit procedure flush declaration + if Flags.Vhdl_Std >= Vhdl_08 then + Proc := Create_Iir (Iir_Kind_Implicit_Procedure_Declaration); + Set_Identifier (Proc, Std_Names.Name_Flush); + Set_Location (Proc, Loc); + Set_Parent (Proc, Get_Parent (Decl)); + Set_Type_Reference (Proc, Decl); + Set_Visible_Flag (Proc, True); + Build_Init (Last_Interface); + Inter := Create_Iir (File_Interface_Kind); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Location (Inter, Loc); + Set_Type (Inter, Type_Definition); + Set_Name_Staticness (Inter, Locally); + Set_Expr_Staticness (Inter, None); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Append (Last_Interface, Proc, Inter); + Set_Implicit_Definition (Proc, Iir_Predefined_Flush); + Compute_Subprogram_Hash (Proc); + -- Add it to the list. + Insert_Incr (Last, Proc); + end if; + -- Create the implicit function endfile declaration. + Func := Create_Iir (Iir_Kind_Implicit_Function_Declaration); + Set_Identifier (Func, Std_Names.Name_Endfile); + Set_Location (Func, Loc); + Set_Parent (Func, Get_Parent (Decl)); + Set_Type_Reference (Func, Decl); + Set_Visible_Flag (Func, True); + Build_Init (Last_Interface); + Inter := Create_Iir (File_Interface_Kind); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Location (Inter, Loc); + Set_Type (Inter, Type_Definition); + Set_Mode (Inter, Iir_In_Mode); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Append (Last_Interface, Func, Inter); + Set_Return_Type (Func, Std_Package.Boolean_Type_Definition); + Set_Implicit_Definition (Func, Iir_Predefined_Endfile); + Compute_Subprogram_Hash (Func); + -- Add it to the list. + Insert_Incr (Last, Func); + end Create_Implicit_File_Primitives; + + function Create_Anonymous_Interface (Atype : Iir) + return Iir_Interface_Constant_Declaration + is + Inter : Iir_Interface_Constant_Declaration; + begin + Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); + Location_Copy (Inter, Atype); + Set_Identifier (Inter, Null_Identifier); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Set_Mode (Inter, Iir_In_Mode); + Set_Type (Inter, Atype); + return Inter; + end Create_Anonymous_Interface; + + procedure Create_Implicit_Operations + (Decl : Iir; Is_Std_Standard : Boolean := False) + is + use Std_Names; + Binary_Chain : Iir; + Unary_Chain : Iir; + Type_Definition : Iir; + Last : Iir; + + procedure Add_Operation + (Name : Name_Id; + Def : Iir_Predefined_Functions; + Interface_Chain : Iir; + Return_Type : Iir) + is + Operation : Iir_Implicit_Function_Declaration; + begin + Operation := Create_Iir (Iir_Kind_Implicit_Function_Declaration); + Location_Copy (Operation, Decl); + Set_Parent (Operation, Get_Parent (Decl)); + Set_Interface_Declaration_Chain (Operation, Interface_Chain); + Set_Type_Reference (Operation, Decl); + Set_Return_Type (Operation, Return_Type); + Set_Implicit_Definition (Operation, Def); + Set_Identifier (Operation, Name); + Set_Visible_Flag (Operation, True); + Compute_Subprogram_Hash (Operation); + Insert_Incr (Last, Operation); + end Add_Operation; + + procedure Add_Relational (Name : Name_Id; Def : Iir_Predefined_Functions) + is + begin + Add_Operation + (Name, Def, Binary_Chain, Std_Package.Boolean_Type_Definition); + end Add_Relational; + + procedure Add_Binary (Name : Name_Id; Def : Iir_Predefined_Functions) is + begin + Add_Operation (Name, Def, Binary_Chain, Type_Definition); + end Add_Binary; + + procedure Add_Unary (Name : Name_Id; Def : Iir_Predefined_Functions) is + begin + Add_Operation (Name, Def, Unary_Chain, Type_Definition); + end Add_Unary; + + procedure Add_To_String (Def : Iir_Predefined_Functions) is + begin + Add_Operation (Name_To_String, Def, + Unary_Chain, String_Type_Definition); + end Add_To_String; + + procedure Add_Min_Max (Name : Name_Id; Def : Iir_Predefined_Functions) + is + Left, Right : Iir; + begin + Left := Create_Anonymous_Interface (Type_Definition); + Set_Identifier (Left, Name_L); + Right := Create_Anonymous_Interface (Type_Definition); + Set_Identifier (Right, Name_R); + Set_Chain (Left, Right); + Add_Operation (Name, Def, Left, Type_Definition); + end Add_Min_Max; + + procedure Add_Vector_Min_Max + (Name : Name_Id; Def : Iir_Predefined_Functions) + is + Left : Iir; + begin + Left := Create_Anonymous_Interface (Type_Definition); + Set_Identifier (Left, Name_L); + Add_Operation + (Name, Def, Left, Get_Element_Subtype (Type_Definition)); + end Add_Vector_Min_Max; + + procedure Add_Shift_Operators + is + Inter_Chain : Iir_Interface_Constant_Declaration; + Inter_Int : Iir; + begin + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + + Inter_Int := Create_Iir (Iir_Kind_Interface_Constant_Declaration); + Location_Copy (Inter_Int, Decl); + Set_Identifier (Inter_Int, Null_Identifier); + Set_Mode (Inter_Int, Iir_In_Mode); + Set_Type (Inter_Int, Std_Package.Integer_Subtype_Definition); + Set_Lexical_Layout (Inter_Int, Iir_Lexical_Has_Type); + + Set_Chain (Inter_Chain, Inter_Int); + + Add_Operation + (Name_Sll, Iir_Predefined_Array_Sll, Inter_Chain, Type_Definition); + Add_Operation + (Name_Srl, Iir_Predefined_Array_Srl, Inter_Chain, Type_Definition); + Add_Operation + (Name_Sla, Iir_Predefined_Array_Sla, Inter_Chain, Type_Definition); + Add_Operation + (Name_Sra, Iir_Predefined_Array_Sra, Inter_Chain, Type_Definition); + Add_Operation + (Name_Rol, Iir_Predefined_Array_Rol, Inter_Chain, Type_Definition); + Add_Operation + (Name_Ror, Iir_Predefined_Array_Ror, Inter_Chain, Type_Definition); + end Add_Shift_Operators; + begin + Last := Decl; + + Type_Definition := Get_Base_Type (Get_Type_Definition (Decl)); + if Get_Kind (Type_Definition) /= Iir_Kind_File_Type_Definition then + Unary_Chain := Create_Anonymous_Interface (Type_Definition); + Binary_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain (Binary_Chain, Unary_Chain); + end if; + + case Get_Kind (Type_Definition) is + when Iir_Kind_Enumeration_Type_Definition => + Add_Relational (Name_Op_Equality, Iir_Predefined_Enum_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Enum_Inequality); + Add_Relational (Name_Op_Greater, Iir_Predefined_Enum_Greater); + Add_Relational + (Name_Op_Greater_Equal, Iir_Predefined_Enum_Greater_Equal); + Add_Relational (Name_Op_Less, Iir_Predefined_Enum_Less); + Add_Relational + (Name_Op_Less_Equal, Iir_Predefined_Enum_Less_Equal); + + if Flags.Vhdl_Std >= Vhdl_08 then + -- LRM08 5.2.6 Predefined operations on scalar types + -- Given a type declaration that declares a scalar type T, the + -- following operations are implicitely declared immediately + -- following the type declaration (except for the TO_STRING + -- operations in package STANDARD [...]) + Add_Min_Max (Name_Minimum, Iir_Predefined_Enum_Minimum); + Add_Min_Max (Name_Maximum, Iir_Predefined_Enum_Maximum); + if not Is_Std_Standard then + Add_To_String (Iir_Predefined_Enum_To_String); + end if; + + -- LRM08 9.2.3 Relational operators + -- The matching relational operators are predefined for the + -- [predefined type BIT and for the] type STD_ULOGIC defined + -- in package STD_LOGIC_1164. + if Type_Definition = Ieee.Std_Logic_1164.Std_Ulogic_Type then + Add_Binary (Name_Op_Match_Equality, + Iir_Predefined_Std_Ulogic_Match_Equality); + Add_Binary (Name_Op_Match_Inequality, + Iir_Predefined_Std_Ulogic_Match_Inequality); + Add_Binary (Name_Op_Match_Less, + Iir_Predefined_Std_Ulogic_Match_Less); + Add_Binary (Name_Op_Match_Less_Equal, + Iir_Predefined_Std_Ulogic_Match_Less_Equal); + Add_Binary (Name_Op_Match_Greater, + Iir_Predefined_Std_Ulogic_Match_Greater); + Add_Binary (Name_Op_Match_Greater_Equal, + Iir_Predefined_Std_Ulogic_Match_Greater_Equal); + end if; + end if; + + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + declare + Element_Type : Iir; + + Element_Array_Inter_Chain : Iir; + Array_Element_Inter_Chain : Iir; + Element_Element_Inter_Chain : Iir; + begin + Add_Relational + (Name_Op_Equality, Iir_Predefined_Array_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Array_Inequality); + if Is_Discrete_Array (Type_Definition) then + Add_Relational + (Name_Op_Greater, Iir_Predefined_Array_Greater); + Add_Relational + (Name_Op_Greater_Equal, + Iir_Predefined_Array_Greater_Equal); + Add_Relational + (Name_Op_Less, Iir_Predefined_Array_Less); + Add_Relational + (Name_Op_Less_Equal, Iir_Predefined_Array_Less_Equal); + + -- LRM08 5.3.2.4 Predefined operations on array types + -- Given a type declaration that declares a discrete array + -- type T, the following operatons are implicitly declared + -- immediately following the type declaration: + -- function MINIMUM (L, R : T) return T; + -- function MAXIMUM (L, R : T) return T; + if Vhdl_Std >= Vhdl_08 then + Add_Min_Max (Name_Maximum, Iir_Predefined_Array_Maximum); + Add_Min_Max (Name_Minimum, Iir_Predefined_Array_Minimum); + end if; + end if; + + Element_Type := Get_Element_Subtype (Type_Definition); + + if Is_One_Dimensional_Array_Type (Type_Definition) then + -- LRM93 7.2.4 Adding operators + -- The concatenation operator & is predefined for any + -- one-dimensional array type. + Add_Operation (Name_Op_Concatenation, + Iir_Predefined_Array_Array_Concat, + Binary_Chain, + Type_Definition); + + Element_Array_Inter_Chain := + Create_Anonymous_Interface (Element_Type); + Set_Chain (Element_Array_Inter_Chain, Unary_Chain); + Add_Operation (Name_Op_Concatenation, + Iir_Predefined_Element_Array_Concat, + Element_Array_Inter_Chain, + Type_Definition); + + Array_Element_Inter_Chain := + Create_Anonymous_Interface (Type_Definition); + Set_Chain (Array_Element_Inter_Chain, + Create_Anonymous_Interface (Element_Type)); + Add_Operation (Name_Op_Concatenation, + Iir_Predefined_Array_Element_Concat, + Array_Element_Inter_Chain, + Type_Definition); + + Element_Element_Inter_Chain := + Create_Anonymous_Interface (Element_Type); + Set_Chain (Element_Element_Inter_Chain, + Create_Anonymous_Interface (Element_Type)); + Add_Operation (Name_Op_Concatenation, + Iir_Predefined_Element_Element_Concat, + Element_Element_Inter_Chain, + Type_Definition); + + -- LRM08 5.3.2.4 Predefined operations on array types + -- In addition, given a type declaration that declares a + -- one-dimensional array type T whose elements are of a + -- sclar type E, the following operations are implicitly + -- declared immediately following the type declaration: + -- function MINIMUM (L : T) return E; + -- function MAXIMUM (L : T) return E; + if Vhdl_Std >= Vhdl_08 + and then (Get_Kind (Element_Type) in + Iir_Kinds_Scalar_Type_Definition) + then + Add_Vector_Min_Max + (Name_Maximum, Iir_Predefined_Vector_Maximum); + Add_Vector_Min_Max + (Name_Minimum, Iir_Predefined_Vector_Minimum); + end if; + + if Element_Type = Std_Package.Boolean_Type_Definition + or else Element_Type = Std_Package.Bit_Type_Definition + then + -- LRM93 7.2.1 Logical operators + -- LRM08 9.2.2 Logical operators + -- The binary logical operators AND, OR, NAND, NOR, XOR, + -- and XNOR, and the unary logical operator NOT are + -- defined for predefined types BIT and BOOLEAN. They + -- are also defined for any one-dimensional array type + -- whose element type is BIT or BOOLEAN. + + Add_Unary (Name_Not, Iir_Predefined_TF_Array_Not); + + Add_Binary (Name_And, Iir_Predefined_TF_Array_And); + Add_Binary (Name_Or, Iir_Predefined_TF_Array_Or); + Add_Binary (Name_Nand, Iir_Predefined_TF_Array_Nand); + Add_Binary (Name_Nor, Iir_Predefined_TF_Array_Nor); + Add_Binary (Name_Xor, Iir_Predefined_TF_Array_Xor); + if Flags.Vhdl_Std > Vhdl_87 then + Add_Binary (Name_Xnor, Iir_Predefined_TF_Array_Xnor); + + -- LRM93 7.2.3 Shift operators + -- The shift operators SLL, SRL, SLA, SRA, ROL and + -- ROR are defined for any one-dimensional array type + -- whose element type is either of the predefined + -- types BIT or BOOLEAN. + Add_Shift_Operators; + end if; + + -- LRM08 9.2.2 Logical operators + -- For the binary operators AND, OR, NAND, NOR, XOR and + -- XNOR, the operands shall both be [of the same base + -- type,] or one operand shall be of a scalar type and + -- the other operand shall be a one-dimensional array + -- whose element type is the scalar type. The result + -- type is the same as the base type of the operands if + -- [both operands are scalars of the same base type or] + -- both operands are arrays, or the same as the base type + -- of the array operand if one operand is a scalar and + -- the other operand is an array. + if Flags.Vhdl_Std >= Vhdl_08 then + Add_Operation + (Name_And, Iir_Predefined_TF_Element_Array_And, + Element_Array_Inter_Chain, Type_Definition); + Add_Operation + (Name_And, Iir_Predefined_TF_Array_Element_And, + Array_Element_Inter_Chain, Type_Definition); + Add_Operation + (Name_Or, Iir_Predefined_TF_Element_Array_Or, + Element_Array_Inter_Chain, Type_Definition); + Add_Operation + (Name_Or, Iir_Predefined_TF_Array_Element_Or, + Array_Element_Inter_Chain, Type_Definition); + Add_Operation + (Name_Nand, Iir_Predefined_TF_Element_Array_Nand, + Element_Array_Inter_Chain, Type_Definition); + Add_Operation + (Name_Nand, Iir_Predefined_TF_Array_Element_Nand, + Array_Element_Inter_Chain, Type_Definition); + Add_Operation + (Name_Nor, Iir_Predefined_TF_Element_Array_Nor, + Element_Array_Inter_Chain, Type_Definition); + Add_Operation + (Name_Nor, Iir_Predefined_TF_Array_Element_Nor, + Array_Element_Inter_Chain, Type_Definition); + Add_Operation + (Name_Xor, Iir_Predefined_TF_Element_Array_Xor, + Element_Array_Inter_Chain, Type_Definition); + Add_Operation + (Name_Xor, Iir_Predefined_TF_Array_Element_Xor, + Array_Element_Inter_Chain, Type_Definition); + Add_Operation + (Name_Xnor, Iir_Predefined_TF_Element_Array_Xnor, + Element_Array_Inter_Chain, Type_Definition); + Add_Operation + (Name_Xnor, Iir_Predefined_TF_Array_Element_Xnor, + Array_Element_Inter_Chain, Type_Definition); + end if; + + if Flags.Vhdl_Std >= Vhdl_08 then + -- LRM08 9.2.2 Logical operations + -- The unary logical operators AND, OR, NAND, NOR, + -- XOR, and XNOR are referred to as logical reduction + -- operators. The logical reduction operators are + -- predefined for any one-dimensional array type whose + -- element type is BIT or BOOLEAN. The result type + -- for the logical reduction operators is the same as + -- the element type of the operand. + Add_Operation + (Name_And, Iir_Predefined_TF_Reduction_And, + Unary_Chain, Element_Type); + Add_Operation + (Name_Or, Iir_Predefined_TF_Reduction_Or, + Unary_Chain, Element_Type); + Add_Operation + (Name_Nand, Iir_Predefined_TF_Reduction_Nand, + Unary_Chain, Element_Type); + Add_Operation + (Name_Nor, Iir_Predefined_TF_Reduction_Nor, + Unary_Chain, Element_Type); + Add_Operation + (Name_Xor, Iir_Predefined_TF_Reduction_Xor, + Unary_Chain, Element_Type); + Add_Operation + (Name_Xnor, Iir_Predefined_TF_Reduction_Xnor, + Unary_Chain, Element_Type); + end if; + end if; + + -- LRM08 9.2.3 Relational operators + -- The matching equality and matching inequality operatotrs + -- are also defined for any one-dimensional array type + -- whose element type is BIT or STD_ULOGIC. + if Flags.Vhdl_Std >= Vhdl_08 then + if Element_Type = Std_Package.Bit_Type_Definition then + Add_Operation + (Name_Op_Match_Equality, + Iir_Predefined_Bit_Array_Match_Equality, + Binary_Chain, Element_Type); + Add_Operation + (Name_Op_Match_Inequality, + Iir_Predefined_Bit_Array_Match_Inequality, + Binary_Chain, Element_Type); + elsif Element_Type = Ieee.Std_Logic_1164.Std_Ulogic_Type + then + Add_Operation + (Name_Op_Match_Equality, + Iir_Predefined_Std_Ulogic_Array_Match_Equality, + Binary_Chain, Element_Type); + Add_Operation + (Name_Op_Match_Inequality, + Iir_Predefined_Std_Ulogic_Array_Match_Inequality, + Binary_Chain, Element_Type); + end if; + end if; + + -- 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 (Element_Type) + = Iir_Kind_Enumeration_Type_Definition) + and then Get_Only_Characters_Flag (Element_Type) + then + Add_Operation (Name_To_String, + Iir_Predefined_Array_Char_To_String, + Unary_Chain, + String_Type_Definition); + end if; + end if; + end; + + when Iir_Kind_Access_Type_Definition => + Add_Relational (Name_Op_Equality, Iir_Predefined_Access_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Access_Inequality); + declare + Deallocate_Proc: Iir_Implicit_Procedure_Declaration; + Var_Interface: Iir_Interface_Variable_Declaration; + begin + Deallocate_Proc := + Create_Iir (Iir_Kind_Implicit_Procedure_Declaration); + Set_Identifier (Deallocate_Proc, Std_Names.Name_Deallocate); + Set_Implicit_Definition + (Deallocate_Proc, Iir_Predefined_Deallocate); + Var_Interface := + Create_Iir (Iir_Kind_Interface_Variable_Declaration); + Set_Identifier (Var_Interface, Std_Names.Name_P); + Set_Type (Var_Interface, Type_Definition); + Set_Mode (Var_Interface, Iir_Inout_Mode); + Set_Lexical_Layout (Var_Interface, Iir_Lexical_Has_Type); + --Set_Purity_State (Deallocate_Proc, Impure); + Set_Wait_State (Deallocate_Proc, False); + Set_Type_Reference (Deallocate_Proc, Decl); + Set_Visible_Flag (Deallocate_Proc, True); + + Set_Interface_Declaration_Chain + (Deallocate_Proc, Var_Interface); + Compute_Subprogram_Hash (Deallocate_Proc); + Insert_Incr (Last, Deallocate_Proc); + end; + + when Iir_Kind_Record_Type_Definition => + Add_Relational (Name_Op_Equality, Iir_Predefined_Record_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Record_Inequality); + + when Iir_Kind_Integer_Type_Definition => + Add_Relational (Name_Op_Equality, Iir_Predefined_Integer_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Integer_Inequality); + Add_Relational (Name_Op_Greater, Iir_Predefined_Integer_Greater); + Add_Relational + (Name_Op_Greater_Equal, Iir_Predefined_Integer_Greater_Equal); + Add_Relational (Name_Op_Less, Iir_Predefined_Integer_Less); + Add_Relational + (Name_Op_Less_Equal, Iir_Predefined_Integer_Less_Equal); + + Add_Binary (Name_Op_Plus, Iir_Predefined_Integer_Plus); + Add_Binary (Name_Op_Minus, Iir_Predefined_Integer_Minus); + + Add_Unary (Name_Op_Minus, Iir_Predefined_Integer_Negation); + Add_Unary (Name_Op_Plus, Iir_Predefined_Integer_Identity); + + Add_Binary (Name_Op_Mul, Iir_Predefined_Integer_Mul); + Add_Binary (Name_Op_Div, Iir_Predefined_Integer_Div); + Add_Binary (Name_Mod, Iir_Predefined_Integer_Mod); + Add_Binary (Name_Rem, Iir_Predefined_Integer_Rem); + + Add_Unary (Name_Abs, Iir_Predefined_Integer_Absolute); + + declare + Inter_Chain : Iir; + begin + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain + (Inter_Chain, + Create_Anonymous_Interface (Integer_Type_Definition)); + Add_Operation (Name_Op_Exp, Iir_Predefined_Integer_Exp, + Inter_Chain, Type_Definition); + end; + + if Vhdl_Std >= Vhdl_08 then + -- LRM08 5.2.6 Predefined operations on scalar types + -- Given a type declaration that declares a scalar type T, the + -- following operations are implicitely declared immediately + -- following the type declaration (except for the TO_STRING + -- operations in package STANDARD [...]) + Add_Min_Max (Name_Minimum, Iir_Predefined_Integer_Minimum); + Add_Min_Max (Name_Maximum, Iir_Predefined_Integer_Maximum); + if not Is_Std_Standard then + Add_To_String (Iir_Predefined_Integer_To_String); + end if; + end if; + + when Iir_Kind_Floating_Type_Definition => + Add_Relational + (Name_Op_Equality, Iir_Predefined_Floating_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Floating_Inequality); + Add_Relational + (Name_Op_Greater, Iir_Predefined_Floating_Greater); + Add_Relational + (Name_Op_Greater_Equal, Iir_Predefined_Floating_Greater_Equal); + Add_Relational + (Name_Op_Less, Iir_Predefined_Floating_Less); + Add_Relational + (Name_Op_Less_Equal, Iir_Predefined_Floating_Less_Equal); + + Add_Binary (Name_Op_Plus, Iir_Predefined_Floating_Plus); + Add_Binary (Name_Op_Minus, Iir_Predefined_Floating_Minus); + + Add_Unary (Name_Op_Minus, Iir_Predefined_Floating_Negation); + Add_Unary (Name_Op_Plus, Iir_Predefined_Floating_Identity); + + Add_Binary (Name_Op_Mul, Iir_Predefined_Floating_Mul); + Add_Binary (Name_Op_Div, Iir_Predefined_Floating_Div); + + Add_Unary (Name_Abs, Iir_Predefined_Floating_Absolute); + + declare + Inter_Chain : Iir; + begin + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain + (Inter_Chain, + Create_Anonymous_Interface (Integer_Type_Definition)); + Add_Operation (Name_Op_Exp, Iir_Predefined_Floating_Exp, + Inter_Chain, Type_Definition); + end; + + if Vhdl_Std >= Vhdl_08 then + -- LRM08 5.2.6 Predefined operations on scalar types + -- Given a type declaration that declares a scalar type T, the + -- following operations are implicitely declared immediately + -- following the type declaration (except for the TO_STRING + -- operations in package STANDARD [...]) + Add_Min_Max (Name_Minimum, Iir_Predefined_Floating_Minimum); + Add_Min_Max (Name_Maximum, Iir_Predefined_Floating_Maximum); + if not Is_Std_Standard then + Add_To_String (Iir_Predefined_Floating_To_String); + end if; + end if; + + when Iir_Kind_Physical_Type_Definition => + Add_Relational + (Name_Op_Equality, Iir_Predefined_Physical_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Physical_Inequality); + Add_Relational + (Name_Op_Greater, Iir_Predefined_Physical_Greater); + Add_Relational + (Name_Op_Greater_Equal, Iir_Predefined_Physical_Greater_Equal); + Add_Relational + (Name_Op_Less, Iir_Predefined_Physical_Less); + Add_Relational + (Name_Op_Less_Equal, Iir_Predefined_Physical_Less_Equal); + + Add_Binary (Name_Op_Plus, Iir_Predefined_Physical_Plus); + Add_Binary (Name_Op_Minus, Iir_Predefined_Physical_Minus); + + Add_Unary (Name_Op_Minus, Iir_Predefined_Physical_Negation); + Add_Unary (Name_Op_Plus, Iir_Predefined_Physical_Identity); + + declare + Inter_Chain : Iir; + begin + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain + (Inter_Chain, + Create_Anonymous_Interface (Integer_Type_Definition)); + Add_Operation (Name_Op_Mul, Iir_Predefined_Physical_Integer_Mul, + Inter_Chain, Type_Definition); + Add_Operation (Name_Op_Div, Iir_Predefined_Physical_Integer_Div, + Inter_Chain, Type_Definition); + end; + + declare + Inter_Chain : Iir; + begin + Inter_Chain := + Create_Anonymous_Interface (Integer_Type_Definition); + Set_Chain (Inter_Chain, Unary_Chain); + Add_Operation (Name_Op_Mul, Iir_Predefined_Integer_Physical_Mul, + Inter_Chain, Type_Definition); + end; + + declare + Inter_Chain : Iir; + begin + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain (Inter_Chain, + Create_Anonymous_Interface (Real_Type_Definition)); + Add_Operation (Name_Op_Mul, Iir_Predefined_Physical_Real_Mul, + Inter_Chain, Type_Definition); + Add_Operation (Name_Op_Div, Iir_Predefined_Physical_Real_Div, + Inter_Chain, Type_Definition); + end; + + declare + Inter_Chain : Iir; + begin + Inter_Chain := + Create_Anonymous_Interface (Real_Type_Definition); + Set_Chain (Inter_Chain, Unary_Chain); + Add_Operation (Name_Op_Mul, Iir_Predefined_Real_Physical_Mul, + Inter_Chain, Type_Definition); + end; + Add_Operation (Name_Op_Div, Iir_Predefined_Physical_Physical_Div, + Binary_Chain, + Std_Package.Convertible_Integer_Type_Definition); + + Add_Unary (Name_Abs, Iir_Predefined_Physical_Absolute); + + if Vhdl_Std >= Vhdl_08 then + -- LRM08 5.2.6 Predefined operations on scalar types + -- Given a type declaration that declares a scalar type T, the + -- following operations are implicitely declared immediately + -- following the type declaration (except for the TO_STRING + -- operations in package STANDARD [...]) + Add_Min_Max (Name_Minimum, Iir_Predefined_Physical_Minimum); + Add_Min_Max (Name_Maximum, Iir_Predefined_Physical_Maximum); + if not Is_Std_Standard then + Add_To_String (Iir_Predefined_Physical_To_String); + end if; + end if; + + when Iir_Kind_File_Type_Definition => + Create_Implicit_File_Primitives (Decl, Type_Definition); + + when Iir_Kind_Protected_Type_Declaration => + null; + + when others => + Error_Kind ("create_predefined_operations", Type_Definition); + end case; + + if not Is_Std_Standard then + return; + end if; + if Decl = Std_Package.Boolean_Type_Declaration then + Add_Binary (Name_And, Iir_Predefined_Boolean_And); + Add_Binary (Name_Or, Iir_Predefined_Boolean_Or); + Add_Binary (Name_Nand, Iir_Predefined_Boolean_Nand); + Add_Binary (Name_Nor, Iir_Predefined_Boolean_Nor); + Add_Binary (Name_Xor, Iir_Predefined_Boolean_Xor); + if Flags.Vhdl_Std > Vhdl_87 then + Add_Binary (Name_Xnor, Iir_Predefined_Boolean_Xnor); + end if; + Add_Unary (Name_Not, Iir_Predefined_Boolean_Not); + elsif Decl = Std_Package.Bit_Type_Declaration then + Add_Binary (Name_And, Iir_Predefined_Bit_And); + Add_Binary (Name_Or, Iir_Predefined_Bit_Or); + Add_Binary (Name_Nand, Iir_Predefined_Bit_Nand); + Add_Binary (Name_Nor, Iir_Predefined_Bit_Nor); + Add_Binary (Name_Xor, Iir_Predefined_Bit_Xor); + if Flags.Vhdl_Std > Vhdl_87 then + Add_Binary (Name_Xnor, Iir_Predefined_Bit_Xnor); + end if; + Add_Unary (Name_Not, Iir_Predefined_Bit_Not); + if Flags.Vhdl_Std >= Vhdl_08 then + Add_Binary (Name_Op_Match_Equality, + Iir_Predefined_Bit_Match_Equality); + Add_Binary (Name_Op_Match_Inequality, + Iir_Predefined_Bit_Match_Inequality); + Add_Binary (Name_Op_Match_Less, + Iir_Predefined_Bit_Match_Less); + Add_Binary (Name_Op_Match_Less_Equal, + Iir_Predefined_Bit_Match_Less_Equal); + Add_Binary (Name_Op_Match_Greater, + Iir_Predefined_Bit_Match_Greater); + Add_Binary (Name_Op_Match_Greater_Equal, + Iir_Predefined_Bit_Match_Greater_Equal); + + -- LRM08 9.2.9 Condition operator + -- The unary operator ?? is predefined for type BIT defined in + -- package STANDARD. + Add_Operation (Name_Op_Condition, Iir_Predefined_Bit_Condition, + Unary_Chain, Std_Package.Boolean_Type_Definition); + + end if; + elsif Decl = Std_Package.Universal_Real_Type_Declaration then + declare + Inter_Chain : Iir; + begin + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain + (Inter_Chain, + Create_Anonymous_Interface (Universal_Integer_Type_Definition)); + Add_Operation (Name_Op_Mul, Iir_Predefined_Universal_R_I_Mul, + Inter_Chain, Type_Definition); + Add_Operation (Name_Op_Div, Iir_Predefined_Universal_R_I_Div, + Inter_Chain, Type_Definition); + end; + + declare + Inter_Chain : Iir; + begin + Inter_Chain := + Create_Anonymous_Interface (Universal_Integer_Type_Definition); + Set_Chain (Inter_Chain, Unary_Chain); + Add_Operation (Name_Op_Mul, Iir_Predefined_Universal_I_R_Mul, + Inter_Chain, Type_Definition); + end; + end if; + end Create_Implicit_Operations; + + procedure Sem_Type_Declaration (Decl: Iir; Is_Global : Boolean) + is + Def: Iir; + Inter : Name_Interpretation_Type; + Old_Decl : Iir; + St_Decl : Iir_Subtype_Declaration; + Bt_Def : Iir; + begin + -- Check if DECL complete a previous incomplete type declaration. + Inter := Get_Interpretation (Get_Identifier (Decl)); + if Valid_Interpretation (Inter) + and then Is_In_Current_Declarative_Region (Inter) + then + Old_Decl := Get_Declaration (Inter); + if Get_Kind (Old_Decl) /= Iir_Kind_Type_Declaration + or else (Get_Kind (Get_Type_Definition (Old_Decl)) /= + Iir_Kind_Incomplete_Type_Definition) + then + Old_Decl := Null_Iir; + end if; + else + Old_Decl := Null_Iir; + end if; + + if Old_Decl = Null_Iir then + if Get_Kind (Decl) = Iir_Kind_Type_Declaration then + -- This is necessary at least for enumeration type definition. + Sem_Scopes.Add_Name (Decl); + end if; + else + -- This is a way to prevent: + -- type a; + -- type a is access a; + -- which is non-sense. + Set_Visible_Flag (Old_Decl, False); + end if; + + -- Check the definition of the type. + Def := Get_Type_Definition (Decl); + if Def = Null_Iir then + -- Incomplete type declaration + Def := Create_Iir (Iir_Kind_Incomplete_Type_Definition); + Location_Copy (Def, Decl); + Set_Type_Definition (Decl, Def); + Set_Base_Type (Def, Def); + Set_Signal_Type_Flag (Def, True); + Set_Type_Declarator (Def, Decl); + Set_Visible_Flag (Decl, True); + Set_Incomplete_Type_List (Def, Create_Iir_List); + Xref_Decl (Decl); + else + -- A complete type declaration. + if Old_Decl = Null_Iir then + Xref_Decl (Decl); + else + Xref_Body (Decl, Old_Decl); + end if; + + Def := Sem_Type_Definition (Def, Decl); + + if Def /= Null_Iir then + case Get_Kind (Def) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Array_Subtype_Definition => + -- Some type declaration are in fact subtype declarations. + St_Decl := Create_Iir (Iir_Kind_Subtype_Declaration); + Location_Copy (St_Decl, Decl); + Set_Identifier (St_Decl, Get_Identifier (Decl)); + Set_Type (St_Decl, Def); + Set_Type_Declarator (Def, St_Decl); + Set_Chain (St_Decl, Get_Chain (Decl)); + Set_Chain (Decl, St_Decl); + + -- The type declaration declares the base type. + Bt_Def := Get_Base_Type (Def); + Set_Type_Definition (Decl, Bt_Def); + Set_Type_Declarator (Bt_Def, Decl); + Set_Subtype_Definition (Decl, Def); + + if Old_Decl = Null_Iir then + Sem_Scopes.Add_Name (St_Decl); + else + Replace_Name (Get_Identifier (Decl), Old_Decl, St_Decl); + Set_Type_Declarator + (Get_Type_Definition (Old_Decl), St_Decl); + end if; + + Sem_Scopes.Name_Visible (St_Decl); + + -- The implicit subprogram will be added in the + -- scope just after. + Create_Implicit_Operations (Decl, False); + + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Access_Type_Definition + | Iir_Kind_File_Type_Definition => + St_Decl := Null_Iir; + Set_Type_Declarator (Def, Decl); + + Sem_Scopes.Name_Visible (Decl); + + -- The implicit subprogram will be added in the + -- scope just after. + Create_Implicit_Operations (Decl, False); + + when Iir_Kind_Protected_Type_Declaration => + Set_Type_Declarator (Def, Decl); + St_Decl := Null_Iir; + -- No implicit subprograms. + + when others => + Error_Kind ("sem_type_declaration", Def); + end case; + + if Old_Decl /= Null_Iir then + -- Complete the type definition. + declare + List : Iir_List; + El : Iir; + Old_Def : Iir; + begin + Old_Def := Get_Type_Definition (Old_Decl); + Set_Signal_Type_Flag (Old_Def, Get_Signal_Type_Flag (Def)); + List := Get_Incomplete_Type_List (Old_Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Set_Designated_Type (El, Def); + end loop; + -- Complete the incomplete_type_definition node + -- (set type_declarator and base_type). + + Set_Base_Type (Old_Def, Get_Base_Type (Def)); + if St_Decl = Null_Iir then + Set_Type_Declarator (Old_Def, Decl); + Replace_Name (Get_Identifier (Decl), Old_Decl, Decl); + end if; + end; + end if; + + if Is_Global then + Set_Type_Has_Signal (Def); + end if; + end if; + end if; + end Sem_Type_Declaration; + + procedure Sem_Subtype_Declaration (Decl: Iir; Is_Global : Boolean) + is + Def: Iir; + Ind : Iir; + begin + -- Real hack to skip subtype declarations of anonymous type decls. + if Get_Visible_Flag (Decl) then + return; + end if; + + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + -- Analyze the definition of the type. + Ind := Get_Subtype_Indication (Decl); + Ind := Sem_Subtype_Indication (Ind); + Set_Subtype_Indication (Decl, Ind); + Def := Get_Type_Of_Subtype_Indication (Ind); + if Def = Null_Iir then + return; + end if; + + if not Is_Anonymous_Type_Definition (Def) then + -- There is no added constraints and therefore the subtype + -- declaration is in fact an alias of the type. Create a copy so + -- that it has its own type declarator. + Def := Copy_Subtype_Indication (Def); + Location_Copy (Def, Decl); + Set_Subtype_Type_Mark (Def, Ind); + Set_Subtype_Indication (Decl, Def); + end if; + + Set_Type (Decl, Def); + Set_Type_Declarator (Def, Decl); + Name_Visible (Decl); + if Is_Global then + Set_Type_Has_Signal (Def); + end if; + end Sem_Subtype_Declaration; + + -- If DECL is a constant declaration, and there is already a constant + -- declaration in the current scope with the same name, then return it. + -- Otherwise, return NULL. + function Get_Deferred_Constant (Decl : Iir) return Iir + is + Deferred_Const : Iir; + Interp : Name_Interpretation_Type; + begin + if Get_Kind (Decl) /= Iir_Kind_Constant_Declaration then + return Null_Iir; + end if; + Interp := Get_Interpretation (Get_Identifier (Decl)); + if not Valid_Interpretation (Interp) then + return Null_Iir; + end if; + + if not Is_In_Current_Declarative_Region (Interp) + or else Is_Potentially_Visible (Interp) + then + -- Deferred and full declarations must be declared in the same + -- declarative region. + return Null_Iir; + end if; + + Deferred_Const := Get_Declaration (Interp); + if Get_Kind (Deferred_Const) /= Iir_Kind_Constant_Declaration then + return Null_Iir; + end if; + -- LRM93 4.3.1.1 + -- The corresponding full constant declaration, which defines the value + -- of the constant, must appear in the body of the package. + if Get_Kind (Get_Library_Unit (Get_Current_Design_Unit)) + /= Iir_Kind_Package_Body + then + Error_Msg_Sem + ("full constant declaration must appear in package body", Decl); + end if; + return Deferred_Const; + end Get_Deferred_Constant; + + procedure Sem_Object_Declaration (Decl: Iir; Parent : Iir; Last_Decl : Iir) + is + Deferred_Const : constant Iir := Get_Deferred_Constant (Decl); + Atype: Iir; + Default_Value : Iir; + Staticness : Iir_Staticness; + begin + -- LRM08 12.2 Scope of declarations + -- Then scope of a declaration [...] extends from the beginning of the + -- declaration [...] + if Deferred_Const = Null_Iir then + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + else + Xref_Ref (Decl, Deferred_Const); + end if; + + -- Semantize type and default value: + Atype := Get_Subtype_Indication (Decl); + if Atype /= Null_Iir then + Atype := Sem_Subtype_Indication (Atype); + Set_Subtype_Indication (Decl, Atype); + Atype := Get_Type_Of_Subtype_Indication (Atype); + if Atype = Null_Iir then + Atype := Create_Error_Type (Get_Type (Decl)); + end if; + + Default_Value := Get_Default_Value (Decl); + if Default_Value /= Null_Iir then + Default_Value := Sem_Expression (Default_Value, Atype); + if Default_Value = Null_Iir then + Default_Value := + Create_Error_Expr (Get_Default_Value (Decl), Atype); + end if; + Check_Read (Default_Value); + Default_Value := Eval_Expr_Check_If_Static (Default_Value, Atype); + end if; + else + Default_Value := Get_Default_Value (Last_Decl); + Atype := Get_Type (Last_Decl); + end if; + + Set_Type (Decl, Atype); + Set_Default_Value (Decl, Default_Value); + Set_Name_Staticness (Decl, Locally); + Set_Visible_Flag (Decl, True); + + -- LRM93 2.6 + -- The subtype indication given in the full declaration of the deferred + -- constant must conform to that given in the deferred constant + -- declaration. + if Deferred_Const /= Null_Iir + and then not Are_Trees_Equal (Get_Type (Decl), + Get_Type (Deferred_Const)) + then + Error_Msg_Sem + ("subtype indication doesn't conform with the deferred constant", + Decl); + end if; + + -- LRM 4.3.1.3 + -- It is an error if a variable declaration declares a variable that is + -- of a file type. + -- + -- LRM 4.3.1.1 + -- It is an error if a constant declaration declares a constant that is + -- of a file type, or an access type, or a composite type which has + -- subelement that is a file type of an access type. + -- + -- LRM 4.3.1.2 + -- It is an error if a signal declaration declares a signal that is of + -- a file type [or an access type]. + case Get_Kind (Atype) is + when Iir_Kind_File_Type_Definition => + Error_Msg_Sem (Disp_Node (Decl) & " cannot be of type file", Decl); + when others => + if Get_Kind (Decl) /= Iir_Kind_Variable_Declaration then + Check_Signal_Type (Decl); + end if; + end case; + + if not Check_Implicit_Conversion (Atype, Default_Value) then + Error_Msg_Sem + ("default value length does not match object type length", Decl); + end if; + + case Get_Kind (Decl) is + when Iir_Kind_Constant_Declaration => + -- LRM93 4.3.1.1 + -- If the assignment symbol ":=" followed by an expression is not + -- present in a constant declaration, then the declaration + -- declares a deferred constant. + -- Such a constant declaration may only appear in a package + -- declaration. + if Deferred_Const /= Null_Iir then + Set_Deferred_Declaration (Decl, Deferred_Const); + Set_Deferred_Declaration (Deferred_Const, Decl); + end if; + if Default_Value = Null_Iir then + if Deferred_Const /= Null_Iir then + Error_Msg_Sem + ("full constant declaration must have a default value", + Decl); + else + Set_Deferred_Declaration_Flag (Decl, True); + end if; + if Get_Kind (Parent) /= Iir_Kind_Package_Declaration then + Error_Msg_Sem ("a constant must have a default value", Decl); + end if; + Set_Expr_Staticness (Decl, Globally); + else + -- LRM93 7.4.1: a locally static primary is defined: + -- A constant (other than deferred constant) explicitly + -- declared by a constant declaration and initialized + -- with a locally static expression. + -- Note: the staticness of the full declaration may be locally. + if False and Deferred_Const /= Null_Iir then + -- This is a deferred constant. + Staticness := Globally; + else + Staticness := Min (Get_Expr_Staticness (Default_Value), + Get_Type_Staticness (Atype)); + -- What about expr staticness of c in: + -- constant c : bit_vector (a to b) := "01"; + -- where a and b are not locally static ? + --Staticness := Get_Expr_Staticness (Default_Value); + + -- LRM 7.4.2 (Globally static primaries) + -- 5. a constant + if Staticness < Globally then + Staticness := Globally; + end if; + end if; + Set_Expr_Staticness (Decl, Staticness); + end if; + + when Iir_Kind_Signal_Declaration => + -- LRM93 4.3.1.2 + -- It is also an error if a guarded signal of a + -- scalar type is neither a resolved signal nor a + -- subelement of a resolved signal. + if Get_Signal_Kind (Decl) /= Iir_No_Signal_Kind + and then not Get_Resolved_Flag (Atype) + then + Error_Msg_Sem + ("guarded " & Disp_Node (Decl) & " must be resolved", Decl); + end if; + Set_Expr_Staticness (Decl, None); + Set_Has_Disconnect_Flag (Decl, False); + Set_Type_Has_Signal (Atype); + + when Iir_Kind_Variable_Declaration => + -- LRM93 4.3.1.3 Variable declarations + -- Variable declared immediatly within entity declarations, + -- architectures bodies, packages, packages bodies, and blocks + -- must be shared variable. + -- Variables declared immediatly within subprograms and + -- processes must not be shared variables. + -- Variables may appear in proteted type bodies; such + -- variables, which must not be shared variables, represent + -- shared data. + case Get_Kind (Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + if not Get_Shared_Flag (Decl) then + Error_Msg_Sem + ("non shared variable declaration not allowed here", + Decl); + end if; + when Iir_Kinds_Process_Statement + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + if Get_Shared_Flag (Decl) then + Error_Msg_Sem + ("shared variable declaration not allowed here", Decl); + end if; + when Iir_Kind_Protected_Type_Body => + if Get_Shared_Flag (Decl) then + Error_Msg_Sem + ("variable of protected type body must not be shared", + Decl); + end if; + when Iir_Kind_Protected_Type_Declaration => + -- This is not allowed, but caught + -- in sem_protected_type_declaration. + null; + when others => + Error_Kind ("sem_object_declaration(2)", Parent); + end case; + + if Flags.Vhdl_Std >= Vhdl_00 then + declare + Base_Type : Iir; + Is_Protected : Boolean; + begin + Base_Type := Get_Base_Type (Atype); + Is_Protected := + Get_Kind (Base_Type) = Iir_Kind_Protected_Type_Declaration; + + -- LRM00 4.3.1.3 + -- The base type of the subtype indication of a + -- shared variable declaration must be a protected type. + if Get_Shared_Flag (Decl) and not Is_Protected then + Error_Msg_Sem + ("type of a shared variable must be a protected type", + Decl); + end if; + + -- LRM00 4.3.1.3 Variable declarations + -- If a given variable appears (directly or indirectly) + -- within a protected type body, then the base type + -- denoted by the subtype indication of the variable + -- declarations must not be a protected type defined by + -- the protected type body. + -- FIXME: indirectly ? + if Is_Protected + and then Get_Kind (Parent) = Iir_Kind_Protected_Type_Body + and then Base_Type + = Get_Protected_Type_Declaration (Parent) + then + Error_Msg_Sem + ("variable type must not be of the protected type body", + Decl); + end if; + end; + end if; + Set_Expr_Staticness (Decl, None); + when others => + Error_Kind ("sem_object_declaration", Decl); + end case; + + case Get_Kind (Decl) is + when Iir_Kind_Constant_Declaration => + -- LRM93 §3.2.1.1 + -- For a constant declared by an object declaration, the index + -- ranges are defined by the initial value, if the subtype of the + -- constant is unconstrained; otherwise they are defined by this + -- subtype. + --if Default_Value = Null_Iir + -- and then not Sem_Is_Constrained (Atype) + --then + -- Error_Msg_Sem ("constant declaration of unconstrained " + -- & Disp_Node (Atype) & " is not allowed", Decl); + --end if; + null; + --if Deferred_Const = Null_Iir then + -- Name_Visible (Decl); + --end if; + + when Iir_Kind_Variable_Declaration + | Iir_Kind_Signal_Declaration => + -- LRM93 3.2.1.1 / LRM08 5.3.2.2 + -- 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 Is_Fully_Constrained_Type (Atype) then + Error_Msg_Sem + ("declaration of " & Disp_Node (Decl) + & " with unconstrained " & Disp_Node (Atype) + & " is not allowed", Decl); + if Default_Value /= Null_Iir then + Error_Msg_Sem ("(even with a default value)", Decl); + end if; + end if; + + when others => + Error_Kind ("sem_object_declaration(2)", Decl); + end case; + end Sem_Object_Declaration; + + procedure Sem_File_Declaration (Decl: Iir_File_Declaration; Last_Decl : Iir) + is + Atype: Iir; + Logical_Name: Iir; + Open_Kind : Iir; + begin + Sem_Scopes.Add_Name (Decl); + Set_Expr_Staticness (Decl, None); + Xref_Decl (Decl); + + -- Try to find a type. + Atype := Get_Subtype_Indication (Decl); + if Atype /= Null_Iir then + Atype := Sem_Subtype_Indication (Atype); + Set_Subtype_Indication (Decl, Atype); + Atype := Get_Type_Of_Subtype_Indication (Atype); + if Atype = Null_Iir then + Atype := Create_Error_Type (Get_Type (Decl)); + end if; + else + Atype := Get_Type (Last_Decl); + end if; + Set_Type (Decl, Atype); + + -- LRM93 4.3.1.4 + -- The subtype indication of a file declaration must define a file + -- subtype. + if Get_Kind (Atype) /= Iir_Kind_File_Type_Definition then + Error_Msg_Sem ("file subtype expected for a file declaration", Decl); + return; + end if; + + Logical_Name := Get_File_Logical_Name (Decl); + -- LRM93 4.3.1.4 + -- The file logical name must be an expression of predefined type + -- STRING. + if Logical_Name /= Null_Iir then + Logical_Name := Sem_Expression (Logical_Name, String_Type_Definition); + if Logical_Name /= Null_Iir then + Check_Read (Logical_Name); + Set_File_Logical_Name (Decl, Logical_Name); + end if; + end if; + + Open_Kind := Get_File_Open_Kind (Decl); + if Open_Kind /= Null_Iir then + Open_Kind := + Sem_Expression (Open_Kind, File_Open_Kind_Type_Definition); + if Open_Kind /= Null_Iir then + Check_Read (Open_Kind); + Set_File_Open_Kind (Decl, Open_Kind); + end if; + else + -- LRM93 4.3.1.4 + -- If a file open kind expression is not included in the file open + -- information of a given file declaration, then the default value + -- of READ_MODE is used during elaboration of the file declaration. + -- + -- LRM87 4.3.1.4 + -- The default mode is IN, if no mode is specified. + if Get_Mode (Decl) = Iir_Unknown_Mode then + if Flags.Vhdl_Std = Vhdl_87 then + Set_Mode (Decl, Iir_In_Mode); + else + null; + -- Set_File_Open_Kind (Decl, File_Open_Kind_Read_Mode); + end if; + end if; + end if; + Name_Visible (Decl); + + -- LRM 93 2.2 + -- If a pure function is the parent of a given procedure, then + -- that procedure must not contain a reference to an explicitly + -- declared file object [...] + -- + -- A pure function must not contain a reference to an explicitly + -- declared file. + + -- Note: this check is also performed when a file is referenced. + -- But a file can be declared without being explicitly referenced. + if Flags.Vhdl_Std > Vhdl_93c then + declare + Parent : Iir; + Spec : Iir; + begin + Parent := Get_Parent (Decl); + case Get_Kind (Parent) is + when Iir_Kind_Function_Body => + Spec := Get_Subprogram_Specification (Parent); + if Get_Pure_Flag (Spec) then + Error_Msg_Sem + ("cannot declare a file in a pure function", Decl); + end if; + when Iir_Kind_Procedure_Body => + Spec := Get_Subprogram_Specification (Parent); + Set_Purity_State (Spec, Impure); + Set_Impure_Depth (Parent, Iir_Depth_Impure); + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Error_Kind ("sem_file_declaration", Parent); + when others => + null; + end case; + end; + end if; + end Sem_File_Declaration; + + procedure Sem_Attribute_Declaration (Decl: Iir_Attribute_Declaration) + is + A_Type : Iir; + Ident : Name_Id; + begin + -- LRM93 4.4 + -- The identifier is said to be the designator of the attribute. + Ident := Get_Identifier (Decl); + if Ident in Std_Names.Name_Id_Attributes + or else (Flags.Vhdl_Std = Vhdl_87 + and then Ident in Std_Names.Name_Id_Vhdl87_Attributes) + or else (Flags.Vhdl_Std > Vhdl_87 + and then Ident in Std_Names.Name_Id_Vhdl93_Attributes) + then + Error_Msg_Sem ("predefined attribute """ & Name_Table.Image (Ident) + & """ overriden", Decl); + end if; + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + A_Type := Sem_Type_Mark (Get_Type_Mark (Decl)); + Set_Type_Mark (Decl, A_Type); + A_Type := Get_Type (A_Type); + Set_Type (Decl, A_Type); + + -- LRM93 4.4 Attribute declarations. + -- It is an error if the type mark denotes an access type, a file type, + -- a protected type, or a composite type with a subelement that is + -- an access type, a file type, or a protected type. + -- The subtype need not be constrained. + Check_Signal_Type (Decl); + Name_Visible (Decl); + end Sem_Attribute_Declaration; + + procedure Sem_Component_Declaration (Component: Iir_Component_Declaration) + is + begin + Sem_Scopes.Add_Name (Component); + Xref_Decl (Component); + + -- LRM 10.1 Declarative region + -- 6. A component declaration. + Open_Declarative_Region; + + Sem_Interface_Chain + (Get_Generic_Chain (Component), Generic_Interface_List); + Sem_Interface_Chain + (Get_Port_Chain (Component), Port_Interface_List); + + Close_Declarative_Region; + + Name_Visible (Component); + end Sem_Component_Declaration; + + procedure Sem_Object_Alias_Declaration (Alias: Iir_Object_Alias_Declaration) + is + N_Name: constant Iir := Get_Name (Alias); + N_Type: Iir; + Name_Type : Iir; + begin + -- LRM93 4.3.3.1 Object Aliases. + -- 1. A signature may not appear in a declaration of an object alias. + -- FIXME: todo. + -- + -- 2. The name must be a static name that denotes an object. + if Get_Name_Staticness (N_Name) < Globally then + Error_Msg_Sem ("aliased name must be a static name", Alias); + end if; + + -- LRM93 4.3.3.1 + -- The base type of the name specified in an alias declaration must be + -- the same as the base type of the type mark in the subtype indication + -- (if the subtype indication is present); + Name_Type := Get_Type (N_Name); + N_Type := Get_Subtype_Indication (Alias); + if N_Type = Null_Iir then + Set_Type (Alias, Name_Type); + N_Type := Name_Type; + else + -- FIXME: must be analyzed before calling Name_Visibility. + N_Type := Sem_Subtype_Indication (N_Type); + Set_Subtype_Indication (Alias, N_Type); + N_Type := Get_Type_Of_Subtype_Indication (N_Type); + if N_Type /= Null_Iir then + Set_Type (Alias, N_Type); + if Get_Base_Type (N_Type) /= Get_Base_Type (Name_Type) then + Error_Msg_Sem ("base type of aliased name and name mismatch", + Alias); + end if; + end if; + end if; + + -- LRM93 4.3.3.1 + -- This type must not be a multi-dimensional array type. + if Get_Kind (N_Type) in Iir_Kinds_Array_Type_Definition then + if not Is_One_Dimensional_Array_Type (N_Type) then + Error_Msg_Sem + ("aliased name must not be a multi-dimensional array type", + Alias); + end if; + if Get_Type_Staticness (N_Type) = Locally + and then Get_Type_Staticness (Name_Type) = Locally + and then Eval_Discrete_Type_Length + (Get_Nth_Element (Get_Index_Subtype_List (N_Type), 0)) + /= Eval_Discrete_Type_Length + (Get_Nth_Element (Get_Index_Subtype_List (Name_Type), 0)) + then + Error_Msg_Sem + ("number of elements not matching in type and name", Alias); + end if; + end if; + + Set_Name_Staticness (Alias, Get_Name_Staticness (N_Name)); + Set_Expr_Staticness (Alias, Get_Expr_Staticness (N_Name)); + if Is_Signal_Object (N_Name) then + Set_Type_Has_Signal (N_Type); + end if; + end Sem_Object_Alias_Declaration; + + function Signature_Match (N_Entity : Iir; Sig : Iir_Signature) + return Boolean + is + List : Iir_List; + Inter : Iir; + El : Iir; + begin + List := Get_Type_Marks_List (Sig); + case Get_Kind (N_Entity) is + when Iir_Kind_Enumeration_Literal => + -- LRM93 2.3.2 Signatures + -- * Similarly, a signature is said to match the parameter and + -- result type profile of a given enumeration literal if + -- the signature matches the parameter and result type profile + -- of the subprogram equivalent to the enumeration literal, + -- defined in Section 3.1.1 + return List = Null_Iir_List + and then Get_Type (N_Entity) + = Get_Type (Get_Return_Type_Mark (Sig)); + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration => + -- LRM93 2.3.2 Signatures + -- * if the reserved word RETURN is present, the subprogram is + -- a function and the base type of the type mark following + -- the reserved word in the signature is the same as the base + -- type of the return type of the function, [...] + if Get_Type (Get_Return_Type_Mark (Sig)) /= + Get_Base_Type (Get_Return_Type (N_Entity)) + then + return False; + end if; + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + -- LRM93 2.3.2 Signatures + -- * [...] or the reserved word RETURN is absent and the + -- subprogram is a procedure. + if Get_Return_Type_Mark (Sig) /= Null_Iir then + return False; + end if; + when others => + -- LRM93 2.3.2 Signatures + -- A signature distinguishes between overloaded subprograms and + -- overloaded enumeration literals based on their parameter + -- and result type profiles. + return False; + end case; + + -- LRM93 2.3.2 Signature + -- * the number of type marks prior the reserved word RETURN, if any, + -- matches the number of formal parameters of the subprogram; + -- * at each parameter position, the base type denoted by the type + -- mark of the signature is the same as the base type of the + -- corresponding formal parameter of the subprogram; [and finally, ] + Inter := Get_Interface_Declaration_Chain (N_Entity); + if List = Null_Iir_List then + return Inter = Null_Iir; + end if; + for I in Natural loop + El := Get_Nth_Element (List, I); + if El = Null_Iir and Inter = Null_Iir then + return True; + end if; + if El = Null_Iir or Inter = Null_Iir then + return False; + end if; + if Get_Base_Type (Get_Type (Inter)) /= Get_Type (El) then + return False; + end if; + Inter := Get_Chain (Inter); + end loop; + -- Avoid a spurious warning. + return False; + end Signature_Match; + + -- Extract from NAME the named entity whose profile matches with SIG. + function Sem_Signature (Name : Iir; Sig : Iir_Signature) return Iir + is + Res : Iir; + El : Iir; + List : Iir_List; + Error : Boolean; + begin + -- Sem signature. + List := Get_Type_Marks_List (Sig); + if List /= Null_Iir_List then + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El := Sem_Type_Mark (El); + Replace_Nth_Element (List, I, El); + + -- Reuse the Type field of the name for the base type. This is + -- a deviation from the use of Type in a name, but restricted to + -- analysis of signatures. + Set_Type (El, Get_Base_Type (Get_Type (El))); + end loop; + end if; + El := Get_Return_Type_Mark (Sig); + if El /= Null_Iir then + El := Sem_Type_Mark (El); + Set_Return_Type_Mark (Sig, El); + -- Likewise. + Set_Type (El, Get_Base_Type (Get_Type (El))); + end if; + + -- FIXME: what to do in case of error ? + Res := Null_Iir; + Error := False; + if Is_Overload_List (Name) then + for I in Natural loop + El := Get_Nth_Element (Get_Overload_List (Name), I); + exit when El = Null_Iir; + if Signature_Match (El, Sig) then + if Res = Null_Iir then + Res := El; + else + Error := True; + Error_Msg_Sem + ("cannot resolve signature, many matching subprograms:", + Sig); + Error_Msg_Sem ("found: " & Disp_Node (Res), Res); + end if; + if Error then + Error_Msg_Sem ("found: " & Disp_Node (El), El); + end if; + end if; + end loop; + + -- Free the overload list (with a workaround as only variables can + -- be free). + declare + Name_Ov : Iir; + begin + Name_Ov := Name; + Free_Overload_List (Name_Ov); + end; + else + if Signature_Match (Name, Sig) then + Res := Name; + end if; + end if; + + if Error then + return Null_Iir; + end if; + if Res = Null_Iir then + Error_Msg_Sem + ("cannot resolve signature, no matching subprogram", Sig); + end if; + + return Res; + end Sem_Signature; + + -- Create implicit aliases for an alias ALIAS of a type or of a subtype. + procedure Add_Aliases_For_Type_Alias (Alias : Iir) + is + N_Entity : constant Iir := Get_Named_Entity (Get_Name (Alias)); + Def : constant Iir := Get_Base_Type (Get_Type (N_Entity)); + Type_Decl : constant Iir := Get_Type_Declarator (Def); + Last : Iir; + El : Iir; + Enum_List : Iir_Enumeration_Literal_List; + + -- Append an implicit alias + procedure Add_Implicit_Alias (Decl : Iir) + is + N_Alias : constant Iir_Non_Object_Alias_Declaration := + Create_Iir (Iir_Kind_Non_Object_Alias_Declaration); + N_Name : constant Iir := Create_Iir (Iir_Kind_Simple_Name); + begin + -- Create the name (can be in fact a character literal or a symbol + -- operator). + Location_Copy (N_Name, Alias); + Set_Identifier (N_Name, Get_Identifier (Decl)); + Set_Named_Entity (N_Name, Decl); + + Location_Copy (N_Alias, Alias); + Set_Identifier (N_Alias, Get_Identifier (Decl)); + Set_Name (N_Alias, N_Name); + Set_Parent (N_Alias, Get_Parent (Alias)); + Set_Implicit_Alias_Flag (N_Alias, True); + + Sem_Scopes.Add_Name (N_Alias); + Set_Visible_Flag (N_Alias, True); + + -- Append in the declaration chain. + Set_Chain (N_Alias, Get_Chain (Last)); + Set_Chain (Last, N_Alias); + Last := N_Alias; + end Add_Implicit_Alias; + begin + Last := Alias; + + if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then + -- LRM93 4.3.3.2 Non-Object Aliases + -- 3. If the name denotes an enumeration type, then one + -- implicit alias declaration for each of the + -- literals of the type immediatly follows the alias + -- declaration for the enumeration type; [...] + -- + -- LRM08 6.6.3 Nonobject aliases + -- c) If the name denotes an enumeration type of a subtype of an + -- enumeration type, then one implicit alias declaration for each + -- of the litereals of the base type immediately follows the + -- alias declaration for the enumeration type; [...] + Enum_List := Get_Enumeration_Literal_List (Def); + for I in Natural loop + El := Get_Nth_Element (Enum_List, I); + exit when El = Null_Iir; + -- LRM93 4.3.3.2 Non-Object Aliases + -- [...] each such implicit declaration has, as its alias + -- designator, the simple name or character literal of the + -- literal, and has, as its name, a name constructed by taking + -- the name of the alias for the enumeration type and + -- substituting the simple name or character literal being + -- aliased for the simple name of the type. Each implicit + -- alias has a signature that matches the parameter and result + -- type profile of the literal being aliased. + -- + -- LRM08 6.6.3 Nonobject aliases + -- [...] each such implicit declaration has, as its alias + -- designator, the simple name or character literal of the + -- literal and has, as its name, a name constructed by taking + -- the name of the alias for the enumeration type or subtype + -- and substituing the simple name or character literal being + -- aliased for the simple name of the type or subtype. Each + -- implicit alias has a signature that matches the parameter + -- and result type profile of the literal being aliased. + Add_Implicit_Alias (El); + end loop; + end if; + + -- LRM93 4.3.3.2 Non-Object Aliases + -- 4. Alternatively, if the name denotes a physical type + -- [...] + -- GHDL: this is not possible, since a physical type is + -- anonymous (LRM93 is buggy on this point). + -- + -- LRM08 6.6.3 Nonobject aliases + -- d) Alternatively, if the name denotes a subtype of a physical type, + -- [...] + if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then + -- LRM08 6.3.3 Nonobject aliases + -- [...] then one implicit alias declaration for each of the + -- units of the base type immediately follows the alias + -- declaration for the physical type; each such implicit + -- declaration has, as its alias designator, the simple name of + -- the unit and has, as its name, a name constructed by taking + -- the name of the alias for the subtype of the physical type + -- and substituting the simple name of the unit being aliased for + -- the simple name of the subtype. + El := Get_Unit_Chain (Def); + while El /= Null_Iir loop + Add_Implicit_Alias (El); + El := Get_Chain (El); + end loop; + end if; + + -- LRM93 4.3.3.2 Non-Object Aliases + -- 5. Finally, if the name denotes a type, then implicit + -- alias declarations for each predefined operator + -- for the type immediatly follow the explicit alias + -- declaration for the type, and if present, any + -- implicit alias declarations for literals or units + -- of the type. + -- Each implicit alias has a signature that matches the + -- parameter and result type profule of the implicit + -- operator being aliased. + -- + -- LRM08 6.6.3 Nonobject aliases + -- e) Finally, if the name denotes a type of a subtype, then implicit + -- alias declarations for each predefined operation for the type + -- immediately follow the explicit alias declaration for the type or + -- subtype and, if present, any implicit alias declarations for + -- literals or units of the type. Each implicit alias has a + -- signature that matches the parameter and result type profile of + -- the implicit operation being aliased. + El := Get_Chain (Type_Decl); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + exit when Get_Type_Reference (El) /= Type_Decl; + when others => + exit; + end case; + Add_Implicit_Alias (El); + El := Get_Chain (El); + end loop; + end Add_Aliases_For_Type_Alias; + + procedure Sem_Non_Object_Alias_Declaration + (Alias : Iir_Non_Object_Alias_Declaration) + is + use Std_Names; + N_Entity : constant Iir := Get_Named_Entity (Get_Name (Alias)); + Id : Name_Id; + begin + case Get_Kind (N_Entity) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + -- LRM93 4.3.3.2 Non-Object Aliases + -- 2. A signature is required if the name denotes a subprogram + -- (including an operator) or enumeration literal. + if Get_Alias_Signature (Alias) = Null_Iir then + Error_Msg_Sem ("signature required for subprogram", Alias); + end if; + when Iir_Kind_Enumeration_Literal => + if Get_Alias_Signature (Alias) = Null_Iir then + Error_Msg_Sem ("signature required for enumeration literal", + Alias); + end if; + when Iir_Kind_Type_Declaration => + Add_Aliases_For_Type_Alias (Alias); + when Iir_Kind_Subtype_Declaration => + -- LRM08 6.6.3 Nonobject aliases + -- ... or a subtype ... + if Flags.Vhdl_Std >= Vhdl_08 then + Add_Aliases_For_Type_Alias (Alias); + end if; + when Iir_Kinds_Object_Declaration => + raise Internal_Error; + when Iir_Kind_Attribute_Declaration + | Iir_Kind_Component_Declaration => + null; + when Iir_Kind_Terminal_Declaration => + null; + when others => + Error_Kind ("sem_non_object_alias_declaration", N_Entity); + end case; + + Id := Get_Identifier (Alias); + + case Id is + when Name_Characters => + -- LRM 4.3.3 Alias declarations + -- If the alias designator is a character literal, the + -- name must denote an enumeration literal. + if Get_Kind (N_Entity) /= Iir_Kind_Enumeration_Literal then + Error_Msg_Sem + ("alias of a character must denote an enumeration literal", + Alias); + return; + end if; + when Name_Id_Operators + | Name_Shift_Operators + | Name_Word_Operators => + -- LRM 4.3.3 Alias declarations + -- If the alias designator is an operator symbol, the + -- name must denote a function, and that function then + -- overloads the operator symbol. In this latter case, + -- the operator symbol and the function both must meet the + -- requirements of 2.3.1. + if Get_Kind (N_Entity) not in Iir_Kinds_Function_Declaration then + Error_Msg_Sem + ("alias of an operator must denote a function", Alias); + return; + end if; + Check_Operator_Requirements (Id, N_Entity); + when others => + null; + end case; + end Sem_Non_Object_Alias_Declaration; + + function Sem_Alias_Declaration (Alias : Iir) return Iir + is + use Std_Names; + Name : Iir; + Sig : Iir_Signature; + N_Entity : Iir; + Res : Iir; + begin + Xref_Decl (Alias); + + Name := Get_Name (Alias); + if Get_Kind (Name) = Iir_Kind_Signature then + Sig := Name; + Name := Get_Signature_Prefix (Sig); + Sem_Name (Name); + Set_Signature_Prefix (Sig, Name); + else + Sem_Name (Name); + Sig := Null_Iir; + end if; + + N_Entity := Get_Named_Entity (Name); + if N_Entity = Error_Mark then + return Alias; + end if; + + if Is_Overload_List (N_Entity) then + if Sig = Null_Iir then + Error_Msg_Sem + ("signature required for alias of a subprogram", Alias); + return Alias; + end if; + end if; + + if Sig /= Null_Iir then + N_Entity := Sem_Signature (N_Entity, Sig); + end if; + if N_Entity = Null_Iir then + return Alias; + end if; + + Set_Named_Entity (Name, N_Entity); + Set_Name (Alias, Finish_Sem_Name (Name)); + + if Is_Object_Name (N_Entity) then + -- Object alias declaration. + + Sem_Scopes.Add_Name (Alias); + Name_Visible (Alias); + + if Sig /= Null_Iir then + Error_Msg_Sem ("signature not allowed for object alias", Sig); + end if; + Sem_Object_Alias_Declaration (Alias); + return Alias; + else + -- Non object alias declaration. + + if Get_Type (Alias) /= Null_Iir then + Error_Msg_Sem + ("subtype indication not allowed for non-object alias", Alias); + end if; + if Get_Subtype_Indication (Alias) /= Null_Iir then + Error_Msg_Sem + ("subtype indication shall not appear in a nonobject alias", + Alias); + end if; + + Res := Create_Iir (Iir_Kind_Non_Object_Alias_Declaration); + Location_Copy (Res, Alias); + Set_Parent (Res, Get_Parent (Alias)); + Set_Chain (Res, Get_Chain (Alias)); + Set_Identifier (Res, Get_Identifier (Alias)); + Set_Name (Res, Name); + Set_Alias_Signature (Res, Sig); + + Sem_Scopes.Add_Name (Res); + Name_Visible (Res); + + Free_Iir (Alias); + + Sem_Non_Object_Alias_Declaration (Res); + return Res; + end if; + end Sem_Alias_Declaration; + + procedure Sem_Group_Template_Declaration + (Decl : Iir_Group_Template_Declaration) + is + begin + Sem_Scopes.Add_Name (Decl); + Sem_Scopes.Name_Visible (Decl); + Xref_Decl (Decl); + end Sem_Group_Template_Declaration; + + procedure Sem_Group_Declaration (Group : Iir_Group_Declaration) + is + use Tokens; + + Constituent_List : Iir_Group_Constituent_List; + Template : Iir_Group_Template_Declaration; + Template_Name : Iir; + Class, Prev_Class : Token_Type; + El : Iir; + El_Name : Iir; + El_Entity : Iir_Entity_Class; + begin + Sem_Scopes.Add_Name (Group); + Xref_Decl (Group); + + Template_Name := Sem_Denoting_Name (Get_Group_Template_Name (Group)); + Set_Group_Template_Name (Group, Template_Name); + Template := Get_Named_Entity (Template_Name); + if Get_Kind (Template) /= Iir_Kind_Group_Template_Declaration then + Error_Class_Match (Template_Name, "group template"); + return; + end if; + Constituent_List := Get_Group_Constituent_List (Group); + El_Entity := Get_Entity_Class_Entry_Chain (Template); + Prev_Class := Tok_Eof; + for I in Natural loop + El := Get_Nth_Element (Constituent_List, I); + exit when El = Null_Iir; + + Sem_Name (El); + + if El_Entity = Null_Iir then + Error_Msg_Sem + ("too many elements in group constituent list", Group); + exit; + end if; + + Class := Get_Entity_Class (El_Entity); + if Class = Tok_Box then + -- LRM93 4.6 + -- An entity class entry that includes a box (<>) allows zero + -- or more group constituents to appear in this position in the + -- corresponding group declaration. + Class := Prev_Class; + else + Prev_Class := Class; + El_Entity := Get_Chain (El_Entity); + end if; + + El_Name := Get_Named_Entity (El); + if Is_Error (El_Name) then + null; + elsif Is_Overload_List (El_Name) then + Error_Overload (El_Name); + else + El := Finish_Sem_Name (El); + Replace_Nth_Element (Constituent_List, I, El); + El_Name := Get_Named_Entity (El); + + -- LRM93 4.7 + -- It is an error if the class of any group constituent in the + -- group constituent list is not the same as the class specified + -- by the corresponding entity class entry in the entity class + -- entry list of the group template. + if Get_Entity_Class_Kind (El_Name) /= Class then + Error_Msg_Sem + ("constituent not of class '" & Tokens.Image (Class) & ''', + El); + end if; + end if; + end loop; + + -- End of entity_class list reached or zero or more constituent allowed. + if not (El_Entity = Null_Iir + or else Get_Entity_Class (El_Entity) = Tok_Box) + then + Error_Msg_Sem + ("not enough elements in group constituent list", Group); + end if; + Set_Visible_Flag (Group, True); + end Sem_Group_Declaration; + + function Sem_Scalar_Nature_Definition (Def : Iir; Decl : Iir) return Iir + is + function Sem_Scalar_Nature_Typemark (T : Iir; Name : String) return Iir + is + Res : Iir; + begin + Res := Sem_Type_Mark (T); + Res := Get_Type (Res); + if Is_Error (Res) then + return Real_Type_Definition; + end if; + -- LRM93 3.5.1 + -- The type marks must denote floating point types + case Get_Kind (Res) is + when Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition => + return Res; + when others => + Error_Msg_Sem (Name & "type must be a floating point type", T); + return Real_Type_Definition; + end case; + end Sem_Scalar_Nature_Typemark; + + Tm : Iir; + Ref : Iir; + begin + Tm := Get_Across_Type (Def); + Tm := Sem_Scalar_Nature_Typemark (Tm, "across"); + Set_Across_Type (Def, Tm); + + Tm := Get_Through_Type (Def); + Tm := Sem_Scalar_Nature_Typemark (Tm, "through"); + Set_Through_Type (Def, Tm); + + -- Declare the reference + Ref := Get_Reference (Def); + Set_Nature (Ref, Def); + Set_Chain (Ref, Get_Chain (Decl)); + Set_Chain (Decl, Ref); + + return Def; + end Sem_Scalar_Nature_Definition; + + function Sem_Nature_Definition (Def : Iir; Decl : Iir) return Iir + is + begin + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + return Sem_Scalar_Nature_Definition (Def, Decl); + when others => + Error_Kind ("sem_nature_definition", Def); + return Null_Iir; + end case; + end Sem_Nature_Definition; + + procedure Sem_Nature_Declaration (Decl : Iir) + is + Def : Iir; + begin + Def := Get_Nature (Decl); + if Def /= Null_Iir then + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + Def := Sem_Nature_Definition (Def, Decl); + if Def /= Null_Iir then + Set_Nature_Declarator (Def, Decl); + Sem_Scopes.Name_Visible (Decl); + end if; + end if; + end Sem_Nature_Declaration; + + procedure Sem_Terminal_Declaration (Decl : Iir; Last_Decl : Iir) + is + Def, Nature : Iir; + begin + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + Def := Get_Nature (Decl); + + if Def = Null_Iir then + Nature := Get_Nature (Last_Decl); + else + Nature := Sem_Subnature_Indication (Def); + end if; + + if Nature /= Null_Iir then + Set_Nature (Decl, Nature); + Sem_Scopes.Name_Visible (Decl); + end if; + end Sem_Terminal_Declaration; + + procedure Sem_Branch_Quantity_Declaration (Decl : Iir; Last_Decl : Iir) + is + Plus_Name : Iir; + Minus_Name : Iir; + Branch_Type : Iir; + Value : Iir; + Is_Second : Boolean; + begin + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + Plus_Name := Get_Plus_Terminal (Decl); + if Plus_Name = Null_Iir then + -- List of identifier. + Is_Second := True; + Plus_Name := Get_Plus_Terminal (Last_Decl); + Minus_Name := Get_Minus_Terminal (Last_Decl); + Value := Get_Default_Value (Last_Decl); + else + Is_Second := False; + Plus_Name := Sem_Terminal_Name (Plus_Name); + Minus_Name := Get_Minus_Terminal (Decl); + if Minus_Name /= Null_Iir then + Minus_Name := Sem_Terminal_Name (Minus_Name); + end if; + Value := Get_Default_Value (Decl); + end if; + Set_Plus_Terminal (Decl, Plus_Name); + Set_Minus_Terminal (Decl, Minus_Name); + case Get_Kind (Decl) is + when Iir_Kind_Across_Quantity_Declaration => + Branch_Type := Get_Across_Type (Get_Nature (Plus_Name)); + when Iir_Kind_Through_Quantity_Declaration => + Branch_Type := Get_Through_Type (Get_Nature (Plus_Name)); + when others => + raise Program_Error; + end case; + Set_Type (Decl, Branch_Type); + + if not Is_Second and then Value /= Null_Iir then + Value := Sem_Expression (Value, Branch_Type); + end if; + Set_Default_Value (Decl, Value); + + -- TODO: tolerance + + Sem_Scopes.Name_Visible (Decl); + end Sem_Branch_Quantity_Declaration; + + procedure Sem_Declaration_Chain (Parent : Iir) + is + Decl: Iir; + Last_Decl : Iir; + Attr_Spec_Chain : Iir; + + -- Used for list of identifiers in object declarations to get the type + -- and default value for the following declarations. + Last_Obj_Decl : Iir; + + -- If IS_GLOBAL is set, then declarations may be seen outside of unit. + -- This must be set for entities and packages (except when + -- Flags.Flag_Whole_Analyze is set). + Is_Global : Boolean; + begin + case Get_Kind (Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration => + Is_Global := not Flags.Flag_Whole_Analyze; + when others => + Is_Global := False; + end case; + + -- Due to implicit declarations, the list can grow during sem. + Decl := Get_Declaration_Chain (Parent); + Last_Decl := Null_Iir; + Attr_Spec_Chain := Null_Iir; + Last_Obj_Decl := Null_Iir; + + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Sem_Type_Declaration (Decl, Is_Global); + when Iir_Kind_Subtype_Declaration => + Sem_Subtype_Declaration (Decl, Is_Global); + when Iir_Kind_Signal_Declaration => + Sem_Object_Declaration (Decl, Parent, Last_Obj_Decl); + Last_Obj_Decl := Decl; + when Iir_Kind_Constant_Declaration => + Sem_Object_Declaration (Decl, Parent, Last_Obj_Decl); + Last_Obj_Decl := Decl; + when Iir_Kind_Variable_Declaration => + Sem_Object_Declaration (Decl, Parent, Last_Obj_Decl); + Last_Obj_Decl := Decl; + when Iir_Kind_File_Declaration => + Sem_File_Declaration (Decl, Last_Obj_Decl); + Last_Obj_Decl := Decl; + when Iir_Kind_Attribute_Declaration => + Sem_Attribute_Declaration (Decl); + when Iir_Kind_Attribute_Specification => + Sem_Attribute_Specification (Decl, Parent); + if Get_Entity_Name_List (Decl) in Iir_Lists_All_Others then + Set_Attribute_Specification_Chain (Decl, Attr_Spec_Chain); + Attr_Spec_Chain := Decl; + end if; + when Iir_Kind_Component_Declaration => + Sem_Component_Declaration (Decl); + when Iir_Kind_Function_Declaration => + Sem_Subprogram_Declaration (Decl); + if Is_Global + and then Is_A_Resolution_Function (Decl, Null_Iir) + then + Set_Resolution_Function_Flag (Decl, True); + end if; + when Iir_Kind_Procedure_Declaration => + Sem_Subprogram_Declaration (Decl); + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Sem_Subprogram_Body (Decl); + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + Sem_Scopes.Add_Name (Decl); + -- Implicit subprogram are already visible. + when Iir_Kind_Non_Object_Alias_Declaration => + -- Added by Sem_Alias_Declaration. Need to check that no + -- existing attribute specification apply to them. + null; + when Iir_Kind_Object_Alias_Declaration => + declare + Res : Iir; + begin + Res := Sem_Alias_Declaration (Decl); + if Res /= Decl then + -- Replace DECL with RES. + if Last_Decl = Null_Iir then + Set_Declaration_Chain (Parent, Res); + else + Set_Chain (Last_Decl, Res); + end if; + Decl := Res; + + -- An alias may add new alias declarations. Do not skip + -- them: check that no existing attribute specifications + -- apply to them. + end if; + end; + when Iir_Kind_Use_Clause => + Sem_Use_Clause (Decl); + when Iir_Kind_Configuration_Specification => + null; + when Iir_Kind_Disconnection_Specification => + Sem_Disconnection_Specification (Decl); + when Iir_Kind_Group_Template_Declaration => + Sem_Group_Template_Declaration (Decl); + when Iir_Kind_Group_Declaration => + Sem_Group_Declaration (Decl); + when Iir_Kinds_Signal_Attribute => + -- Added by sem, so nothing to do. + null; + when Iir_Kind_Protected_Type_Body => + Sem_Protected_Type_Body (Decl); + when Iir_Kind_Nature_Declaration => + Sem_Nature_Declaration (Decl); + when Iir_Kind_Terminal_Declaration => + Sem_Terminal_Declaration (Decl, Last_Obj_Decl); + Last_Obj_Decl := Decl; + when Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + Sem_Branch_Quantity_Declaration (Decl, Last_Obj_Decl); + Last_Obj_Decl := Decl; + when others => + Error_Kind ("sem_declaration_chain", Decl); + end case; + if Attr_Spec_Chain /= Null_Iir then + Check_Post_Attribute_Specification (Attr_Spec_Chain, Decl); + end if; + Last_Decl := Decl; + Decl := Get_Chain (Decl); + end loop; + end Sem_Declaration_Chain; + + procedure Check_Full_Declaration (Decls_Parent : Iir; Decl: Iir) + is + El: Iir; + + -- If set, emit a warning if a declaration is not used. + Check_Unused : Boolean; + begin + -- LRM 3.5 Protected types. + -- Each protected type declaration appearing immediatly within a given + -- declaration region must have exactly one corresponding protected type + -- body appearing immediatly within the same declarative region and + -- textually subsequent to the protected type declaration. + + -- LRM 3.3.1 Incomplete type declarations + -- For each incomplete type declaration, there must be a corresponding + -- full type declaration with the same identifier. This full type + -- declaration must occur later and immediatly within the same + -- declarative part as the incomplete type declaration to which it + -- correspinds. + + -- LRM 4.3.1.1 Constant declarations + -- If the assignment symbol ":=" followed by an expression is not + -- present in a constant declaration, then the declaration declares a + -- deferred constant. Such a constant declaration must appear in a + -- package declaration. The corresponding full constant declaration, + -- which defines the value of the constant, must appear in the body of + -- the package (see 2.6). + + -- LRM 2.2 Subprogram bodies + -- If both a declaration and a body are given, [...]. Furthermore, + -- both the declaration and the body must occur immediatly within the + -- same declaration region. + + -- Set Check_Unused. + Check_Unused := False; + if Flags.Warn_Unused then + case Get_Kind (Decl) is + when Iir_Kind_Entity_Declaration => + -- May be used in architecture. + null; + when Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + -- Might be used in a configuration. + -- FIXME: create a second level of warning. + null; + when Iir_Kind_Package_Body + | Iir_Kind_Protected_Type_Body => + -- Check only for declarations of the body. + if Decls_Parent = Decl then + Check_Unused := True; + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Check_Unused := True; + when others => + -- Note: Check_Full_Declaration is not called + -- for package declarations or protected type declarations. + Error_Kind ("check_full_declaration", Decl); + end case; + end if; + + El := Get_Declaration_Chain (Decls_Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Constant_Declaration => + if Get_Deferred_Declaration_Flag (El) then + if Get_Deferred_Declaration (El) = Null_Iir then + Error_Msg_Sem ("missing value for constant declared at " + & Disp_Location (El), Decl); + else + -- Remove from visibility the full declaration of the + -- constant. + -- FIXME: this is not a check! + Set_Deferred_Declaration (El, Null_Iir); + end if; + end if; + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if Get_Subprogram_Body (El) = Null_Iir then + Error_Msg_Sem ("missing body for " & Disp_Node (El) + & " declared at " + & Disp_Location (El), Decl); + end if; + when Iir_Kind_Type_Declaration => + declare + Def : Iir; + begin + Def := Get_Type_Definition (El); + if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition + and then Get_Type_Declarator (Def) = El + then + Error_Msg_Sem ("missing full type declaration for " + & Disp_Node (El), El); + elsif Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration + and then Get_Protected_Type_Body (Def) = Null_Iir + then + Error_Msg_Sem ("missing protected type body for " + & Disp_Node (El), El); + end if; + end; + when others => + null; + end case; + + if Check_Unused then + -- All subprograms declared in the specification (package or + -- protected type) have only their *body* in the body. + -- Therefore, they don't appear as declaration in body. + -- Only private subprograms appears as declarations. + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if not Get_Use_Flag (El) + and then not Is_Second_Subprogram_Specification (El) + then + Warning_Msg_Sem + (Disp_Node (El) & " is never referenced", El); + end if; + when others => + null; + end case; + end if; + + El := Get_Chain (El); + end loop; + end Check_Full_Declaration; + + procedure Sem_Iterator (Iterator : Iir_Iterator_Declaration; + Staticness : Iir_Staticness) + is + It_Range: constant Iir := Get_Discrete_Range (Iterator); + It_Type : Iir; + A_Range: Iir; + begin + Xref_Decl (Iterator); + + A_Range := Sem_Discrete_Range_Integer (It_Range); + if A_Range = Null_Iir then + Set_Type (Iterator, Create_Error_Type (It_Range)); + return; + end if; + + Set_Discrete_Range (Iterator, A_Range); + + It_Type := Range_To_Subtype_Indication (A_Range); + Set_Subtype_Indication (Iterator, It_Type); + Set_Type (Iterator, Get_Type_Of_Subtype_Indication (It_Type)); + + Set_Expr_Staticness (Iterator, Staticness); + end Sem_Iterator; +end Sem_Decls; diff --git a/src/vhdl/sem_decls.ads b/src/vhdl/sem_decls.ads new file mode 100644 index 000000000..7a8e24042 --- /dev/null +++ b/src/vhdl/sem_decls.ads @@ -0,0 +1,52 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +package Sem_Decls is + procedure Sem_Interface_Chain (Interface_Chain: Iir; + Interface_Kind : Interface_Kind_Type); + + -- Create predefined operations for DECL. + procedure Create_Implicit_Operations + (Decl : Iir; Is_Std_Standard : Boolean := False); + + -- Semantize declarations of PARENT. + procedure Sem_Declaration_Chain (Parent : Iir); + + -- Check all declarations of DECLS_PARENT are complete + -- This checks subprograms, deferred constants, incomplete types and + -- protected types. + -- + -- DECL is the declaration that contains the declaration_list DECLS_PARENT. + -- (location of errors). + -- DECL is different from DECLS_PARENT for package bodies and protected + -- type bodies. + -- + -- Also, report unused declarations if DECL = DECLS_PARENT. + -- As a consequence, Check_Full_Declaration must be called after sem + -- of statements, if any. + procedure Check_Full_Declaration (Decls_Parent : Iir; Decl: Iir); + + procedure Sem_Iterator (Iterator : Iir_Iterator_Declaration; + Staticness : Iir_Staticness); + + -- Extract from NAME the named entity whose profile matches SIG. If NAME + -- is an overload list, it is destroyed. + function Sem_Signature (Name : Iir; Sig : Iir_Signature) return Iir; + +end Sem_Decls; diff --git a/src/vhdl/sem_expr.adb b/src/vhdl/sem_expr.adb new file mode 100644 index 000000000..f7af76c09 --- /dev/null +++ b/src/vhdl/sem_expr.adb @@ -0,0 +1,4262 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Std_Package; use Std_Package; +with Errorout; use Errorout; +with Flags; use Flags; +with Sem_Scopes; use Sem_Scopes; +with Sem_Names; use Sem_Names; +with Sem; +with Name_Table; +with Iirs_Utils; use Iirs_Utils; +with Evaluation; use Evaluation; +with Iir_Chains; use Iir_Chains; +with Sem_Types; +with Sem_Stmts; use Sem_Stmts; +with Sem_Assocs; use Sem_Assocs; +with Xrefs; use Xrefs; + +package body Sem_Expr is + procedure Not_Match (Expr: Iir; A_Type: Iir) + is + pragma Inline (Not_Match); + begin + Error_Not_Match (Expr, A_Type, Expr); + end Not_Match; + +-- procedure Not_Match (Expr: Iir; Type1: Iir; Type2: Iir) is +-- begin +-- Error_Msg_Sem +-- ("can't match '" & Disp_Node (Expr) & "' with type '" +-- & Disp_Node (Type1) & "' or type '" & Disp_Node (Type2) & "'", +-- Expr); +-- end Not_Match; + +-- procedure Overloaded (Expr: Iir) is +-- begin +-- Error_Msg_Sem +-- ("cant resolve overloaded identifier '" & Get_String (Expr) & "'", +-- Expr); +-- end Overloaded; + + -- Replace type of TARGET by A_TYPE. + -- If TARGET has already a type, it must be an overload list, and in this + -- case, this list is freed, or it must be A_TYPE. + -- A_TYPE can't be an overload list. + -- + -- This procedure can be called in the second pass, when the type is known. + procedure Replace_Type (Target: Iir; A_Type: Iir) is + Old_Type: Iir; + begin + Old_Type := Get_Type (Target); + if Old_Type /= Null_Iir then + if Is_Overload_List (Old_Type) then + Free_Iir (Old_Type); + elsif Old_Type = A_Type then + return; + else + -- Cannot replace a type. + raise Internal_Error; + end if; + end if; + if A_Type = Null_Iir then + return; + end if; + if Is_Overload_List (A_Type) then + raise Internal_Error; + end if; + Set_Type (Target, A_Type); + end Replace_Type; + + -- Return true if EXPR is overloaded, ie has several meanings. + function Is_Overloaded (Expr : Iir) return Boolean + is + Expr_Type : constant Iir := Get_Type (Expr); + begin + return Expr_Type = Null_Iir or else Is_Overload_List (Expr_Type); + end Is_Overloaded; + + -- Return the common type of base types LEFT and RIGHT. + -- LEFT are RIGHT must be really base types (not subtypes). + -- Roughly speaking, it returns LEFT (= RIGHT) if LEFT = RIGHT (ie, same + -- type), null otherwise. + -- However, it handles implicite conversions of universal types. + function Get_Common_Basetype (Left: Iir; Right: Iir) + return Iir is + begin + if Left = Right then + return Left; + end if; + case Get_Kind (Left) is + when Iir_Kind_Integer_Type_Definition => + if Right = Convertible_Integer_Type_Definition then + return Left; + elsif Left = Convertible_Integer_Type_Definition + and then Get_Kind (Right) = Iir_Kind_Integer_Type_Definition + then + return Right; + end if; + when Iir_Kind_Floating_Type_Definition => + if Right = Convertible_Real_Type_Definition then + return Left; + elsif Left = Convertible_Real_Type_Definition + and then Get_Kind (Right) = Iir_Kind_Floating_Type_Definition + then + return Right; + end if; + when others => + null; + end case; + return Null_Iir; + end Get_Common_Basetype; + + -- LEFT are RIGHT must be really a type (not a subtype). + function Are_Basetypes_Compatible (Left: Iir; Right: Iir) + return Boolean is + begin + return Get_Common_Basetype (Left, Right) /= Null_Iir; + end Are_Basetypes_Compatible; + + function Are_Types_Compatible (Left: Iir; Right: Iir) + return Boolean is + begin + return Get_Common_Basetype (Get_Base_Type (Left), + Get_Base_Type (Right)) /= Null_Iir; + end Are_Types_Compatible; + + function Are_Nodes_Compatible (Left: Iir; Right: Iir) + return Boolean is + begin + return Are_Types_Compatible (Get_Type (Left), Get_Type (Right)); + end Are_Nodes_Compatible; + + -- Return TRUE iif LEFT_TYPE and RIGHT_TYPES are compatible. RIGHT_TYPES + -- may be an overload list. + function Compatibility_Types1 (Left_Type : Iir; Right_Types : Iir) + return Boolean + is + El : Iir; + Right_List : Iir_List; + begin + pragma Assert (not Is_Overload_List (Left_Type)); + + if Is_Overload_List (Right_Types) then + Right_List := Get_Overload_List (Right_Types); + for I in Natural loop + El := Get_Nth_Element (Right_List, I); + exit when El = Null_Iir; + if Are_Types_Compatible (Left_Type, El) then + return True; + end if; + end loop; + return False; + else + return Are_Types_Compatible (Left_Type, Right_Types); + end if; + end Compatibility_Types1; + + -- Return compatibility for nodes LEFT and RIGHT. + -- LEFT is expected to be an interface of a function definition. + -- Type of RIGHT can be an overload_list + -- RIGHT might be implicitly converted to LEFT. + function Compatibility_Nodes (Left : Iir; Right : Iir) + return Boolean + is + Left_Type, Right_Type : Iir; + begin + Left_Type := Get_Base_Type (Get_Type (Left)); + Right_Type := Get_Type (Right); + + -- Check. + case Get_Kind (Left_Type) is + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Array_Type_Definition => + null; + when others => + Error_Kind ("are_node_compatible_ov", Left_Type); + end case; + + return Compatibility_Types1 (Left_Type, Right_Type); + end Compatibility_Nodes; + + -- Return TRUE iff A_TYPE can be the type of string or bit string literal + -- EXPR. EXPR is needed to distinguish between string and bit string + -- for VHDL87 rule about the type of a bit string. + function Is_String_Literal_Type (A_Type : Iir; Expr : Iir) return Boolean + is + Base_Type : constant Iir := Get_Base_Type (A_Type); + El_Bt : Iir; + begin + -- LRM 7.3.1 + -- [...] the type of the literal must be a one-dimensional array ... + if not Is_One_Dimensional_Array_Type (Base_Type) then + return False; + end if; + -- LRM 7.3.1 + -- ... of a character type ... + El_Bt := Get_Base_Type (Get_Element_Subtype (Base_Type)); + if Get_Kind (El_Bt) /= Iir_Kind_Enumeration_Type_Definition then + return False; + end if; + -- LRM87 7.3.1 + -- ... (for string literals) or of type BIT (for bit string literals). + if Flags.Vhdl_Std = Vhdl_87 + and then Get_Kind (Expr) = Iir_Kind_Bit_String_Literal + and then El_Bt /= Bit_Type_Definition + then + return False; + end if; + return True; + end Is_String_Literal_Type; + + -- Return TRUE iff A_TYPE can be the type of an aggregate. + function Is_Aggregate_Type (A_Type : Iir) return Boolean is + begin + -- LRM 7.3.2 Aggregates + -- [...] the type of the aggregate must be a composite type. + case Get_Kind (Get_Base_Type (A_Type)) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Record_Type_Definition => + return True; + when others => + return False; + end case; + end Is_Aggregate_Type; + + -- Return TRUE iff A_TYPE can be the type of a null literal. + function Is_Null_Literal_Type (A_Type : Iir) return Boolean is + begin + -- LRM 7.3.1 Literals + -- The literal NULL represents the null access value for any access + -- type. + return + Get_Kind (Get_Base_Type (A_Type)) = Iir_Kind_Access_Type_Definition; + end Is_Null_Literal_Type; + + -- Return TRUE iff A_TYPE can be the type of allocator EXPR. Note that + -- the allocator must have been analyzed. + function Is_Allocator_Type (A_Type : Iir; Expr : Iir) return Boolean + is + Base_Type : constant Iir := Get_Base_Type (A_Type); + Designated_Type : Iir; + begin + -- LRM 7.3.6 Allocators + -- [...] the value returned is of an access type having the named + -- designated type. + + if Get_Kind (Base_Type) /= Iir_Kind_Access_Type_Definition then + return False; + end if; + Designated_Type := Get_Allocator_Designated_Type (Expr); + pragma Assert (Designated_Type /= Null_Iir); + -- Cheat: there is no allocators on universal types. + return Get_Base_Type (Get_Designated_Type (Base_Type)) + = Get_Base_Type (Designated_Type); + end Is_Allocator_Type; + + -- Return TRUE iff the type of EXPR is compatible with A_TYPE + function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) return Boolean + is + Expr_Type : constant Iir := Get_Type (Expr); + begin + if Expr_Type /= Null_Iir then + return Compatibility_Types1 (A_Type, Expr_Type); + end if; + + case Get_Kind (Expr) is + when Iir_Kind_Aggregate => + return Is_Aggregate_Type (A_Type); + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + return Is_String_Literal_Type (A_Type, Expr); + when Iir_Kind_Null_Literal => + return Is_Null_Literal_Type (A_Type); + when Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype => + return Is_Allocator_Type (A_Type, Expr); + when Iir_Kind_Parenthesis_Expression => + return Is_Expr_Compatible (A_Type, Get_Expression (Expr)); + when others => + -- Error while EXPR was typed. FIXME: should create an ERROR + -- node? + return False; + end case; + end Is_Expr_Compatible; + + function Check_Is_Expression (Expr : Iir; Loc : Iir) return Iir + is + begin + if Expr = Null_Iir then + return Null_Iir; + end if; + case Get_Kind (Expr) is + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kinds_Subtype_Definition + | Iir_Kind_Design_Unit + | Iir_Kind_Architecture_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement + | Iir_Kind_Library_Declaration + | Iir_Kind_Library_Clause + | Iir_Kind_Component_Declaration + | Iir_Kinds_Procedure_Declaration + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Element_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Psl_Declaration => + Error_Msg_Sem (Disp_Node (Expr) + & " not allowed in an expression", Loc); + return Null_Iir; + when Iir_Kinds_Function_Declaration => + return Expr; + when Iir_Kind_Overload_List => + return Expr; + when Iir_Kinds_Literal + | Iir_Kind_Character_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Unit_Declaration + | Iir_Kind_Enumeration_Literal => + return Expr; + when Iir_Kinds_Object_Declaration + | Iir_Kind_Aggregate + | Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype + | Iir_Kind_Qualified_Expression => + return Expr; + when Iir_Kinds_Quantity_Declaration => + return Expr; + when Iir_Kinds_Dyadic_Operator + | Iir_Kinds_Monadic_Operator => + return Expr; + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kinds_Expression_Attribute + | Iir_Kind_Attribute_Value + | Iir_Kind_Parenthesis_Expression + | Iir_Kind_Type_Conversion + | Iir_Kind_Function_Call => + return Expr; + when Iir_Kind_Simple_Name + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Attribute_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Selected_By_All_Name => + return Expr; + when Iir_Kind_Error => + return Expr; + when others => + Error_Kind ("check_is_expression", Expr); + --N := Get_Type (Expr); + --return Expr; + end case; + end Check_Is_Expression; + + function Check_Implicit_Conversion (Targ_Type : Iir; Expr : Iir) + return Boolean + is + Expr_Type : Iir; + Targ_Indexes : Iir_List; + Expr_Indexes : Iir_List; + Targ_Index : Iir; + Expr_Index : Iir; + begin + -- Handle errors. + 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 + 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; + Targ_Indexes := Get_Index_Subtype_List (Targ_Type); + Expr_Indexes := Get_Index_Subtype_List (Expr_Type); + for I in Natural loop + Targ_Index := Get_Index_Type (Targ_Indexes, I); + Expr_Index := Get_Index_Type (Expr_Indexes, I); + exit when Targ_Index = Null_Iir and Expr_Index = Null_Iir; + if Targ_Index = Null_Iir or Expr_Index = Null_Iir then + -- Types does not match. + raise Internal_Error; + end if; + if Get_Type_Staticness (Targ_Index) = Locally + and then Get_Type_Staticness (Expr_Index) = Locally + then + if Eval_Discrete_Type_Length (Targ_Index) + /= Eval_Discrete_Type_Length (Expr_Index) + then + return False; + end if; + end if; + end loop; + return True; + end Check_Implicit_Conversion; + + -- Find a type compatible with A_TYPE in TYPE_LIST (which can be an + -- overload list or a simple type) and return it. + -- In case of failure, return null. + function Search_Overloaded_Type (Type_List: Iir; A_Type: Iir) + return Iir + is + Type_List_List : Iir_List; + El: Iir; + Com : Iir; + Res : Iir; + begin + if not Is_Overload_List (Type_List) then + return Get_Common_Basetype (Get_Base_Type (Type_List), + Get_Base_Type (A_Type)); + else + Type_List_List := Get_Overload_List (Type_List); + Res := Null_Iir; + for I in Natural loop + El := Get_Nth_Element (Type_List_List, I); + exit when El = Null_Iir; + Com := Get_Common_Basetype (Get_Base_Type (El), + Get_Base_Type (A_Type)); + if Com /= Null_Iir then + if Res = Null_Iir then + Res := Com; + else + -- Several compatible types. + return Null_Iir; + end if; + end if; + end loop; + return Res; + end if; + end Search_Overloaded_Type; + + -- LIST1, LIST2 are either a type node or an overload list of types. + -- Return THE type which is compatible with LIST1 are LIST2. + -- Return null_iir if there is no such type or if there are several types. + function Search_Compatible_Type (List1, List2 : Iir) return Iir + is + List1_List : Iir_List; + Res : Iir; + El : Iir; + Tmp : Iir; + begin + if Is_Overload_List (List1) then + List1_List := Get_Overload_List (List1); + Res := Null_Iir; + for I in Natural loop + El := Get_Nth_Element (List1_List, I); + exit when El = Null_Iir; + Tmp := Search_Overloaded_Type (List2, El); + if Tmp /= Null_Iir then + if Res = Null_Iir then + Res := Tmp; + else + -- Several types match. + return Null_Iir; + end if; + end if; + end loop; + return Res; + else + return Search_Overloaded_Type (List2, List1); + end if; + end Search_Compatible_Type; + + -- Semantize the range expression EXPR. + -- If A_TYPE is not null_iir, EXPR is expected to be of type A_TYPE. + -- LRM93 3.2.1.1 + -- FIXME: avoid to run it on an already semantized node, be careful + -- with range_type_expr. + function Sem_Simple_Range_Expression + (Expr: Iir_Range_Expression; A_Type: Iir; Any_Dir : Boolean) + return Iir_Range_Expression + is + Base_Type: Iir; + Left, Right: Iir; + Left_Type, Right_Type : Iir; + Expr_Type : Iir; + begin + Expr_Type := Get_Type (Expr); + Left := Get_Left_Limit (Expr); + Right := Get_Right_Limit (Expr); + + if Expr_Type = Null_Iir then + -- Pass 1. + + if A_Type = Null_Iir then + Base_Type := Null_Iir; + else + Base_Type := Get_Base_Type (A_Type); + end if; + + -- Analyze left and right bounds. + Right := Sem_Expression_Ov (Right, Base_Type); + Left := Sem_Expression_Ov (Left, Base_Type); + + if Left = Null_Iir or else Right = Null_Iir then + -- Error. + return Null_Iir; + end if; + + Left_Type := Get_Type (Left); + Right_Type := Get_Type (Right); + -- Check for string or aggregate literals + -- FIXME: improve error message + if Left_Type = Null_Iir then + Error_Msg_Sem ("bad expression for a scalar", Left); + return Null_Iir; + end if; + if Right_Type = Null_Iir then + Error_Msg_Sem ("bad expression for a scalar", Right); + return Null_Iir; + end if; + + if Is_Overload_List (Left_Type) + or else Is_Overload_List (Right_Type) + then + if Base_Type /= Null_Iir then + -- Cannot happen, since sem_expression_ov should resolve + -- ambiguties if a type is given. + raise Internal_Error; + end if; + + -- Try to find a common type. + Expr_Type := Search_Compatible_Type (Left_Type, Right_Type); + if Expr_Type = Null_Iir then + if Compatibility_Types1 (Universal_Integer_Type_Definition, + Left_Type) + and then + Compatibility_Types1 (Universal_Integer_Type_Definition, + Right_Type) + then + Expr_Type := Universal_Integer_Type_Definition; + elsif Compatibility_Types1 (Universal_Real_Type_Definition, + Left_Type) + and then + Compatibility_Types1 (Universal_Real_Type_Definition, + Right_Type) + then + Expr_Type := Universal_Real_Type_Definition; + else + -- FIXME: handle overload + Error_Msg_Sem + ("left and right expressions of range are not compatible", + Expr); + return Null_Iir; + end if; + end if; + Left := Sem_Expression (Left, Expr_Type); + Right := Sem_Expression (Right, Expr_Type); + if Left = Null_Iir or else Right = Null_Iir then + return Null_Iir; + end if; + else + Expr_Type := Get_Common_Basetype (Get_Base_Type (Left_Type), + Get_Base_Type (Right_Type)); + if Expr_Type = Null_Iir then + Error_Msg_Sem + ("left and right expressions of range are not compatible", + Expr); + return Null_Iir; + end if; + end if; + + -- The type of the range is known, finish analysis. + else + -- Second call. + + pragma Assert (A_Type /= Null_Iir); + + if Is_Overload_List (Expr_Type) then + -- FIXME: resolve overload + raise Internal_Error; + else + if not Are_Types_Compatible (Expr_Type, A_Type) then + Error_Msg_Sem + ("type of range doesn't match expected type", Expr); + return Null_Iir; + end if; + + return Expr; + end if; + end if; + + Left := Eval_Expr_If_Static (Left); + Right := Eval_Expr_If_Static (Right); + Set_Left_Limit (Expr, Left); + Set_Right_Limit (Expr, Right); + Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Left), + Get_Expr_Staticness (Right))); + + if A_Type /= Null_Iir + and then not Are_Types_Compatible (Expr_Type, A_Type) + then + Error_Msg_Sem ("type of range doesn't match expected type", Expr); + return Null_Iir; + end if; + + Set_Type (Expr, Expr_Type); + if Get_Kind (Get_Base_Type (Expr_Type)) + not in Iir_Kinds_Scalar_Type_Definition + then + Error_Msg_Sem ("type of range is not a scalar type", Expr); + return Null_Iir; + end if; + + if Get_Expr_Staticness (Expr) = Locally + and then Get_Type_Staticness (Expr_Type) = Locally + and then Get_Kind (Expr_Type) in Iir_Kinds_Subtype_Definition + then + Eval_Check_Range (Expr, Expr_Type, Any_Dir); + end if; + + return Expr; + end Sem_Simple_Range_Expression; + + -- The result can be: + -- a subtype definition + -- a range attribute + -- a range type definition + -- LRM93 3.2.1.1 + -- FIXME: avoid to run it on an already semantized node, be careful + -- with range_type_expr. + function Sem_Range_Expression (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) + return Iir + is + Res : Iir; + Res_Type : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + Res := Sem_Simple_Range_Expression (Expr, A_Type, Any_Dir); + if Res = Null_Iir then + return Null_Iir; + end if; + Res_Type := Get_Type (Res); + + when Iir_Kinds_Denoting_Name + | Iir_Kind_Attribute_Name + | Iir_Kind_Parenthesis_Name => + if Get_Named_Entity (Expr) = Null_Iir then + Sem_Name (Expr); + end if; + Res := Name_To_Range (Expr); + if Res = Error_Mark then + return Null_Iir; + end if; + + case Get_Kind (Res) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + pragma Assert (Get_Kind (Get_Named_Entity (Res)) + in Iir_Kinds_Type_Declaration); + Res_Type := Get_Type (Get_Named_Entity (Res)); + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Res_Type := Get_Type (Res); + when others => + Error_Msg_Sem ("name must denote a range", Expr); + return Null_Iir; + end case; + if A_Type /= Null_Iir + and then Get_Base_Type (Res_Type) /= Get_Base_Type (A_Type) + then + Not_Match (Expr, A_Type); + return Null_Iir; + end if; + + when others => + Error_Msg_Sem ("range expression required", Expr); + return Null_Iir; + end case; + + if Get_Kind (Res_Type) not in Iir_Kinds_Scalar_Type_Definition then + Error_Msg_Sem (Disp_Node (Res) & " is not a range type", Expr); + return Null_Iir; + end if; + + Res := Eval_Range_If_Static (Res); + + if A_Type /= Null_Iir + and then Get_Type_Staticness (A_Type) = Locally + and then Get_Kind (A_Type) in Iir_Kinds_Subtype_Definition + then + if Get_Expr_Staticness (Res) = Locally then + Eval_Check_Range (Res, A_Type, Any_Dir); + end if; + end if; + return Res; + end Sem_Range_Expression; + + function Sem_Discrete_Range_Expression + (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) + return Iir + is + Res : Iir; + Res_Type : Iir; + begin + if Get_Kind (Expr) = Iir_Kind_Subtype_Definition then + Res := Sem_Types.Sem_Subtype_Indication (Expr); + if Res = Null_Iir then + return Null_Iir; + end if; + + Res_Type := Res; + if A_Type /= Null_Iir + and then (not Are_Types_Compatible + (A_Type, Get_Type_Of_Subtype_Indication (Res))) + then + -- A_TYPE is known when analyzing an index_constraint within + -- a subtype indication. + Error_Msg_Sem ("subtype " & Disp_Node (Res) + & " doesn't match expected type " + & Disp_Node (A_Type), Expr); + -- FIXME: override type of RES ? + end if; + else + Res := Sem_Range_Expression (Expr, A_Type, Any_Dir); + + if Res = Null_Iir then + return Null_Iir; + end if; + + Res_Type := Get_Type (Res); + end if; + + -- Check the type is discrete. + if Get_Kind (Res_Type) not in Iir_Kinds_Discrete_Type_Definition then + if Get_Kind (Res_Type) /= Iir_Kind_Error then + -- FIXME: avoid that test with error. + if Get_Kind (Res) not in Iir_Kinds_Denoting_Name then + Error_Msg_Sem ("range is not discrete", Res); + else + Error_Msg_Sem + (Disp_Node (Res) & " is not a discrete range type", Expr); + end if; + end if; + return Null_Iir; + end if; + + return Res; + end Sem_Discrete_Range_Expression; + + function Sem_Discrete_Range_Integer (Expr: Iir) return Iir + is + Res : Iir; + Range_Type : Iir; + begin + Res := Sem_Discrete_Range_Expression (Expr, Null_Iir, True); + if Res = Null_Iir then + return Null_Iir; + end if; + if Get_Kind (Expr) /= Iir_Kind_Range_Expression then + return Res; + end if; + + Range_Type := Get_Type (Res); + if Range_Type = Convertible_Integer_Type_Definition then + -- LRM 3.2.1.1 Index constraints and discrete ranges + -- 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 each bound is either a numeric literal or an + -- attribute, and the type of both bounds (prior to the + -- implicit conversion) is the type universal_integer. + + -- FIXME: catch phys/phys. + Set_Type (Res, Integer_Type_Definition); + if Get_Expr_Staticness (Res) = Locally then + Eval_Check_Range (Res, Integer_Subtype_Definition, True); + end if; + elsif Range_Type = Universal_Integer_Type_Definition 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", Res); + else + Error_Msg_Sem ("universal integer bound must be numeric literal " + & "or attribute", Res); + end if; + Set_Type (Res, Integer_Type_Definition); + end if; + return Res; + end Sem_Discrete_Range_Integer; + + procedure Set_Function_Call_Staticness (Expr : Iir; Imp : Iir) + is + Staticness : Iir_Staticness; + begin + -- LRM93 7.4.1 (Locally Static Primaries) + -- 4. a function call whose function name denotes an implicitly + -- defined operator, and whose actual parameters are each + -- locally static expressions; + -- + -- LRM93 7.4.2 (Globally Static Primaries) + -- 9. a function call whose function name denotes a pure function, + -- and whose actual parameters are each globally static + -- expressions. + case Get_Kind (Expr) is + when Iir_Kinds_Monadic_Operator => + Staticness := Get_Expr_Staticness (Get_Operand (Expr)); + when Iir_Kinds_Dyadic_Operator => + Staticness := Min (Get_Expr_Staticness (Get_Left (Expr)), + Get_Expr_Staticness (Get_Right (Expr))); + when Iir_Kind_Function_Call => + Staticness := Locally; + declare + Assoc : Iir; + begin + Assoc := Get_Parameter_Association_Chain (Expr); + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_Open then + Staticness := Min + (Get_Expr_Staticness (Get_Actual (Assoc)), + Staticness); + end if; + Assoc := Get_Chain (Assoc); + end loop; + end; + when Iir_Kind_Procedure_Call => + return; + when others => + Error_Kind ("set_function_call_staticness (1)", Expr); + end case; + case Get_Kind (Imp) is + when Iir_Kind_Implicit_Function_Declaration => + if Get_Implicit_Definition (Imp) + not in Iir_Predefined_Pure_Functions + then + -- Predefined functions such as Now, Endfile are not static. + Staticness := None; + end if; + when Iir_Kind_Function_Declaration => + if Get_Pure_Flag (Imp) then + Staticness := Min (Staticness, Globally); + else + Staticness := None; + end if; + when others => + Error_Kind ("set_function_call_staticness (2)", Imp); + end case; + Set_Expr_Staticness (Expr, Staticness); + end Set_Function_Call_Staticness; + + -- Add CALLEE in the callees list of SUBPRG (which must be a subprg decl). + procedure Add_In_Callees_List (Subprg : Iir; Callee : Iir) + is + Holder : constant Iir := Get_Callees_List_Holder (Subprg); + List : Iir_List; + begin + List := Get_Callees_List (Holder); + if List = Null_Iir_List then + List := Create_Iir_List; + Set_Callees_List (Holder, List); + end if; + -- FIXME: May use a flag in IMP to speed up the + -- add operation. + Add_Element (List, Callee); + end Add_In_Callees_List; + + -- Check purity rules when SUBPRG calls CALLEE. + -- Both SUBPRG and CALLEE are subprogram declarations. + -- Update purity_state/impure_depth of SUBPRG if it is a procedure. + procedure Sem_Call_Purity_Check (Subprg : Iir; Callee : Iir; Loc : Iir) + is + begin + if Callee = Subprg then + return; + end if; + + -- Handle easy cases. + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration => + if not Get_Pure_Flag (Subprg) then + return; + end if; + when Iir_Kind_Procedure_Declaration => + if Get_Purity_State (Subprg) = Impure then + return; + end if; + when Iir_Kinds_Process_Statement => + return; + when others => + Error_Kind ("sem_call_purity_check(0)", Subprg); + end case; + + case Get_Kind (Callee) is + when Iir_Kind_Function_Declaration => + if Get_Pure_Flag (Callee) then + -- Pure functions may be called anywhere. + return; + end if; + -- CALLEE is impure. + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration => + Error_Pure (Subprg, Callee, Loc); + when Iir_Kind_Procedure_Declaration => + Set_Purity_State (Subprg, Impure); + when others => + Error_Kind ("sem_call_purity_check(1)", Subprg); + end case; + when Iir_Kind_Procedure_Declaration => + declare + Depth : Iir_Int32; + Callee_Body : Iir; + Subprg_Body : Iir; + begin + Callee_Body := Get_Subprogram_Body (Callee); + Subprg_Body := Get_Subprogram_Body (Subprg); + -- Get purity depth of callee, if possible. + case Get_Purity_State (Callee) is + when Pure => + return; + when Impure => + Depth := Iir_Depth_Impure; + when Maybe_Impure => + if Callee_Body = Null_Iir then + -- Cannot be 'maybe_impure' if no body! + raise Internal_Error; + end if; + Depth := Get_Impure_Depth (Callee_Body); + when Unknown => + -- Add in list. + Add_In_Callees_List (Subprg, Callee); + + if Callee_Body /= Null_Iir then + Depth := Get_Impure_Depth (Callee_Body); + else + return; + end if; + end case; + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration => + if Depth = Iir_Depth_Impure then + Error_Pure (Subprg, Callee, Loc); + else + if Depth < Get_Subprogram_Depth (Subprg) then + Error_Pure (Subprg, Callee, Loc); + end if; + end if; + when Iir_Kind_Procedure_Declaration => + if Depth = Iir_Depth_Impure then + Set_Purity_State (Subprg, Impure); + -- FIXME: free callee list ? (wait state). + else + -- Set depth to the worst. + if Depth < Get_Impure_Depth (Subprg_Body) then + Set_Impure_Depth (Subprg_Body, Depth); + end if; + end if; + when others => + Error_Kind ("sem_call_purity_check(2)", Subprg); + end case; + end; + when others => + Error_Kind ("sem_call_purity_check", Callee); + end case; + end Sem_Call_Purity_Check; + + procedure Sem_Call_Wait_Check (Subprg : Iir; Callee : Iir; Loc : Iir) + is + procedure Error_Wait is + begin + Error_Msg_Sem + (Disp_Node (Subprg) & " must not contain wait statement, but calls", + Loc); + Error_Msg_Sem + (Disp_Node (Callee) & " which has (indirectly) a wait statement", + Callee); + --Error_Msg_Sem + -- ("(indirect) wait statement not allowed in " & Where, Loc); + end Error_Wait; + begin + pragma Assert (Get_Kind (Callee) = Iir_Kind_Procedure_Declaration); + + case Get_Wait_State (Callee) is + when False => + return; + when True => + null; + when Unknown => + Add_In_Callees_List (Subprg, Callee); + return; + end case; + + -- LRM 8.1 + -- It is an error if a wait statement appears [...] in a procedure that + -- has a parent that is a function subprogram. + -- + -- Furthermore, it is an error if a wait statement appears [...] in a + -- procedure that has a parent that is such a process statement. + case Get_Kind (Subprg) is + when Iir_Kind_Sensitized_Process_Statement => + Error_Wait; + return; + when Iir_Kind_Process_Statement => + return; + when Iir_Kind_Function_Declaration => + Error_Wait; + return; + when Iir_Kind_Procedure_Declaration => + if Is_Subprogram_Method (Subprg) then + Error_Wait; + else + Set_Wait_State (Subprg, True); + end if; + when others => + Error_Kind ("sem_call_wait_check", Subprg); + end case; + end Sem_Call_Wait_Check; + + procedure Sem_Call_All_Sensitized_Check + (Subprg : Iir; Callee : Iir; Loc : Iir) + is + begin + -- No need to deal with 'process (all)' if standard predates it. + if Vhdl_Std < Vhdl_08 then + return; + end if; + + -- If subprogram called is pure, then there is no signals reference. + case Get_Kind (Callee) is + when Iir_Kind_Function_Declaration => + if Get_Pure_Flag (Callee) then + return; + end if; + when Iir_Kind_Procedure_Declaration => + if Get_Purity_State (Callee) = Pure then + return; + end if; + when others => + Error_Kind ("sem_call_all_sensitized_check", Callee); + end case; + + case Get_All_Sensitized_State (Callee) is + when Invalid_Signal => + case Get_Kind (Subprg) is + when Iir_Kind_Sensitized_Process_Statement => + if Get_Sensitivity_List (Subprg) = Iir_List_All then + -- LRM08 11.3 + -- + -- It is an error if a process statement with the + -- reserved word ALL as its process sensitivity list + -- is the parent of a subprogram declared in a design + -- unit other than that containing the process statement + -- and the subprogram reads an explicitly declared + -- signal that is not a formal signal parameter or + -- member of a formal signal parameter of the + -- subprogram or of any of its parents. Similarly, + -- it is an error if such subprogram reads an implicit + -- signal whose explicit ancestor is not a formal signal + -- parameter or member of a formal parameter of + -- the subprogram or of any of its parents. + Error_Msg_Sem + ("all-sensitized " & Disp_Node (Subprg) + & " can't call " & Disp_Node (Callee), Loc); + Error_Msg_Sem + (" (as this subprogram reads (indirectly) a signal)", + Loc); + end if; + when Iir_Kind_Process_Statement => + return; + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Set_All_Sensitized_State (Subprg, Invalid_Signal); + when others => + Error_Kind ("sem_call_all_sensitized_check", Subprg); + end case; + when Read_Signal => + -- Put this subprogram in callees list as it may read a signal. + -- Used by canon to build the sensitivity list. + Add_In_Callees_List (Subprg, Callee); + if Get_Kind (Subprg) in Iir_Kinds_Subprogram_Declaration then + if Get_All_Sensitized_State (Subprg) < Read_Signal then + Set_All_Sensitized_State (Subprg, Read_Signal); + end if; + end if; + when Unknown => + -- Put this subprogram in callees list as it may read a signal. + -- Used by canon to build the sensitivity list. + Add_In_Callees_List (Subprg, Callee); + when No_Signal => + null; + end case; + end Sem_Call_All_Sensitized_Check; + + -- Set IMP as the implementation to being called by EXPR. + -- If the context is a subprogram or a process (ie, if current_subprogram + -- is not NULL), then mark IMP as callee of current_subprogram, and + -- update states. + procedure Sem_Subprogram_Call_Finish (Expr : Iir; Imp : Iir) + is + Subprg : constant Iir := Get_Current_Subprogram; + begin + Set_Function_Call_Staticness (Expr, Imp); + Mark_Subprogram_Used (Imp); + + -- Check purity/wait/passive. + + if Subprg = Null_Iir then + -- Not inside a suprogram or a process. + return; + end if; + if Subprg = Imp then + -- Recursive call. + return; + end if; + + case Get_Kind (Imp) is + when Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Implicit_Function_Declaration => + if Get_Implicit_Definition (Imp) in Iir_Predefined_Pure_Functions + then + return; + end if; + when Iir_Kind_Function_Declaration => + Sem_Call_Purity_Check (Subprg, Imp, Expr); + Sem_Call_All_Sensitized_Check (Subprg, Imp, Expr); + when Iir_Kind_Procedure_Declaration => + Sem_Call_Purity_Check (Subprg, Imp, Expr); + Sem_Call_Wait_Check (Subprg, Imp, Expr); + Sem_Call_All_Sensitized_Check (Subprg, Imp, Expr); + -- Check passive. + if Get_Passive_Flag (Imp) = False then + case Get_Kind (Subprg) is + when Iir_Kinds_Process_Statement => + if Get_Passive_Flag (Subprg) then + Error_Msg_Sem + (Disp_Node (Subprg) + & " is passive, but calls non-passive " + & Disp_Node (Imp), Expr); + end if; + when others => + null; + end case; + end if; + when others => + raise Internal_Error; + end case; + end Sem_Subprogram_Call_Finish; + + -- EXPR is a function or procedure call. + function Sem_Subprogram_Call_Stage1 + (Expr : Iir; A_Type : Iir; Is_Func_Call : Boolean) + return Iir + is + Imp : Iir; + Nbr_Inter: Natural; + A_Func: Iir; + Imp_List: Iir_List; + Assoc_Chain: Iir; + Inter_Chain : Iir; + Res_Type: Iir_List; + Inter: Iir; + Match : Boolean; + begin + -- Sem_Name has gathered all the possible names for the prefix of this + -- call. Reduce this list to only names that match the types. + Nbr_Inter := 0; + Imp := Get_Implementation (Expr); + Imp_List := Get_Overload_List (Imp); + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + + for I in Natural loop + A_Func := Get_Nth_Element (Imp_List, I); + exit when A_Func = Null_Iir; + + case Get_Kind (A_Func) is + when Iir_Kinds_Functions_And_Literals => + if not Is_Func_Call then + -- The identifier of a function call must be a function or + -- an enumeration literal. + goto Continue; + end if; + when Iir_Kinds_Procedure_Declaration => + if Is_Func_Call then + -- The identifier of a procedure call must be a procedure. + goto Continue; + end if; + when others => + Error_Kind ("sem_subprogram_call_stage1", A_Func); + end case; + + -- Keep this interpretation only if compatible. + if A_Type = Null_Iir + or else Compatibility_Nodes (A_Type, Get_Return_Type (A_Func)) + then + Sem_Association_Chain + (Get_Interface_Declaration_Chain (A_Func), + Assoc_Chain, False, Missing_Parameter, Expr, Match); + if Match then + Replace_Nth_Element (Imp_List, Nbr_Inter, A_Func); + Nbr_Inter := Nbr_Inter + 1; + end if; + end if; + + << Continue >> null; + end loop; + Set_Nbr_Elements (Imp_List, Nbr_Inter); + + -- Set_Implementation (Expr, Inter_List); + -- A set of possible functions to call is in INTER_LIST. + -- Create a set of possible return type in RES_TYPE. + case Nbr_Inter is + when 0 => + -- FIXME: display subprogram name. + Error_Msg_Sem + ("cannot resolve overloading for subprogram call", Expr); + return Null_Iir; + + when 1 => + -- Simple case: no overloading. + Inter := Get_First_Element (Imp_List); + Free_Overload_List (Imp); + Set_Implementation (Expr, Inter); + if Is_Func_Call then + Set_Type (Expr, Get_Return_Type (Inter)); + end if; + Inter_Chain := Get_Interface_Declaration_Chain (Inter); + Sem_Association_Chain + (Inter_Chain, Assoc_Chain, + True, Missing_Parameter, Expr, Match); + Set_Parameter_Association_Chain (Expr, Assoc_Chain); + if not Match then + raise Internal_Error; + end if; + Check_Subprogram_Associations (Inter_Chain, Assoc_Chain); + Sem_Subprogram_Call_Finish (Expr, Inter); + return Expr; + + when others => + if Is_Func_Call then + if A_Type /= Null_Iir then + -- Cannot find a single interpretation for a given + -- type. + Error_Overload (Expr); + Disp_Overload_List (Imp_List, Expr); + return Null_Iir; + end if; + + -- Create the list of types for the result. + Res_Type := Create_Iir_List; + for I in 0 .. Nbr_Inter - 1 loop + Add_Element + (Res_Type, + Get_Return_Type (Get_Nth_Element (Imp_List, I))); + end loop; + + if Get_Nbr_Elements (Res_Type) = 1 then + -- several implementations but one profile. + Error_Overload (Expr); + Disp_Overload_List (Imp_List, Expr); + return Null_Iir; + end if; + Set_Type (Expr, Create_Overload_List (Res_Type)); + else + -- For a procedure call, the context does't help to resolve + -- overload. + Error_Overload (Expr); + Disp_Overload_List (Imp_List, Expr); + end if; + return Expr; + end case; + end Sem_Subprogram_Call_Stage1; + + -- For a procedure call, A_TYPE must be null. + -- Associations must have already been semantized by sem_association_list. + function Sem_Subprogram_Call (Expr: Iir; A_Type: Iir) return Iir + is + Is_Func: constant Boolean := Get_Kind (Expr) = Iir_Kind_Function_Call; + Res_Type: Iir; + Res: Iir; + Inter_List: Iir; + Param_Chain : Iir; + Inter: Iir; + Assoc_Chain : Iir; + Match : Boolean; + begin + if Is_Func then + Res_Type := Get_Type (Expr); + end if; + + if not Is_Func or else Res_Type = Null_Iir then + -- First call to sem_subprogram_call. + -- Create the list of possible implementations and possible + -- return types, according to arguments and A_TYPE. + + -- Select possible interpretations among all interpretations. + -- NOTE: the list of possible implementations was already created + -- during the transformation of iir_kind_parenthesis_name to + -- iir_kind_function_call. + Inter_List := Get_Implementation (Expr); + if Get_Kind (Inter_List) = Iir_Kind_Error then + return Null_Iir; + elsif Is_Overload_List (Inter_List) then + -- Subprogram name is overloaded. + return Sem_Subprogram_Call_Stage1 (Expr, A_Type, Is_Func); + else + -- Only one interpretation for the subprogram name. + if Is_Func then + if Get_Kind (Inter_List) not in Iir_Kinds_Function_Declaration + then + Error_Msg_Sem ("name does not designate a function", Expr); + return Null_Iir; + end if; + else + if Get_Kind (Inter_List) not in Iir_Kinds_Procedure_Declaration + then + Error_Msg_Sem ("name does not designate a procedure", Expr); + return Null_Iir; + end if; + end if; + + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + Param_Chain := Get_Interface_Declaration_Chain (Inter_List); + Sem_Association_Chain + (Param_Chain, Assoc_Chain, + True, Missing_Parameter, Expr, Match); + Set_Parameter_Association_Chain (Expr, Assoc_Chain); + if not Match then + -- No need to disp an error message, this is done by + -- sem_subprogram_arguments. + return Null_Iir; + end if; + if Is_Func then + Set_Type (Expr, Get_Return_Type (Inter_List)); + end if; + Check_Subprogram_Associations (Param_Chain, Assoc_Chain); + Set_Implementation (Expr, Inter_List); + Sem_Subprogram_Call_Finish (Expr, Inter_List); + return Expr; + end if; + end if; + + -- Second call to Sem_Function_Call (only for functions). + pragma Assert (Is_Func); + pragma Assert (A_Type /= Null_Iir); + + -- The implementation list was set. + -- The return type was set. + -- A_TYPE is not null, A_TYPE is *the* return type. + + Inter_List := Get_Implementation (Expr); + + -- Find a single implementation. + Res := Null_Iir; + if Is_Overload_List (Inter_List) then + -- INTER_LIST is a list of possible declaration to call. + -- Find one, based on the return type A_TYPE. + for I in Natural loop + Inter := Get_Nth_Element (Get_Overload_List (Inter_List), I); + exit when Inter = Null_Iir; + if Are_Basetypes_Compatible + (A_Type, Get_Base_Type (Get_Return_Type (Inter))) + then + if Res /= Null_Iir then + Error_Overload (Expr); + Disp_Overload_List (Get_Overload_List (Inter_List), Expr); + return Null_Iir; + else + Res := Inter; + end if; + end if; + end loop; + else + if Are_Basetypes_Compatible + (A_Type, Get_Base_Type (Get_Return_Type (Inter_List))) + then + Res := Inter_List; + end if; + end if; + if Res = Null_Iir then + Not_Match (Expr, A_Type); + return Null_Iir; + end if; + + -- Clean up. + if Res_Type /= Null_Iir and then Is_Overload_List (Res_Type) then + Free_Iir (Res_Type); + end if; + + if Is_Overload_List (Inter_List) then + Free_Iir (Inter_List); + end if; + + -- Simple case: this is not a call to a function, but an enumeration + -- literal. + if Get_Kind (Res) = Iir_Kind_Enumeration_Literal then + -- Free_Iir (Expr); + return Res; + end if; + + -- Set types. + Set_Type (Expr, Get_Return_Type (Res)); + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + Param_Chain := Get_Interface_Declaration_Chain (Res); + Sem_Association_Chain + (Param_Chain, Assoc_Chain, True, Missing_Parameter, Expr, Match); + Set_Parameter_Association_Chain (Expr, Assoc_Chain); + if not Match then + return Null_Iir; + end if; + Check_Subprogram_Associations (Param_Chain, Assoc_Chain); + Set_Implementation (Expr, Res); + Sem_Subprogram_Call_Finish (Expr, Res); + return Expr; + end Sem_Subprogram_Call; + + procedure Sem_Procedure_Call (Call : Iir_Procedure_Call; Stmt : Iir) + is + Imp: Iir; + Name : Iir; + Parameters_Chain : Iir; + Param : Iir; + Formal : Iir; + Prefix : Iir; + Inter : Iir; + begin + Name := Get_Prefix (Call); + -- FIXME: check for denoting name. + Sem_Name (Name); + + -- Return now if the procedure declaration wasn't found. + Imp := Get_Named_Entity (Name); + if Is_Error (Imp) then + return; + end if; + Set_Implementation (Call, Imp); + + Name_To_Method_Object (Call, Name); + Parameters_Chain := Get_Parameter_Association_Chain (Call); + if Sem_Actual_Of_Association_Chain (Parameters_Chain) = False then + return; + end if; + if Sem_Subprogram_Call (Call, Null_Iir) /= Call then + return; + end if; + Imp := Get_Implementation (Call); + if Is_Overload_List (Imp) then + -- Failed to resolve overload. + return; + end if; + Set_Named_Entity (Name, Imp); + Set_Prefix (Call, Finish_Sem_Name (Name)); + + -- LRM 2.1.1.2 Signal Parameters + -- A process statement contains a driver for each actual signal + -- associated with a formal signal parameter of mode OUT or INOUT in + -- a subprogram call. + -- Similarly, a subprogram contains a driver for each formal signal + -- parameter of mode OUT or INOUT declared in its subrogram + -- specification. + Param := Parameters_Chain; + Inter := Get_Interface_Declaration_Chain (Imp); + while Param /= Null_Iir loop + Formal := Get_Formal (Param); + if Formal = Null_Iir then + Formal := Inter; + Inter := Get_Chain (Inter); + else + Formal := Get_Base_Name (Formal); + Inter := Null_Iir; + end if; + if Get_Kind (Formal) = Iir_Kind_Interface_Signal_Declaration + and then Get_Mode (Formal) in Iir_Out_Modes + then + Prefix := Name_To_Object (Get_Actual (Param)); + if Prefix /= Null_Iir then + case Get_Kind (Get_Object_Prefix (Prefix)) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Prefix := Get_Longuest_Static_Prefix (Prefix); + Sem_Stmts.Sem_Add_Driver (Prefix, Stmt); + when others => + null; + end case; + end if; + end if; + Param := Get_Chain (Param); + end loop; + end Sem_Procedure_Call; + + -- List must be an overload list containing subprograms declarations. + -- Try to resolve overload and return the uniq interpretation if one, + -- NULL_IIR otherwise. + -- + -- If there are two functions, one primitive of a universal + -- type and the other not, return the primitive of the universal type. + -- This rule is *not* from LRM (but from Ada) and allows to resolve + -- common cases such as: + -- constant c1 : integer := - 4; -- or '+', 'abs' + -- constant c2 : integer := 2 ** 3; + -- constant c3 : integer := 3 - 2; -- or '+', '*', '/'... + function Get_Non_Implicit_Subprogram (List : Iir_List) return Iir + is + El : Iir; + Res : Iir; + Ref_Type : Iir; + begin + -- Conditions: + -- 1. All the possible functions must return boolean. + -- 2. There is only one implicit function for universal or real. + Res := Null_Iir; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if Get_Base_Type (Get_Return_Type (El)) /= Boolean_Type_Definition + then + return Null_Iir; + end if; + + if Get_Kind (El) = Iir_Kind_Implicit_Function_Declaration then + Ref_Type := Get_Type_Reference (El); + if Ref_Type = Universal_Integer_Type_Declaration + or Ref_Type = Universal_Real_Type_Declaration + then + if Res = Null_Iir then + Res := El; + else + return Null_Iir; + end if; + end if; + end if; + end loop; + return Res; + end Get_Non_Implicit_Subprogram; + + -- Honor the -fexplicit flag. + -- If LIST is composed of 2 declarations that matches the 'explicit' rule, + -- return the explicit declaration. + -- Otherwise, return NULL_IIR. + function Get_Explicit_Subprogram (List : Iir_List) return Iir + is + Sub1 : Iir; + Sub2 : Iir; + Res : Iir; + begin + if Get_Nbr_Elements (List) /= 2 then + return Null_Iir; + end if; + + Sub1 := Get_Nth_Element (List, 0); + Sub2 := Get_Nth_Element (List, 1); + + -- One must be an implicit declaration, the other must be an explicit + -- declaration. + if Get_Kind (Sub1) = Iir_Kind_Implicit_Function_Declaration then + if Get_Kind (Sub2) /= Iir_Kind_Function_Declaration then + return Null_Iir; + end if; + Res := Sub2; + elsif Get_Kind (Sub1) = Iir_Kind_Function_Declaration then + if Get_Kind (Sub2) /= Iir_Kind_Implicit_Function_Declaration then + return Null_Iir; + end if; + Res := Sub1; + else + Error_Kind ("get_explicit_subprogram", Sub1); + end if; + + -- They must have the same profile. + if Get_Subprogram_Hash (Sub1) /= Get_Subprogram_Hash (Sub2) + or else not Is_Same_Profile (Sub1, Sub2) + then + return Null_Iir; + end if; + + -- They must be declared in a package. + if Get_Kind (Get_Parent (Sub1)) /= Iir_Kind_Package_Declaration + or else Get_Kind (Get_Parent (Sub2)) /= Iir_Kind_Package_Declaration + then + return Null_Iir; + end if; + + return Res; + end Get_Explicit_Subprogram; + + -- Set when the -fexplicit option was adviced. + Explicit_Advice_Given : Boolean := False; + + function Sem_Operator (Expr : Iir; Res_Type : Iir; Arity : Positive) + return Iir + is + Operator : Name_Id; + Left, Right: Iir; + Interpretation : Name_Interpretation_Type; + Decl : Iir; + Overload_List : Iir_List; + Overload : Iir; + Res_Type_List : Iir; + Full_Compat : Iir; + + -- LEFT and RIGHT must be set. + function Set_Uniq_Interpretation (Decl : Iir) return Iir + is + Interface_Chain : Iir; + Err : Boolean; + begin + Set_Type (Expr, Get_Return_Type (Decl)); + Interface_Chain := Get_Interface_Declaration_Chain (Decl); + Err := False; + if Is_Overloaded (Left) then + Left := Sem_Expression_Ov + (Left, Get_Base_Type (Get_Type (Interface_Chain))); + if Left = Null_Iir then + Err := True; + else + if Arity = 1 then + Set_Operand (Expr, Left); + else + Set_Left (Expr, Left); + end if; + end if; + end if; + Check_Read (Left); + if Arity = 2 then + if Is_Overloaded (Right) then + Right := Sem_Expression_Ov + (Right, + Get_Base_Type (Get_Type (Get_Chain (Interface_Chain)))); + if Right = Null_Iir then + Err := True; + else + Set_Right (Expr, Right); + end if; + end if; + Check_Read (Right); + end if; + Destroy_Iir_List (Overload_List); + if not Err then + Set_Implementation (Expr, Decl); + Sem_Subprogram_Call_Finish (Expr, Decl); + return Eval_Expr_If_Static (Expr); + else + return Expr; + end if; + end Set_Uniq_Interpretation; + + -- Note: operator and implementation node of expr must be set. + procedure Error_Operator_Overload (List : Iir_List) is + begin + Error_Msg_Sem ("operator """ & Name_Table.Image (Operator) + & """ is overloaded", Expr); + Disp_Overload_List (List, Expr); + end Error_Operator_Overload; + + Interface_Chain : Iir; + begin + if Arity = 1 then + Left := Get_Operand (Expr); + Right := Null_Iir; + else + Left := Get_Left (Expr); + Right := Get_Right (Expr); + end if; + Operator := Iirs_Utils.Get_Operator_Name (Expr); + + if Get_Type (Expr) = Null_Iir then + -- First pass. + -- Semantize operands. + -- FIXME: should try to semantize right operand even if semantization + -- of left operand has failed ?? + if Get_Type (Left) = Null_Iir then + Left := Sem_Expression_Ov (Left, Null_Iir); + if Left = Null_Iir then + return Null_Iir; + end if; + if Arity = 1 then + Set_Operand (Expr, Left); + else + Set_Left (Expr, Left); + end if; + end if; + if Arity = 2 and then Get_Type (Right) = Null_Iir then + Right := Sem_Expression_Ov (Right, Null_Iir); + if Right = Null_Iir then + return Null_Iir; + end if; + Set_Right (Expr, Right); + end if; + + Overload_List := Create_Iir_List; + + -- Try to find an implementation among user defined function + Interpretation := Get_Interpretation (Operator); + while Valid_Interpretation (Interpretation) loop + Decl := Get_Non_Alias_Declaration (Interpretation); + + -- It is compatible with operand types ? + if Get_Kind (Decl) not in Iir_Kinds_Function_Declaration then + raise Internal_Error; + end if; + + -- LRM08 12.3 Visibility + -- [...] or all visible declarations denote the same named entity. + -- + -- GHDL: If DECL has already been seen, then skip it. + if Get_Seen_Flag (Decl) then + goto Next; + end if; + + -- Check return type. + if Res_Type /= Null_Iir + and then + not Are_Types_Compatible (Res_Type, Get_Return_Type (Decl)) + then + goto Next; + end if; + + Interface_Chain := Get_Interface_Declaration_Chain (Decl); + + -- Check arity. + + -- LRM93 2.5.2 Operator overloading + -- The subprogram specification of a unary operator must have + -- a single parameter [...] + -- The subprogram specification of a binary operator must have + -- two parameters [...] + -- + -- GHDL: So even in presence of default expression in a parameter, + -- a unary operation has to match with a binary operator. + if Iir_Chains.Get_Chain_Length (Interface_Chain) /= Arity then + goto Next; + end if; + + -- Check operands. + if not Is_Expr_Compatible (Get_Type (Interface_Chain), Left) then + goto Next; + end if; + if Arity = 2 then + if not Is_Expr_Compatible + (Get_Type (Get_Chain (Interface_Chain)), Right) + then + goto Next; + end if; + end if; + + -- Match. + Set_Seen_Flag (Decl, True); + Append_Element (Overload_List, Decl); + + << Next >> null; + Interpretation := Get_Next_Interpretation (Interpretation); + end loop; + + -- Clear seen_flags. + for I in Natural loop + Decl := Get_Nth_Element (Overload_List, I); + exit when Decl = Null_Iir; + Set_Seen_Flag (Decl, False); + end loop; + + -- The list of possible implementations was computed. + case Get_Nbr_Elements (Overload_List) is + when 0 => + Error_Msg_Sem + ("no function declarations for " & Disp_Node (Expr), Expr); + Destroy_Iir_List (Overload_List); + return Null_Iir; + + when 1 => + Decl := Get_First_Element (Overload_List); + return Set_Uniq_Interpretation (Decl); + + when others => + -- Preference for universal operator. + -- This roughly corresponds to: + -- + -- LRM 7.3.5 + -- An implicit conversion of a convertible universal operand + -- is applied if and only if the innermost complete context + -- determines a unique (numeric) target type for the implicit + -- conversion, and there is no legal interpretation of this + -- context without this conversion. + if Arity = 2 then + Decl := Get_Non_Implicit_Subprogram (Overload_List); + if Decl /= Null_Iir then + return Set_Uniq_Interpretation (Decl); + end if; + end if; + + Set_Implementation (Expr, Create_Overload_List (Overload_List)); + + -- Create the list of possible return types, if it is not yet + -- determined. + if Res_Type = Null_Iir then + Res_Type_List := Create_List_Of_Types (Overload_List); + if Is_Overload_List (Res_Type_List) then + -- There are many possible return types. + -- Try again. + Set_Type (Expr, Res_Type_List); + return Expr; + end if; + end if; + + -- The return type is known. + -- Search for explicit subprogram. + + -- It was impossible to find one solution. + Error_Operator_Overload (Overload_List); + + -- Give an advice. + if not Flags.Flag_Explicit + and then not Explicit_Advice_Given + and then Flags.Vhdl_Std < Vhdl_08 + then + Decl := Get_Explicit_Subprogram (Overload_List); + if Decl /= Null_Iir then + Error_Msg_Sem + ("(you may want to use the -fexplicit option)", Expr); + Explicit_Advice_Given := True; + end if; + end if; + + return Null_Iir; + end case; + else + -- Second pass + -- Find the uniq implementation for this call. + Overload := Get_Implementation (Expr); + Overload_List := Get_Overload_List (Overload); + Full_Compat := Null_Iir; + for I in Natural loop + Decl := Get_Nth_Element (Overload_List, I); + exit when Decl = Null_Iir; + -- FIXME: wrong: compatibilty with return type and args. + if Are_Types_Compatible (Get_Return_Type (Decl), Res_Type) then + if Full_Compat /= Null_Iir then + Error_Operator_Overload (Overload_List); + return Null_Iir; + else + Full_Compat := Decl; + end if; + end if; + end loop; + Free_Iir (Overload); + Overload := Get_Type (Expr); + Free_Overload_List (Overload); + return Set_Uniq_Interpretation (Full_Compat); + end if; + end Sem_Operator; + + -- Semantize LIT whose elements must be of type EL_TYPE, and return + -- the length. + -- FIXME: the errors are reported, but there is no mark of that. + function Sem_String_Literal (Lit: Iir; El_Type : Iir) return Natural + is + function Find_Literal (Etype : Iir_Enumeration_Type_Definition; + C : Character) + return Iir_Enumeration_Literal + is + Inter : Name_Interpretation_Type; + Id : Name_Id; + Decl : Iir; + begin + Id := Name_Table.Get_Identifier (C); + Inter := Get_Interpretation (Id); + while Valid_Interpretation (Inter) loop + Decl := Get_Declaration (Inter); + if Get_Kind (Decl) = Iir_Kind_Enumeration_Literal + and then Get_Type (Decl) = Etype + then + return Decl; + end if; + Inter := Get_Next_Interpretation (Inter); + end loop; + -- Character C is not visible... + if Find_Name_In_List (Get_Enumeration_Literal_List (Etype), Id) + = Null_Iir + then + -- ... because it is not defined. + Error_Msg_Sem + ("type " & Disp_Node (Etype) & " does not define character '" + & C & "'", Lit); + else + -- ... because it is not visible. + Error_Msg_Sem ("character '" & C & "' of type " + & Disp_Node (Etype) & " is not visible", Lit); + end if; + return Null_Iir; + end Find_Literal; + + Ptr : String_Fat_Acc; + El : Iir; + pragma Unreferenced (El); + Len : Nat32; + begin + Len := Get_String_Length (Lit); + + if Get_Kind (Lit) = Iir_Kind_Bit_String_Literal then + Set_Bit_String_0 (Lit, Find_Literal (El_Type, '0')); + Set_Bit_String_1 (Lit, Find_Literal (El_Type, '1')); + else + Ptr := Get_String_Fat_Acc (Lit); + + -- For a string_literal, check all characters of the string is a + -- literal of the type. + -- Always check, for visibility. + for I in 1 .. Len loop + El := Find_Literal (El_Type, Ptr (I)); + end loop; + end if; + + Set_Expr_Staticness (Lit, Locally); + + return Natural (Len); + end Sem_String_Literal; + + procedure Sem_String_Literal (Lit: Iir) + is + Lit_Type : constant Iir := Get_Type (Lit); + Lit_Base_Type : constant Iir := Get_Base_Type (Lit_Type); + + -- The subtype created for the literal. + N_Type: Iir; + -- type of the index of the array type. + Index_Type: Iir; + Len : Natural; + El_Type : Iir; + begin + El_Type := Get_Base_Type (Get_Element_Subtype (Lit_Base_Type)); + Len := Sem_String_Literal (Lit, El_Type); + + if Get_Constraint_State (Lit_Type) = Fully_Constrained then + -- The type of the context is constrained. + Index_Type := Get_Index_Type (Lit_Type, 0); + 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: emit a warning because of dubious construct (the type + -- of the string is not locally constrained) ? + null; + end if; + else + -- Context type is not constained. 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); + Set_Literal_Subtype (Lit, N_Type); + end if; + 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; + + -- 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; + + -- Compare two elements of ARR. + -- Return true iff OP1 < OP2. + function Lt (Op1, Op2 : Natural) return Boolean is + begin + return Compare_String_Literals (Get_Choice_Expression (Arr (Op1)), + Get_Choice_Expression (Arr (Op2))) + = Compare_Lt; + end Lt; + + function Eq (Op1, Op2 : Natural) return Boolean is + begin + return Compare_String_Literals (Get_Choice_Expression (Arr (Op1)), + Get_Choice_Expression (Arr (Op2))) + = Compare_Eq; + 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; + begin + -- LRM93 8.8 + -- In such case, each choice appearing in any of the case statement + -- alternative must be a locally static expression whose value is of + -- the same length as that of the case expression. + Expr := Sem_Expression (Get_Choice_Expression (Choice), Sel_Type); + if Expr = Null_Iir then + Has_Length_Error := True; + return; + end if; + Set_Choice_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); + Set_Choice_Expression (Choice, Expr); + if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then + Error_Msg_Sem + ("bound error during evaluation of choice expression", Expr); + Has_Length_Error := True; + elsif Eval_Discrete_Type_Length + (Get_String_Type_Bound_Type (Get_Type (Expr))) /= Sel_Length + then + Has_Length_Error := True; + Error_Msg_Sem + ("value not of the same length of the case expression", Expr); + return; + end if; + end Sem_Simple_Choice; + begin + -- LRM93 8.8 + -- If the expression is of one-dimensional character array type, then + -- the expression must be one of the following: + -- FIXME: to complete. + Sel_Type := Get_Type (Sel); + if not Is_One_Dimensional_Array_Type (Sel_Type) then + Error_Msg_Sem + ("expression must be discrete or one-dimension array subtype", Sel); + return; + end if; + if Get_Type_Staticness (Sel_Type) /= Locally then + Error_Msg_Sem ("array type must be locally static", Sel); + return; + 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); + + Has_Others := False; + Nbr_Choices := 0; + El := Choice_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + raise Internal_Error; + when Iir_Kind_Choice_By_Range => + 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 + Error_Msg_Sem ("duplicate others choice", El); + elsif Get_Chain (El) /= Null_Iir then + Error_Msg_Sem + ("choice others must be the last alternative", El); + end if; + Has_Others := True; + when others => + Error_Kind ("sem_string_choices_range", El); + end case; + El := Get_Chain (El); + end loop; + + -- 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; + + procedure Sem_Choices_Range + (Choice_Chain : in out Iir; + Sub_Type : Iir; + Is_Sub_Range : Boolean; + Is_Case_Stmt : Boolean; + Loc : Location_Type; + Low : out Iir; + High : out Iir) + is + -- Number of positionnal choice. + Nbr_Pos : Iir_Int64; + + -- Number of named choices. + Nbr_Named : Natural; + + -- True if others choice is present. + Has_Others : Boolean; + + Has_Error : Boolean; + + -- True if SUB_TYPE has bounds. + Type_Has_Bounds : Boolean; + + Arr : Iir_Array_Acc; + Index : Natural; + Pos_Max : Iir_Int64; + El : Iir; + Prev_El : Iir; + + -- Staticness of the current choice. + Choice_Staticness : Iir_Staticness; + + -- Staticness of all the choices. + Staticness : Iir_Staticness; + + function Replace_By_Range_Choice (Name : Iir; Range_Type : Iir) + return Boolean + is + N_Choice : Iir; + Name1 : Iir; + begin + if not Are_Types_Compatible (Range_Type, Sub_Type) then + Not_Match (Name, Sub_Type); + return False; + end if; + + Name1 := Finish_Sem_Name (Name); + N_Choice := Create_Iir (Iir_Kind_Choice_By_Range); + Location_Copy (N_Choice, El); + Set_Chain (N_Choice, Get_Chain (El)); + Set_Associated_Expr (N_Choice, Get_Associated_Expr (El)); + Set_Associated_Chain (N_Choice, Get_Associated_Chain (El)); + Set_Same_Alternative_Flag (N_Choice, Get_Same_Alternative_Flag (El)); + Set_Choice_Range (N_Choice, Eval_Range_If_Static (Name1)); + Set_Choice_Staticness (N_Choice, Get_Type_Staticness (Range_Type)); + Free_Iir (El); + + if Prev_El = Null_Iir then + Choice_Chain := N_Choice; + else + Set_Chain (Prev_El, N_Choice); + end if; + El := N_Choice; + + return True; + end Replace_By_Range_Choice; + + -- Semantize a simple (by expression or by range) choice. + -- Return FALSE in case of error. + function Sem_Simple_Choice return Boolean + is + Expr : Iir; + Ent : Iir; + begin + if Get_Kind (El) = Iir_Kind_Choice_By_Range then + Expr := Get_Choice_Range (El); + Expr := Sem_Discrete_Range_Expression (Expr, Sub_Type, True); + if Expr = Null_Iir then + return False; + end if; + Expr := Eval_Range_If_Static (Expr); + Set_Choice_Range (El, Expr); + else + Expr := Get_Choice_Expression (El); + case Get_Kind (Expr) is + when Iir_Kind_Selected_Name + | Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Selected_By_All_Name + | Iir_Kind_Attribute_Name => + Sem_Name (Expr); + Ent := Get_Named_Entity (Expr); + if Ent = Error_Mark then + return False; + end if; + + -- So range or expression ? + -- FIXME: share code with sem_name for slice/index. + case Get_Kind (Ent) is + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Range_Expression => + return Replace_By_Range_Choice (Expr, Ent); + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration => + Ent := Is_Type_Name (Expr); + Set_Expr_Staticness (Expr, Get_Type_Staticness (Ent)); + return Replace_By_Range_Choice (Expr, Ent); + when others => + Expr := Name_To_Expression + (Expr, Get_Base_Type (Sub_Type)); + end case; + when others => + Expr := Sem_Expression_Ov (Expr, Get_Base_Type (Sub_Type)); + end case; + if Expr = Null_Iir then + return False; + end if; + Expr := Eval_Expr_If_Static (Expr); + Set_Choice_Expression (El, Expr); + end if; + Set_Choice_Staticness (El, Get_Expr_Staticness (Expr)); + return True; + end Sem_Simple_Choice; + + -- Get low limit of ASSOC. + -- First, get the expression of the association, then the low limit. + -- ASSOC may be either association_by_range (in this case the low limit + -- is to be fetched), or association_by_expression (and the low limit + -- is the expression). + function Get_Low (Assoc : Iir) return Iir + is + Expr : Iir; + begin + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_Expression => + return Get_Choice_Expression (Assoc); + when Iir_Kind_Choice_By_Range => + Expr := Get_Choice_Range (Assoc); + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + case Get_Direction (Expr) is + when Iir_To => + return Get_Left_Limit (Expr); + when Iir_Downto => + return Get_Right_Limit (Expr); + end case; + when others => + return Expr; + end case; + when others => + Error_Kind ("get_low", Assoc); + end case; + end Get_Low; + + function Get_High (Assoc : Iir) return Iir + is + Expr : Iir; + begin + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_Expression => + return Get_Choice_Expression (Assoc); + when Iir_Kind_Choice_By_Range => + Expr := Get_Choice_Range (Assoc); + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + case Get_Direction (Expr) is + when Iir_To => + return Get_Right_Limit (Expr); + when Iir_Downto => + return Get_Left_Limit (Expr); + end case; + when others => + return Expr; + end case; + when others => + Error_Kind ("get_high", Assoc); + end case; + end Get_High; + + -- Compare two elements of ARR. + -- Return true iff OP1 < OP2. + function Lt (Op1, Op2 : Natural) return Boolean is + begin + return + Eval_Pos (Get_Low (Arr (Op1))) < Eval_Pos (Get_Low (Arr (Op2))); + end Lt; + + -- Swap two elements of ARR. + procedure Swap (From : Natural; To : Natural) + is + Tmp : Iir; + begin + Tmp := Arr (To); + Arr (To) := Arr (From); + Arr (From) := Tmp; + end Swap; + + package Disc_Heap_Sort is new Heap_Sort (Lt => Lt, Swap => Swap); + begin + Low := Null_Iir; + High := Null_Iir; + + -- First: + -- semantize the choices + -- compute the range of positionnal choices + -- compute the number of choice elements (extracted from lists). + -- check for others presence. + Nbr_Pos := 0; + Nbr_Named := 0; + Has_Others := False; + Has_Error := False; + Staticness := Locally; + El := Choice_Chain; + Prev_El := Null_Iir; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + Nbr_Pos := Nbr_Pos + 1; + when Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range => + if Sem_Simple_Choice then + Choice_Staticness := Get_Choice_Staticness (El); + Staticness := Min (Staticness, Choice_Staticness); + if Choice_Staticness /= Locally + and then Is_Case_Stmt + then + -- FIXME: explain why + Error_Msg_Sem ("choice is not locally static", El); + end if; + else + Has_Error := True; + end if; + Nbr_Named := Nbr_Named + 1; + when Iir_Kind_Choice_By_Name => + -- It is not possible to have such a choice in an array + -- aggregate. + -- Should have been caught previously. + raise Internal_Error; + when Iir_Kind_Choice_By_Others => + if Has_Others then + Error_Msg_Sem ("duplicate others choice", El); + elsif Get_Chain (El) /= Null_Iir then + Error_Msg_Sem + ("choice others should be the last alternative", El); + end if; + Has_Others := True; + when others => + Error_Kind ("sem_choices_range", El); + end case; + Prev_El := El; + El := Get_Chain (El); + end loop; + + if Has_Error then + -- Nothing can be done here... + return; + end if; + if Nbr_Pos > 0 and then Nbr_Named > 0 then + -- LRM93 7.3.2.2 + -- Apart from the final element with the single choice OTHERS, the + -- rest (if any) of the element associations of an array aggregate + -- must be either all positionnal or all named. + Error_Msg_Sem + ("element associations must be all positional or all named", Loc); + return; + end if; + + -- For a positional aggregate. + if Nbr_Pos > 0 then + -- Check number of elements match, but only if it is possible. + if Get_Type_Staticness (Sub_Type) /= Locally then + return; + end if; + Pos_Max := Eval_Discrete_Type_Length (Sub_Type); + if (not Has_Others and not Is_Sub_Range) + and then Nbr_Pos < Pos_Max + then + Error_Msg_Sem ("not enough elements associated", Loc); + elsif Nbr_Pos > Pos_Max then + Error_Msg_Sem ("too many elements associated", Loc); + end if; + return; + end if; + + -- Second: + -- Create the list of choices + if Nbr_Named = 0 and then Has_Others then + -- This is only a others association. + return; + end if; + if Staticness /= Locally then + -- Emit a message for aggregrate. The message has already been + -- emitted for a case stmt. + -- FIXME: what about individual associations? + if not Is_Case_Stmt then + -- LRM93 §7.3.2.2 + -- A named association of an array aggregate is allowed to have + -- a choice that is not locally static, or likewise a choice that + -- is a null range, only if the aggregate includes a single + -- element association and the element association has a single + -- choice. + if Nbr_Named > 1 or Has_Others then + Error_Msg_Sem ("not static choice exclude others choice", Loc); + end if; + end if; + return; + end if; + + -- Set TYPE_HAS_BOUNDS + case Get_Kind (Sub_Type) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition => + Type_Has_Bounds := True; + when Iir_Kind_Integer_Type_Definition => + Type_Has_Bounds := False; + when others => + Error_Kind ("sem_choice_range(3)", Sub_Type); + end case; + + Arr := new Iir_Array (1 .. Nbr_Named); + Index := 0; + + declare + procedure Add_Choice (Choice : Iir; A_Type : Iir) + is + Ok : Boolean; + Expr : Iir; + begin + Ok := True; + if Type_Has_Bounds + and then Get_Type_Staticness (A_Type) = Locally + then + if Get_Kind (Choice) = Iir_Kind_Choice_By_Range then + Expr := Get_Choice_Range (Choice); + if Get_Expr_Staticness (Expr) = Locally then + Ok := Eval_Is_Range_In_Bound (Expr, A_Type, True); + end if; + else + Expr := Get_Choice_Expression (Choice); + if Get_Expr_Staticness (Expr) = Locally then + Ok := Eval_Is_In_Bound (Expr, A_Type); + end if; + end if; + if not Ok then + Error_Msg_Sem + (Disp_Node (Expr) & " out of index range", Choice); + end if; + end if; + if Ok then + Index := Index + 1; + Arr (Index) := Choice; + end if; + end Add_Choice; + begin + -- Fill the array. + El := Choice_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + -- Only named associations are considered. + raise Internal_Error; + when Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range => + Add_Choice (El, Sub_Type); + when Iir_Kind_Choice_By_Others => + null; + when others => + Error_Kind ("sem_choices_range(2)", El); + end case; + El := Get_Chain (El); + end loop; + end; + + -- Third: + -- Sort the list + Disc_Heap_Sort.Sort (Index); + + -- Set low and high bounds. + if Index > 0 then + Low := Get_Low (Arr (1)); + High := Get_High (Arr (Index)); + else + Low := Null_Iir; + High := Null_Iir; + end if; + + -- Fourth: + -- check for lacking choice (if no others) + -- check for overlapping choices + declare + -- Emit an error message for absence of choices in position L to H + -- of index type BT at location LOC. + procedure Error_No_Choice (Bt : Iir; + L, H : Iir_Int64; + Loc : Location_Type) + is + begin + if L = H then + Error_Msg_Sem ("no choice for " & Disp_Discrete (Bt, L), Loc); + else + Error_Msg_Sem + ("no choices for " & Disp_Discrete (Bt, L) + & " to " & Disp_Discrete (Bt, H), Loc); + end if; + end Error_No_Choice; + + -- Lowest and highest bounds. + Lb, Hb : Iir; + Pos : Iir_Int64; + Pos_Max : Iir_Int64; + E_Pos : Iir_Int64; + + Bt : Iir; + begin + Bt := Get_Base_Type (Sub_Type); + if not Is_Sub_Range + and then Get_Type_Staticness (Sub_Type) = Locally + and then Type_Has_Bounds + then + Get_Low_High_Limit (Get_Range_Constraint (Sub_Type), Lb, Hb); + else + Lb := Low; + Hb := High; + end if; + -- Checks all values between POS and POS_MAX are handled. + Pos := Eval_Pos (Lb); + Pos_Max := Eval_Pos (Hb); + if Pos > Pos_Max then + -- Null range. + Free (Arr); + return; + end if; + for I in 1 .. Index loop + E_Pos := Eval_Pos (Get_Low (Arr (I))); + if E_Pos > Pos_Max then + -- Choice out of bound, already handled. + Error_No_Choice (Bt, Pos, Pos_Max, Get_Location (Arr (I))); + -- Avoid other errors. + Pos := Pos_Max + 1; + exit; + end if; + if Pos < E_Pos and then not Has_Others then + Error_No_Choice (Bt, Pos, E_Pos - 1, Get_Location (Arr (I))); + elsif Pos > E_Pos then + if Pos + 1 = E_Pos then + Error_Msg_Sem + ("duplicate choice for " & Disp_Discrete (Bt, Pos), + Arr (I)); + else + Error_Msg_Sem + ("duplicate choices for " & Disp_Discrete (Bt, E_Pos) + & " to " & Disp_Discrete (Bt, Pos), Arr (I)); + end if; + end if; + Pos := Eval_Pos (Get_High (Arr (I))) + 1; + end loop; + if Pos /= Pos_Max + 1 and then not Has_Others then + Error_No_Choice (Bt, Pos, Pos_Max, Loc); + end if; + end; + + Free (Arr); + end Sem_Choices_Range; + +-- -- Find out the MIN and the MAX of an all named association choice list. +-- -- It also returns the number of elements associed (counting range). +-- procedure Sem_Find_Min_Max_Association_Choice_List +-- (List: Iir_Association_Choices_List; +-- Min: out Iir; +-- Max: out Iir; +-- Length: out natural) +-- is +-- Min_Res: Iir := null; +-- Max_Res: Iir := null; +-- procedure Update_With_Value (Val: Iir) is +-- begin +-- if Min_Res = null then +-- Min_Res := Val; +-- Max_Res := Val; +-- elsif Get_Value (Val) < Get_Value (Min_Res) then +-- Min_Res := Val; +-- elsif Get_Value (Val) > Get_Value (Max_Res) then +-- Max_Res := Val; +-- end if; +-- end Update_With_Value; + +-- Number_Elements: Natural; + +-- procedure Update (Choice: Iir) is +-- Left, Right: Iir; +-- Expr: Iir; +-- begin +-- case Get_Kind (Choice) is +-- when Iir_Kind_Choice_By_Expression => +-- Update_With_Value (Get_Expression (Choice)); +-- Number_Elements := Number_Elements + 1; +-- when Iir_Kind_Choice_By_Range => +-- Expr := Get_Expression (Choice); +-- Left := Get_Left_Limit (Expr); +-- Right := Get_Right_Limit (Expr); +-- Update_With_Value (Left); +-- Update_With_Value (Right); +-- -- There can't be null range. +-- case Get_Direction (Expr) is +-- when Iir_To => +-- Number_Elements := Number_Elements + +-- Natural (Get_Value (Right) - Get_Value (Left) + 1); +-- when Iir_Downto => +-- Number_Elements := Number_Elements + +-- Natural (Get_Value (Left) - Get_Value (Right) + 1); +-- end case; +-- when others => +-- Error_Kind ("sem_find_min_max_association_choice_list", Choice); +-- end case; +-- end Update; + +-- El: Iir; +-- Sub_List: Iir_Association_Choices_List; +-- Sub_El: Iir; +-- begin +-- Number_Elements := 0; +-- for I in Natural loop +-- El := Get_Nth_Element (List, I); +-- exit when El = null; +-- case Get_Kind (El) is +-- when Iir_Kind_Choice_By_List => +-- Sub_List := Get_Choice_List (El); +-- for J in Natural loop +-- Sub_El := Get_Nth_Element (Sub_List, J); +-- exit when Sub_El = null; +-- Update (Sub_El); +-- end loop; +-- when others => +-- Update (El); +-- end case; +-- end loop; +-- Min := Min_Res; +-- Max := Max_Res; +-- Length := Number_Elements; +-- end Sem_Find_Min_Max_Association_Choice_List; + + -- Perform semantisation on a (sub)aggregate AGGR, which is of type + -- A_TYPE. + -- return FALSE is case of failure + function Sem_Record_Aggregate (Aggr: Iir_Aggregate; A_Type: Iir) + return boolean + is + 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 (0 .. Get_Nbr_Elements (El_List) - 1); + Ok : Boolean; + + -- Add a choice for element REC_EL. + -- Checks the element is not already associated. + -- Checks type of expression is compatible with type of element. + procedure Add_Match (El : Iir; Rec_El : Iir_Element_Declaration) + is + Ass_Type : Iir; + Pos : constant Natural := Natural (Get_Element_Position (Rec_El)); + begin + if Matches (Pos) /= Null_Iir then + Error_Msg_Sem + (Disp_Node (Matches (Pos)) & " was already associated", El); + Ok := False; + return; + end if; + Matches (Pos) := El; + + -- LRM 7.3.2.1 Record aggregates + -- An element association with more than once choice, [...], is + -- only allowed if the elements specified are all of the same type. + Ass_Type := Get_Type (Rec_El); + if El_Type = Null_Iir then + El_Type := Ass_Type; + elsif not Are_Types_Compatible (El_Type, Ass_Type) then + Error_Msg_Sem ("elements are not of the same type", El); + Ok := False; + end if; + end Add_Match; + + -- Semantize a simple choice: extract the record element corresponding + -- to the expression, and create a choice_by_name. + -- FIXME: should mutate the node. + function Sem_Simple_Choice (Ass : Iir) return Iir + is + N_El : Iir; + Expr : Iir; + Aggr_El : Iir_Element_Declaration; + begin + Expr := Get_Choice_Expression (Ass); + if Get_Kind (Expr) /= Iir_Kind_Simple_Name then + Error_Msg_Sem ("element association must be a simple name", Ass); + Ok := False; + return Ass; + end if; + 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); + Ok := False; + return Ass; + end if; + + N_El := Create_Iir (Iir_Kind_Choice_By_Name); + Location_Copy (N_El, Ass); + Set_Choice_Name (N_El, Aggr_El); + Set_Associated_Expr (N_El, Get_Associated_Expr (Ass)); + Set_Associated_Chain (N_El, Get_Associated_Chain (Ass)); + Set_Chain (N_El, Get_Chain (Ass)); + Set_Same_Alternative_Flag (N_El, Get_Same_Alternative_Flag (Ass)); + + Xref_Ref (Expr, Aggr_El); + Free_Iir (Ass); + Free_Iir (Expr); + Add_Match (N_El, Aggr_El); + return N_El; + end Sem_Simple_Choice; + + Assoc_Chain : Iir; + El, Prev_El : Iir; + Expr: Iir; + Has_Named : Boolean; + Rec_El_Index : Natural; + Value_Staticness : Iir_Staticness; + begin + Ok := True; + Assoc_Chain := Get_Association_Choices_Chain (Aggr); + Matches := (others => Null_Iir); + Value_Staticness := Locally; + + El_Type := Null_Iir; + Has_Named := False; + Rec_El_Index := 0; + Prev_El := Null_Iir; + El := Assoc_Chain; + while El /= Null_Iir loop + Expr := Get_Associated_Expr (El); + + -- If there is an associated expression with the choice, then the + -- choice is a new alternative, and has no expected type. + if Expr /= Null_Iir then + El_Type := Null_Iir; + end if; + + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + if Has_Named then + Error_Msg_Sem ("positional association after named one", El); + Ok := False; + elsif Rec_El_Index > Matches'Last then + Error_Msg_Sem ("too many elements", El); + exit; + else + 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; + El := Sem_Simple_Choice (El); + -- This creates a choice_by_name, which replaces the + -- choice_by_expression. + if Prev_El = Null_Iir then + Set_Association_Choices_Chain (Aggr, El); + else + Set_Chain (Prev_El, El); + end if; + when Iir_Kind_Choice_By_Others => + Has_Named := True; + if Get_Chain (El) /= Null_Iir then + Error_Msg_Sem + ("choice others must be the last alternative", El); + end if; + declare + Found : Boolean := False; + begin + for I in Matches'Range loop + if Matches (I) = Null_Iir then + Add_Match (El, Get_Nth_Element (El_List, I)); + Found := True; + end if; + end loop; + if not Found then + Error_Msg_Sem ("no element for choice others", El); + Ok := False; + end if; + end; + when others => + Error_Kind ("sem_record_aggregate", El); + end case; + + -- Semantize the expression associated. + if Expr /= Null_Iir then + if El_Type /= Null_Iir then + Expr := Sem_Expression (Expr, El_Type); + if Expr /= Null_Iir then + Set_Associated_Expr (El, Eval_Expr_If_Static (Expr)); + Value_Staticness := Min (Value_Staticness, + Get_Expr_Staticness (Expr)); + else + Ok := False; + end if; + else + -- This case is not possible unless there is an error. + if Ok then + raise Internal_Error; + end if; + end if; + end if; + + Prev_El := El; + El := Get_Chain (El); + end loop; + + -- Check for missing associations. + for I in Matches'Range loop + if Matches (I) = Null_Iir then + Error_Msg_Sem + ("no value for " & Disp_Node (Get_Nth_Element (El_List, I)), + Aggr); + Ok := False; + end if; + end loop; + Set_Value_Staticness (Aggr, Value_Staticness); + Set_Expr_Staticness (Aggr, Min (Globally, Value_Staticness)); + return Ok; + end Sem_Record_Aggregate; + + -- Information for each dimension of an aggregate. + type Array_Aggr_Info is record + -- False if one sub-aggregate has no others choices. + -- If FALSE, the dimension is constrained. + Has_Others : Boolean := True; + + -- True if one sub-aggregate is by named/by position. + Has_Named : Boolean := False; + Has_Positional : Boolean := False; + + -- True if one sub-aggregate is dynamic. + Has_Dynamic : Boolean := False; + + -- LOW and HIGH limits for the dimension. + Low : Iir := Null_Iir; + High : Iir := Null_Iir; + + -- Minimum length of the dimension. This is a minimax. + Min_Length : Natural := 0; + + -- If not NULL_IIR, this is the bounds of the dimension. + -- If every dimension has bounds, then the aggregate is constrained. + Index_Subtype : Iir := Null_Iir; + + -- True if there is an error. + Error : Boolean := False; + end record; + + type Array_Aggr_Info_Arr is array (Natural range <>) of Array_Aggr_Info; + + -- Semantize an array aggregate AGGR of *base type* A_TYPE. + -- The type of the array is computed into A_SUBTYPE. + -- DIM is the dimension index in A_TYPE. + -- Return FALSE in case of error. + procedure Sem_Array_Aggregate_Type_1 (Aggr: Iir; + A_Type: Iir; + Infos : in out Array_Aggr_Info_Arr; + Constrained : Boolean; + Dim: Natural) + is + Assoc_Chain : Iir; + Choice: Iir; + Is_Positional: Tri_State_Type; + Has_Positional_Choice: Boolean; + Low, High : Iir; + Index_List : Iir_List; + Has_Others : Boolean; + + Len : Natural; + + -- Type of the index (this is also the type of the choices). + Index_Type : Iir; + + --Index_Subtype : Iir; + Index_Subtype_Constraint : Iir_Range_Expression; + Index_Constraint : Iir_Range_Expression; -- FIXME: 'range. + Choice_Staticness : Iir_Staticness; + + Info : Array_Aggr_Info renames Infos (Dim); + begin + Index_List := Get_Index_Subtype_List (A_Type); + Index_Type := Get_Index_Type (Index_List, Dim - 1); + + -- Sem choices. + case Get_Kind (Aggr) is + when Iir_Kind_Aggregate => + Assoc_Chain := Get_Association_Choices_Chain (Aggr); + Sem_Choices_Range (Assoc_Chain, Index_Type, not Constrained, False, + Get_Location (Aggr), Low, High); + Set_Association_Choices_Chain (Aggr, Assoc_Chain); + + -- Update infos. + if Low /= Null_Iir + and then (Info.Low = Null_Iir + or else Eval_Pos (Low) < Eval_Pos (Info.Low)) + then + Info.Low := Low; + end if; + if High /= Null_Iir + and then (Info.High = Null_Iir + or else Eval_Pos (High) > Eval_Pos (Info.High)) + then + Info.High := High; + end if; + + -- Determine if the aggregate is positionnal or named; + -- and compute choice staticness. + Is_Positional := Unknown; + Choice_Staticness := Locally; + Has_Positional_Choice := False; + Has_Others := False; + Len := 0; + Choice := Assoc_Chain; + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_Expression => + Is_Positional := False; + Choice_Staticness := + Iirs.Min (Choice_Staticness, + Get_Choice_Staticness (Choice)); + -- FIXME: not true for range. + Len := Len + 1; + when Iir_Kind_Choice_By_None => + Has_Positional_Choice := True; + Len := Len + 1; + when Iir_Kind_Choice_By_Others => + if not Constrained then + Error_Msg_Sem ("'others' choice not allowed for an " + & "aggregate in this context", Aggr); + Infos (Dim).Error := True; + return; + end if; + Has_Others := True; + when others => + Error_Kind ("sem_array_aggregate_type", Choice); + end case; + -- LRM93 7.3.2.2 + -- Apart from the final element with the single choice + -- OTHERS, the rest (if any) of the element + -- associations of an array aggregate must be either + -- all positionnal or all named. + if Has_Positional_Choice then + if Is_Positional = False then + -- The error has already been emited + -- by sem_choices_range. + Infos (Dim).Error := True; + return; + end if; + Is_Positional := True; + end if; + Choice := Get_Chain (Choice); + end loop; + + Info.Min_Length := Integer'Max (Info.Min_Length, Len); + + if Choice_Staticness = Unknown then + -- This is possible when a choice is erroneous. + Infos (Dim).Error := True; + return; + end if; + + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + Len := Sem_String_Literal + (Aggr, Get_Base_Type (Get_Element_Subtype (A_Type))); + Assoc_Chain := Null_Iir; + Info.Min_Length := Integer'Max (Info.Min_Length, Len); + Is_Positional := True; + Has_Others := False; + Choice_Staticness := Locally; + + when others => + Error_Kind ("sem_array_aggregate_type_1", Aggr); + end case; + + if Is_Positional = True then + Info.Has_Positional := True; + end if; + if Is_Positional = False then + Info.Has_Named := True; + end if; + if not Has_Others then + Info.Has_Others := False; + end if; + + -- LRM93 7.3.2.2 + -- A named association of an array aggregate is allowed to have a choice + -- that is not locally static, [or likewise a choice that is a null + -- range], only if the aggregate includes a single element association + -- and this element association has a single choice. + if Is_Positional = False and then Choice_Staticness /= Locally then + Choice := Assoc_Chain; + if not Is_Chain_Length_One (Assoc_Chain) or else + (Get_Kind (Choice) /= Iir_Kind_Choice_By_Expression + and then Get_Kind (Choice) /= Iir_Kind_Choice_By_Range) + then + Error_Msg_Sem ("non-locally static choice for an aggregate is " + & "allowed only if only choice", Aggr); + Infos (Dim).Error := True; + return; + end if; + Info.Has_Dynamic := True; + end if; + + -- Compute bounds of the index if there is no index subtype. + if Info.Index_Subtype = Null_Iir and then Has_Others = False then + -- LRM93 7.3.2.2 + -- the direction of the index subtype of the aggregate is that of the + -- index subtype of the base type of the aggregate. + + if Is_Positional = True then + -- LRM93 7.3.2.2 + -- For a positionnal aggregate, [...] the leftmost bound is given + -- by S'LEFT where S is the index subtype of the base type of the + -- array; [...] the rightmost bound is determined by the direction + -- of the index subtype and the number of element. + if Get_Type_Staticness (Index_Type) = Locally then + Info.Index_Subtype := Create_Range_Subtype_By_Length + (Index_Type, Iir_Int64 (Len), Get_Location (Aggr)); + end if; + else + -- Create an index subtype. + case Get_Kind (Index_Type) is + when Iir_Kind_Integer_Subtype_Definition => + Info.Index_Subtype := Create_Iir (Get_Kind (Index_Type)); + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Info.Index_Subtype := + Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + when others => + Error_Kind ("sem_array_aggregate_type2", Index_Type); + end case; + Location_Copy (Info.Index_Subtype, Aggr); + 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_Expr_Staticness (Index_Subtype_Constraint, Choice_Staticness); + + -- LRM93 7.3.2.2 + -- For an aggregate that has named associations, the leftmost and + -- the rightmost bounds are determined by the direction of the + -- index subtype of the aggregate and the smallest and largest + -- choice given. + if Choice_Staticness = Locally then + if Low = Null_Iir or High = Null_Iir then + -- Avoid error propagation. + Set_Range_Constraint (Info.Index_Subtype, + 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); + Set_Right_Limit (Index_Subtype_Constraint, High); + when Iir_Downto => + Set_Left_Limit (Index_Subtype_Constraint, High); + Set_Right_Limit (Index_Subtype_Constraint, Low); + end case; + end if; + else + -- Dynamic aggregate. + declare + Expr : Iir; + Choice : Iir; + begin + Choice := Assoc_Chain; + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Expression => + Expr := Get_Choice_Expression (Choice); + 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 => + Expr := Get_Choice_Range (Choice); + Set_Range_Constraint (Info.Index_Subtype, Expr); + -- FIXME: avoid allocation-free. + Free_Iir (Index_Subtype_Constraint); + when others => + raise Internal_Error; + end case; + end; + end if; + end if; + --Set_Type_Staticness + -- (A_Subtype, Iirs.Min (Get_Type_Staticness (A_Subtype), + -- Get_Type_Staticness (Index_Subtype))); + --Append_Element (Get_Index_List (A_Subtype), Index_Subtype); + elsif Has_Others = False then + -- Check the subaggregate bounds are the same. + if Is_Positional = True then + if Eval_Pos (Eval_Discrete_Range_Left (Get_Range_Constraint + (Info.Index_Subtype))) + /= Eval_Pos (Eval_Discrete_Range_Left (Get_Range_Constraint + (Index_Type))) + then + Error_Msg_Sem ("subaggregate bounds mismatch", Aggr); + else + if Eval_Discrete_Type_Length (Info.Index_Subtype) + /= Iir_Int64 (Len) + then + Error_Msg_Sem ("subaggregate length mismatch", Aggr); + end if; + end if; + else + declare + L, H : Iir; + begin + Get_Low_High_Limit + (Get_Range_Constraint (Info.Index_Subtype), L, H); + if Eval_Pos (L) /= Eval_Pos (Low) + or else Eval_Pos (H) /= Eval_Pos (H) + then + Error_Msg_Sem ("subagregate bounds mismatch", Aggr); + end if; + end; + end if; + end if; + + -- Semantize aggregate elements. + if Dim = Get_Nbr_Elements (Index_List) then + -- A type has been found for AGGR, semantize AGGR as if it was + -- an aggregate with a subtype. + + if Get_Kind (Aggr) = Iir_Kind_Aggregate then + -- LRM93 7.3.2.2: + -- the expression of each element association must be of the + -- element type. + declare + El : Iir; + Element_Type : Iir; + Expr : Iir; + Value_Staticness : Iir_Staticness; + Expr_Staticness : Iir_Staticness; + begin + Element_Type := Get_Element_Subtype (A_Type); + El := Assoc_Chain; + Value_Staticness := Locally; + while El /= Null_Iir loop + Expr := Get_Associated_Expr (El); + if Expr /= Null_Iir then + Expr := Sem_Expression (Expr, Element_Type); + if Expr /= Null_Iir then + Expr_Staticness := Get_Expr_Staticness (Expr); + Set_Expr_Staticness + (Aggr, Min (Get_Expr_Staticness (Aggr), + Expr_Staticness)); + Set_Associated_Expr (El, Eval_Expr_If_Static (Expr)); + + -- FIXME: handle name/others in translate. + -- if Get_Kind (Expr) = Iir_Kind_Aggregate then + -- Expr_Staticness := Get_Value_Staticness (Expr); + -- end if; + Value_Staticness := Min (Value_Staticness, + Expr_Staticness); + else + Info.Error := True; + end if; + end if; + El := Get_Chain (El); + end loop; + Set_Value_Staticness (Aggr, Value_Staticness); + end; + end if; + else + declare + Assoc : Iir; + Value_Staticness : Iir_Staticness; + begin + Assoc := Null_Iir; + Choice := Assoc_Chain; + Value_Staticness := Locally; + while Choice /= Null_Iir loop + if Get_Associated_Expr (Choice) /= Null_Iir then + Assoc := Get_Associated_Expr (Choice); + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Aggregate => + Sem_Array_Aggregate_Type_1 + (Assoc, A_Type, Infos, Constrained, Dim + 1); + Value_Staticness := Min (Value_Staticness, + Get_Value_Staticness (Assoc)); + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + if Dim + 1 = Get_Nbr_Elements (Index_List) then + Sem_Array_Aggregate_Type_1 + (Assoc, A_Type, Infos, Constrained, Dim + 1); + else + Error_Msg_Sem + ("string literal not allowed here", Assoc); + Infos (Dim + 1).Error := True; + end if; + when others => + Error_Msg_Sem ("sub-aggregate expected", Assoc); + Infos (Dim + 1).Error := True; + end case; + Choice := Get_Chain (Choice); + end loop; + Set_Value_Staticness (Aggr, Value_Staticness); + end; + end if; + end Sem_Array_Aggregate_Type_1; + + -- Semantize an array aggregate whose type is AGGR_TYPE. + -- If CONSTRAINED is true, then the aggregate appears in one of the + -- context and can have an 'others' choice. + -- If CONSTRAINED is false, the aggregate can not have an 'others' choice. + -- Create a subtype for this aggregate. + -- Return NULL_IIR in case of error, or AGGR if not. + function Sem_Array_Aggregate_Type + (Aggr : Iir; Aggr_Type : Iir; Constrained : Boolean) + return Iir + is + A_Subtype: Iir; + Base_Type : Iir; + Index_List : constant Iir_List := Get_Index_Subtype_List (Aggr_Type); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); + Infos : Array_Aggr_Info_Arr (1 .. Nbr_Dim); + Aggr_Constrained : Boolean; + Info, Prev_Info : Iir_Aggregate_Info; + begin + -- Semantize the aggregate. + Sem_Array_Aggregate_Type_1 (Aggr, Aggr_Type, Infos, Constrained, 1); + + Aggr_Constrained := True; + for I in Infos'Range loop + -- Return now in case of error. + if Infos (I).Error then + return Null_Iir; + end if; + if Infos (I).Index_Subtype = Null_Iir then + Aggr_Constrained := False; + end if; + end loop; + Base_Type := Get_Base_Type (Aggr_Type); + + -- FIXME: should reuse AGGR_TYPE iff AGGR_TYPE is fully constrained + -- and statically match the subtype of the aggregate. + if Aggr_Constrained then + A_Subtype := Create_Array_Subtype (Base_Type, Get_Location (Aggr)); + for I in Infos'Range loop + Append_Element (Get_Index_Subtype_List (A_Subtype), + Infos (I).Index_Subtype); + Set_Type_Staticness + (A_Subtype, + 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); + Set_Literal_Subtype (Aggr, A_Subtype); + else + -- Free unused indexes subtype. + for I in Infos'Range loop + declare + St : constant Iir := Infos (I).Index_Subtype; + begin + if St /= Null_Iir then + Free_Iir (Get_Range_Constraint (St)); + Free_Iir (St); + end if; + end; + end loop; + end if; + + Prev_Info := Null_Iir; + for I in Infos'Range loop + -- Create info and link. + Info := Create_Iir (Iir_Kind_Aggregate_Info); + if I = 1 then + Set_Aggregate_Info (Aggr, Info); + else + Set_Sub_Aggregate_Info (Prev_Info, Info); + end if; + Prev_Info := Info; + + -- Fill info. + Set_Aggr_Dynamic_Flag (Info, Infos (I).Has_Dynamic); + Set_Aggr_Named_Flag (Info, Infos (I).Has_Named); + Set_Aggr_Low_Limit (Info, Infos (I).Low); + Set_Aggr_High_Limit (Info, Infos (I).High); + Set_Aggr_Min_Length (Info, Iir_Int32 (Infos (I).Min_Length)); + Set_Aggr_Others_Flag (Info, Infos (I).Has_Others); + end loop; + return Aggr; + end Sem_Array_Aggregate_Type; + + -- Semantize aggregate EXPR whose type is expected to be A_TYPE. + -- A_TYPE cannot be null_iir (this case is handled in sem_expression_ov) + function Sem_Aggregate (Expr: Iir_Aggregate; A_Type: Iir) + return Iir_Aggregate is + begin + pragma Assert (A_Type /= Null_Iir); + + -- An aggregate is at most globally static. + Set_Expr_Staticness (Expr, Globally); + + 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, 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 + | Iir_Kind_Record_Subtype_Definition => + if not Sem_Record_Aggregate (Expr, A_Type) then + return Null_Iir; + end if; + return Expr; + when others => + Error_Msg_Sem ("type " & Disp_Node (A_Type) & " is not composite", + Expr); + return Null_Iir; + end case; + end Sem_Aggregate; + + -- Transform LIT into a physical_literal. + -- LIT can be either a not semantized physical literal or + -- a simple name that is a physical unit. In the later case, a physical + -- literal is created. + function Sem_Physical_Literal (Lit: Iir) return Iir + is + Unit_Name : Iir; + Unit_Type : Iir; + Res: Iir; + begin + case Get_Kind (Lit) is + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal => + Unit_Name := Get_Unit_Name (Lit); + Res := Lit; + when Iir_Kind_Unit_Declaration => + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Location_Copy (Res, Lit); + Set_Value (Res, 1); + Unit_Name := Null_Iir; + raise Program_Error; + when Iir_Kinds_Denoting_Name => + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Location_Copy (Res, Lit); + Set_Value (Res, 1); + Unit_Name := Lit; + when others => + Error_Kind ("sem_physical_literal", Lit); + end case; + Unit_Name := Sem_Denoting_Name (Unit_Name); + if Get_Kind (Get_Named_Entity (Unit_Name)) /= Iir_Kind_Unit_Declaration + then + Error_Class_Match (Unit_Name, "unit"); + Set_Named_Entity (Unit_Name, Create_Error_Name (Unit_Name)); + end if; + Set_Unit_Name (Res, Unit_Name); + Unit_Type := Get_Type (Unit_Name); + Set_Type (Res, Unit_Type); + + -- LRM93 7.4.2 + -- 1. a literal of type TIME. + -- + -- LRM93 7.4.1 + -- 1. a literal of any type other than type TIME; + Set_Expr_Staticness (Res, Get_Expr_Staticness (Unit_Name)); + --Eval_Check_Constraints (Res); + return Res; + end Sem_Physical_Literal; + + -- Semantize an allocator by expression or an allocator by subtype. + function Sem_Allocator (Expr : Iir; A_Type : Iir) return Iir + is + Arg: Iir; + Arg_Type : Iir; + begin + Set_Expr_Staticness (Expr, None); + + Arg_Type := Get_Allocator_Designated_Type (Expr); + + if Arg_Type = Null_Iir then + -- Expression was not analyzed. + case Iir_Kinds_Allocator (Get_Kind (Expr)) is + when Iir_Kind_Allocator_By_Expression => + Arg := Get_Expression (Expr); + pragma Assert (Get_Kind (Arg) = Iir_Kind_Qualified_Expression); + Arg := Sem_Expression (Arg, Null_Iir); + if Arg = Null_Iir then + return Null_Iir; + end if; + Check_Read (Arg); + Set_Expression (Expr, Arg); + Arg_Type := Get_Type (Arg); + when Iir_Kind_Allocator_By_Subtype => + Arg := Get_Subtype_Indication (Expr); + Arg := Sem_Types.Sem_Subtype_Indication (Arg); + Set_Subtype_Indication (Expr, Arg); + Arg := Get_Type_Of_Subtype_Indication (Arg); + if Arg = Null_Iir then + return Null_Iir; + end if; + -- LRM93 7.3.6 + -- If an allocator includes a subtype indication and if the + -- 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 Is_Fully_Constrained_Type (Arg) then + Error_Msg_Sem + ("allocator of unconstrained " & + Disp_Node (Arg) & " is not allowed", Expr); + end if; + -- LRM93 7.3.6 + -- A subtype indication that is part of an allocator must + -- not include a resolution function. + if Is_Anonymous_Type_Definition (Arg) + and then Get_Resolution_Indication (Arg) /= Null_Iir + then + Error_Msg_Sem ("subtype indication must not include" + & " a resolution function", Expr); + end if; + Arg_Type := Arg; + end case; + Set_Allocator_Designated_Type (Expr, Arg_Type); + end if; + + -- LRM 7.3.6 Allocators + -- The type of the access value returned by an allocator must be + -- determinable solely from the context, but using the fact that the + -- value returned is of an access type having the named designated + -- type. + if A_Type = Null_Iir then + -- Type of the context is not yet known. + return Expr; + else + if not Is_Allocator_Type (A_Type, Expr) then + if Get_Kind (A_Type) /= Iir_Kind_Access_Type_Definition then + if Get_Kind (A_Type) /= Iir_Kind_Error then + Error_Msg_Sem ("expected type is not an access type", Expr); + end if; + else + Not_Match (Expr, A_Type); + end if; + return Null_Iir; + end if; + Set_Type (Expr, A_Type); + return Expr; + end if; + end Sem_Allocator; + + procedure Check_Read_Aggregate (Aggr : Iir) + is + pragma Unreferenced (Aggr); + begin + -- FIXME: todo. + null; + end Check_Read_Aggregate; + + -- Check EXPR can be read. + procedure Check_Read (Expr : Iir) + is + Obj : Iir; + begin + if Expr = Null_Iir then + return; + end if; + + Obj := Expr; + loop + case Get_Kind (Obj) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Attribute_Value + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Guard_Signal_Declaration => + return; + when Iir_Kinds_Quantity_Declaration => + return; + when Iir_Kind_File_Declaration + | Iir_Kind_Interface_File_Declaration => + -- LRM 4.3.2 Interface declarations + -- The value of an object is said to be read [...] + -- - When the object is a file and a READ operation is + -- performed on the file. + return; + when Iir_Kind_Object_Alias_Declaration => + Obj := Get_Name (Obj); + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Variable_Declaration => + case Get_Mode (Obj) is + when Iir_In_Mode + | Iir_Inout_Mode + | Iir_Buffer_Mode => + null; + when Iir_Out_Mode + | Iir_Linkage_Mode => + Error_Msg_Sem (Disp_Node (Obj) & " cannot be read", Expr); + when Iir_Unknown_Mode => + raise Internal_Error; + end case; + return; + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal + | Iir_Kind_Character_Literal + | Iir_Kind_Integer_Literal + | Iir_Kind_Floating_Point_Literal + | Iir_Kind_Null_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Overflow_Literal => + return; + when Iir_Kinds_Monadic_Operator + | Iir_Kinds_Dyadic_Operator + | Iir_Kind_Function_Call => + return; + when Iir_Kind_Parenthesis_Expression => + Obj := Get_Expression (Obj); + when Iir_Kind_Qualified_Expression => + return; + when Iir_Kind_Type_Conversion + | Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Dereference + | Iir_Kind_Attribute_Name => + return; + when Iir_Kinds_Scalar_Type_Attribute + | Iir_Kinds_Type_Attribute + | Iir_Kinds_Array_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute + | Iir_Kinds_Name_Attribute + | Iir_Kinds_Signal_Attribute + | Iir_Kinds_Signal_Value_Attribute => + return; + when Iir_Kind_Aggregate => + Check_Read_Aggregate (Obj); + return; + when Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element => + -- FIXME: speed up using Base_Name + -- Obj := Get_Base_Name (Obj); + Obj := Get_Prefix (Obj); + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Obj := Get_Named_Entity (Obj); + when Iir_Kind_Error => + return; + when others => + Error_Kind ("check_read", Obj); + end case; + end loop; + end Check_Read; + + procedure Check_Update (Expr : Iir) + is + pragma Unreferenced (Expr); + begin + null; + end Check_Update; + + -- Emit an error if the constant EXPR is deferred and cannot be used in + -- the current context. + procedure Check_Constant_Restriction (Expr : Iir; Loc : Iir) + is + Lib : Iir; + Cur_Lib : Iir; + begin + -- LRM93 §2.6 + -- Within a package declaration that contains the declaration + -- of a deferred constant, and within the body of that package, + -- before the end of the corresponding full declaration, the + -- use of a name that denotes the deferred constant is only + -- allowed in the default expression for a local generic, + -- local port or formal parameter. + if Get_Deferred_Declaration_Flag (Expr) = False + or else Get_Deferred_Declaration (Expr) /= Null_Iir + then + -- The constant declaration is not deferred + -- or the it has been fully declared. + return; + end if; + + Lib := Get_Parent (Expr); + if Get_Kind (Lib) = Iir_Kind_Design_Unit then + Lib := Get_Library_Unit (Lib); + -- FIXME: the parent of the constant is the library unit or + -- the design unit ? + raise Internal_Error; + end if; + Cur_Lib := Get_Library_Unit (Sem.Get_Current_Design_Unit); + if (Get_Kind (Cur_Lib) = Iir_Kind_Package_Declaration + and then Lib = Cur_Lib) + or else (Get_Kind (Cur_Lib) = Iir_Kind_Package_Body + and then Get_Package (Cur_Lib) = Lib) + then + Error_Msg_Sem ("invalid use of a deferred constant", Loc); + end if; + end Check_Constant_Restriction; + + -- Set semantic to EXPR. + -- Replace simple_name with the referenced node, + -- Set type to nodes, + -- Resolve overloading + + -- If A_TYPE is not null, then EXPR must be of type A_TYPE. + -- Return null in case of error. + function Sem_Expression_Ov (Expr: Iir; A_Type1: Iir) return Iir + is + A_Type: Iir; + begin +-- -- Avoid to run sem_expression_ov when a node was already semantized +-- -- except to resolve overload. +-- if Get_Type (Expr) /= Null_Iir then +-- -- EXPR was already semantized. +-- if A_Type1 = null or else not Is_Overload_List (Get_Type (Expr)) then +-- -- This call to sem_expression_ov do not add any informations. +-- Check_Restrictions (Expr, Restriction); +-- return Expr; +-- end if; +-- -- This is an overload list that will be reduced. +-- end if; + + -- A_TYPE must be a type definition and not a subtype. + if A_Type1 /= Null_Iir then + A_Type := Get_Base_Type (A_Type1); + if A_Type /= A_Type1 then + raise Internal_Error; + end if; + else + A_Type := Null_Iir; + end if; + + case Get_Kind (Expr) is + when Iir_Kind_Selected_Name + | Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Selected_By_All_Name + | Iir_Kind_Attribute_Name => + declare + E : Iir; + begin + E := Get_Named_Entity (Expr); + if E = Null_Iir then + Sem_Name (Expr); + E := Get_Named_Entity (Expr); + if E = Null_Iir then + raise Internal_Error; + end if; + end if; + if E = Error_Mark then + return Null_Iir; + end if; + if Get_Kind (E) = Iir_Kind_Constant_Declaration + and then not Deferred_Constant_Allowed + then + Check_Constant_Restriction (E, Expr); + end if; + E := Name_To_Expression (Expr, A_Type); + return E; + end; + + when Iir_Kinds_Monadic_Operator => + return Sem_Operator (Expr, A_Type, 1); + + when Iir_Kinds_Dyadic_Operator => + return Sem_Operator (Expr, A_Type, 2); + + when Iir_Kind_Enumeration_Literal + | Iir_Kinds_Object_Declaration => + -- All these case have already a type. + if Get_Type (Expr) = Null_Iir then + return Null_Iir; + end if; + if A_Type /= Null_Iir + and then not Are_Basetypes_Compatible + (A_Type, Get_Base_Type (Get_Type (Expr))) + then + Not_Match (Expr, A_Type); + return Null_Iir; + end if; + return Expr; + + when Iir_Kind_Integer_Literal => + Set_Expr_Staticness (Expr, Locally); + if A_Type = Null_Iir then + Set_Type (Expr, Convertible_Integer_Type_Definition); + return Expr; + elsif Get_Kind (A_Type) = Iir_Kind_Integer_Type_Definition then + Set_Type (Expr, A_Type); + return Expr; + else + Not_Match (Expr, A_Type); + return Null_Iir; + end if; + + when Iir_Kind_Floating_Point_Literal => + Set_Expr_Staticness (Expr, Locally); + if A_Type = Null_Iir then + Set_Type (Expr, Convertible_Real_Type_Definition); + return Expr; + elsif Get_Kind (A_Type) = Iir_Kind_Floating_Type_Definition then + Set_Type (Expr, A_Type); + return Expr; + else + Not_Match (Expr, A_Type); + return Null_Iir; + end if; + + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Unit_Declaration => + declare + Res: Iir; + begin + Res := Sem_Physical_Literal (Expr); + if Res = Null_Iir then + return Null_Iir; + end if; + if A_Type /= Null_Iir and then Get_Type (Res) /= A_Type then + Not_Match (Res, A_Type); + return Null_Iir; + end if; + return Res; + end; + + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + -- LRM93 7.3.1 Literals + -- The type of a string or bit string literal must be + -- determinable solely from the context in whcih the literal + -- appears, excluding the literal itself [...] + if A_Type = Null_Iir then + return Expr; + end if; + + if not Is_String_Literal_Type (A_Type, Expr) then + Not_Match (Expr, A_Type); + return Null_Iir; + else + Replace_Type (Expr, A_Type); + Sem_String_Literal (Expr); + return Expr; + end if; + + when Iir_Kind_Null_Literal => + Set_Expr_Staticness (Expr, Locally); + -- GHDL: the LRM doesn't explain how the type of NULL is + -- determined. Use the same rule as string or aggregates. + if A_Type = Null_Iir then + return Expr; + end if; + if not Is_Null_Literal_Type (A_Type) then + Error_Msg_Sem ("null literal can only be access type", Expr); + return Null_Iir; + else + Set_Type (Expr, A_Type); + return Expr; + end if; + + when Iir_Kind_Aggregate => + -- LRM93 7.3.2 Aggregates + -- The type of an aggregate must be determinable solely from the + -- context in which the aggregate appears, excluding the aggregate + -- itself but [...] + if A_Type = Null_Iir then + return Expr; + else + return Sem_Aggregate (Expr, A_Type); + end if; + + when Iir_Kind_Parenthesis_Expression => + declare + Sub_Expr : Iir; + begin + Sub_Expr := Get_Expression (Expr); + Sub_Expr := Sem_Expression_Ov (Sub_Expr, A_Type1); + if Sub_Expr = Null_Iir then + return Null_Iir; + end if; + Set_Expression (Expr, Sub_Expr); + Set_Type (Expr, Get_Type (Sub_Expr)); + Set_Expr_Staticness (Expr, Get_Expr_Staticness (Sub_Expr)); + return Expr; + end; + + when Iir_Kind_Qualified_Expression => + declare + N_Type: Iir; + Res: Iir; + begin + N_Type := Sem_Type_Mark (Get_Type_Mark (Expr)); + Set_Type_Mark (Expr, N_Type); + N_Type := Get_Type (N_Type); + Set_Type (Expr, N_Type); + if A_Type /= Null_Iir + and then not Are_Types_Compatible (A_Type, N_Type) + then + Not_Match (Expr, A_Type); + return Null_Iir; + end if; + Res := Sem_Expression (Get_Expression (Expr), N_Type); + if Res = Null_Iir then + return Null_Iir; + end if; + Check_Read (Res); + Set_Expression (Expr, Res); + Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Res), + Get_Type_Staticness (N_Type))); + return Expr; + end; + + when Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype => + return Sem_Allocator (Expr, A_Type); + + when Iir_Kinds_Procedure_Declaration => + Error_Msg_Sem + (Disp_Node (Expr) & " cannot be used as an expression", Expr); + return Null_Iir; + + when others => + Error_Kind ("sem_expression_ov", Expr); + return Null_Iir; + end case; + end Sem_Expression_Ov; + + -- If A_TYPE is not null, then EXPR must be of type A_TYPE. + -- Return null in case of error. + function Sem_Expression (Expr: Iir; A_Type: Iir) return Iir + is + A_Type1: Iir; + Res: Iir; + Expr_Type : Iir; + begin + if Check_Is_Expression (Expr, Expr) = Null_Iir then + return Null_Iir; + end if; + + -- Can't try to run sem_expression_ov when a node was already semantized + Expr_Type := Get_Type (Expr); + if Expr_Type /= Null_Iir and then not Is_Overload_List (Expr_Type) then + -- Checks types. + -- This is necessary when the first call to sem_expression was done + -- with A_TYPE set to NULL_IIR and results in setting the type of + -- EXPR. + if A_Type /= Null_Iir + and then not Are_Types_Compatible (Expr_Type, A_Type) + then + Not_Match (Expr, A_Type); + return Null_Iir; + end if; + return Expr; + end if; + + -- A_TYPE must be a type definition and not a subtype. + if A_Type /= Null_Iir then + A_Type1 := Get_Base_Type (A_Type); + else + A_Type1 := Null_Iir; + end if; + + case Get_Kind (Expr) is + when Iir_Kind_Aggregate => + Res := Sem_Aggregate (Expr, A_Type); + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + if A_Type = Null_Iir then + Res := Sem_Expression_Ov (Expr, Null_Iir); + else + if not Is_String_Literal_Type (A_Type, Expr) then + Not_Match (Expr, A_Type); + return Null_Iir; + end if; + Set_Type (Expr, A_Type); + Sem_String_Literal (Expr); + return Expr; + end if; + when others => + Res := Sem_Expression_Ov (Expr, A_Type1); + end case; + + if Res /= Null_Iir and then Is_Overloaded (Res) then + -- FIXME: clarify between overload and not determinable from the + -- context. + Error_Overload (Expr); + if Get_Type (Res) /= Null_Iir then + Disp_Overload_List (Get_Overload_List (Get_Type (Res)), Expr); + end if; + return Null_Iir; + end if; + return Res; + end Sem_Expression; + + function Sem_Composite_Expression (Expr : Iir) return Iir + is + Res : Iir; + begin + Res := Sem_Expression_Ov (Expr, Null_Iir); + if Res = Null_Iir or else Get_Type (Res) = Null_Iir then + return Res; + elsif Is_Overload_List (Get_Type (Res)) then + declare + List : constant Iir_List := Get_Overload_List (Get_Type (Res)); + Res_Type : Iir; + Atype : Iir; + begin + Res_Type := Null_Iir; + for I in Natural loop + Atype := Get_Nth_Element (List, I); + exit when Atype = Null_Iir; + if Is_Aggregate_Type (Atype) then + Add_Result (Res_Type, Atype); + end if; + end loop; + + if Res_Type = Null_Iir then + Error_Overload (Expr); + return Null_Iir; + elsif Is_Overload_List (Res_Type) then + Error_Overload (Expr); + Disp_Overload_List (Get_Overload_List (Res_Type), Expr); + Free_Overload_List (Res_Type); + return Null_Iir; + else + return Sem_Expression_Ov (Expr, Res_Type); + end if; + end; + else + -- Either an error (already handled) or not overloaded. Type + -- matching will be done later (when the target is analyzed). + return Res; + end if; + end Sem_Composite_Expression; + + function Sem_Expression_Universal (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 Expr_Type = Null_Iir then + -- FIXME: improve message + Error_Msg_Sem ("bad expression for a scalar", Expr); + return Null_Iir; + end if; + if not Is_Overload_List (Expr_Type) then + return Expr1; + end if; + + 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 El = Universal_Integer_Type_Definition + or El = Convertible_Integer_Type_Definition + or El = Universal_Real_Type_Definition + or El = Convertible_Real_Type_Definition + 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_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 Expr_Type = Null_Iir then + -- Possible only if the type cannot be determined without the + -- context (aggregate or string literal). + Error_Msg_Sem + ("cannot determine the type of choice expression", Expr); + if Get_Kind (Expr1) = Iir_Kind_Aggregate then + Error_Msg_Sem + ("(use a qualified expression of the form T'(xxx).)", Expr); + end if; + return Null_Iir; + end if; + 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_One_Dimensional_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, Get_Base_Type (Res)); + end Sem_Case_Expression; + + function Sem_Condition (Cond : Iir) return Iir + is + Res : Iir; + Op : Iir; + begin + if Vhdl_Std < Vhdl_08 then + Res := Sem_Expression (Cond, Boolean_Type_Definition); + + Check_Read (Res); + return Res; + else + -- LRM08 9.2.9 + -- If, without overload resolution (see 12.5), the expression is + -- of type BOOLEAN defined in package STANDARD, or if, assuming a + -- rule requiring the expression to be of type BOOLEAN defined in + -- package STANDARD, overload resolution can determine at least one + -- interpretation of each constituent of the innermost complete + -- context including the expression, then the condition operator is + -- not applied. + + -- GHDL: what does the second alternative mean ? Any example ? + + Res := Sem_Expression_Ov (Cond, Null_Iir); + + if Res = Null_Iir then + return Res; + end if; + + if not Is_Overloaded (Res) + and then Get_Type (Res) = Boolean_Type_Definition + then + Check_Read (Res); + return Res; + end if; + + -- LRM08 9.2.9 + -- Otherwise, the condition operator is implicitely applied, and the + -- type of the expresion with the implicit application shall be + -- BOOLEAN defined in package STANDARD. + + Op := Create_Iir (Iir_Kind_Condition_Operator); + Location_Copy (Op, Res); + Set_Operand (Op, Res); + + Res := Sem_Operator (Op, Boolean_Type_Definition, 1); + Check_Read (Res); + return Res; + end if; + end Sem_Condition; + +end Sem_Expr; diff --git a/src/vhdl/sem_expr.ads b/src/vhdl/sem_expr.ads new file mode 100644 index 000000000..a0422e727 --- /dev/null +++ b/src/vhdl/sem_expr.ads @@ -0,0 +1,178 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Iirs; use Iirs; + +package Sem_Expr is + -- Set semantic to EXPR. + -- Replace simple_name with the referenced node, + -- Set type to nodes, + -- Resolve overloading + + Deferred_Constant_Allowed : Boolean := False; + + -- Semantize an expression (other than a range) with a possible overloading. + -- Sem_expression_ov (and therefore sem_expression) must be called *once* + -- for each expression node with A_TYPE1 not null and at most *once* with + -- A_TYPE1 null. + -- + -- When A_TYPE1 is null, sem_expression_ov find all possible types + -- of the expression. If there is only one possible type (ie, overloading + -- is non-existant or solved), then the type of the expression is set, + -- and the node is completly semantized. Sem_expression_ov must not + -- be called for such a node. + -- If there is several possible types (ie overloaded), then the type is + -- set with a list of overload. To finishes the semantisation, + -- sem_expression_ov must be called again with A_TYPE1 set to the + -- expected type. + -- + -- If A_TYPE1 is set, sem_expression_ov must finishes the semantisation + -- of the expression, and set its type, which is not necessary a base type. + -- A_TYPE1 must be a base type. + -- + -- In case of error, it displays a message and return null. + -- In case of success, it returns the semantized expression, which can + -- be different from EXPR (eg, a character literal is transformed into an + -- enumeration literal). + function Sem_Expression_Ov (Expr: Iir; A_Type1: Iir) return Iir; + + -- If A_TYPE is not null, then EXPR must be of type A_TYPE. + -- Return null in case of error. + function Sem_Expression (Expr: Iir; A_Type: Iir) return Iir; + + -- Same as Sem_Expression, but also implicitly choose an universal type + -- 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; + + -- Sem COND as a condition. + -- In VHDL08, this follows 9.2.9 Condition operator. + -- In VHDL87 and 93, type of COND must be a boolean. + -- A check is made that COND can be read. + function Sem_Condition (Cond : Iir) return Iir; + + -- Same as Sem_Expression but knowing that the type of EXPR must be a + -- composite type. Used for expressions in assignment statement when the + -- target is an aggregate. + function Sem_Composite_Expression (Expr : Iir) return Iir; + + -- Check EXPR can be read. + procedure Check_Read (Expr : Iir); + + -- Check EXPR can be updated. + procedure Check_Update (Expr : Iir); + + -- Check the type of EXPR can be implicitly converted to TARG_TYPE, ie + -- if TARG_TYPE is a constrained array subtype, number of elements matches. + -- Return FALSE in case of error. + -- If TARG_TYPE or EXPR is NULL_IIR, silently returns TRUE. + function Check_Implicit_Conversion (Targ_Type : Iir; Expr : Iir) + return Boolean; + + -- For a procedure call, A_TYPE must be null. + function Sem_Subprogram_Call (Expr: Iir; A_Type: Iir) return Iir; + + -- If EXPR is a node for an expression, then return EXPR. + -- Otherwise, emit an error message using LOC as location + -- and return NULL_IIR. + -- If EXPR is NULL_IIR, NULL_IIR is silently returned. + function Check_Is_Expression (Expr : Iir; Loc : Iir) return Iir; + + -- Semantize a procedure_call or a concurrent_procedure_call_statement. + -- A procedure call is not an expression but because most of the code + -- for procedure call is common with function call, procedure calls are + -- handled in this package. + procedure Sem_Procedure_Call (Call : Iir_Procedure_Call; Stmt : Iir); + + -- Analyze a range (ie a range attribute or a range expression). If + -- ANY_DIR is true, the range can't be a null range (slice vs subtype, + -- used in static evaluation). A_TYPE may be Null_Iir. + -- Return Null_Iir in case of error, or EXPR analyzed (and evaluated if + -- possible). + function Sem_Range_Expression (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) + return Iir; + + -- Analyze a discrete range. If ANY_DIR is true, the range can't be a + -- null range (slice vs subtype -- used in static evaluation). A_TYPE may + -- be Null_Iir. Return Null_Iir in case of error. + function Sem_Discrete_Range_Expression + (Expr: Iir; A_Type: Iir; Any_Dir: Boolean) return Iir; + + -- Semantize a discrete range and convert to integer if both bounds are + -- universal integer types, according to rules of LRM 3.2.1.1 + function Sem_Discrete_Range_Integer (Expr: Iir) return Iir; + + -- Transform LIT into a physical_literal. + -- LIT can be either a not semantized physical literal or + -- a simple name that is a physical unit. In the later case, a physical + -- literal is created. + function Sem_Physical_Literal (Lit: Iir) return Iir; + + -- CHOICES_LIST is a list of choices (none, expression, range, list or + -- others). + -- If IS_SUB_RANGE is true, then SUB_TYPE may not be fully convered, + -- otherwise, SUB_TYPE must be fully covered. + -- This is used when the subtype of an aggregate must be determined. + -- SUB_TYPE is the discrete subtype. + -- Emit a message if: + -- * the SUB_TYPE is not fully covered by the choices + -- * the choices are not mutually exclusif (an element is present twice) + -- * OTHERS is not the last choice, or is present several times. + -- + -- If there is at least one named choice, LOW and HIGH are set with the + -- lowest and highest index. + -- If LOW and HIGH are set, they are locally static. + -- + -- Unidimensional strings are not handled here but by + -- sem_string_choices_range. + -- + -- TODO: + -- * be smarter if only positional choices (do not create the list). + -- * smarter messages. + procedure Sem_Choices_Range + (Choice_Chain : in out Iir; + Sub_Type : Iir; + Is_Sub_Range : Boolean; + Is_Case_Stmt : Boolean; + Loc : Location_Type; + Low : out Iir; + High : out Iir); + + -- Semantize CHOICE_LIST when the choice expression SEL is of a + -- one-dimensional character array type. + procedure Sem_String_Choices_Range (Choice_Chain : Iir; Sel : Iir); + + -- LEFT are RIGHT must be really a type (not a subtype). + function Are_Basetypes_Compatible (Left: Iir; Right: Iir) + return Boolean; + + -- Return TRUE iif types of LEFT and RIGHT are compatible. + function Are_Nodes_Compatible (Left: Iir; Right: Iir) + return Boolean; + + -- Return TRUE iff the type of EXPR is compatible with A_TYPE + function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) return Boolean; + + -- LIST1, LIST2 are either a type node or an overload list of types. + -- Return THE type which is compatible with LIST1 are LIST2. + -- Return null_iir if there is no such type or if there are several types. + function Search_Compatible_Type (List1, List2 : Iir) return Iir; +end Sem_Expr; diff --git a/src/vhdl/sem_inst.adb b/src/vhdl/sem_inst.adb new file mode 100644 index 000000000..a9ba7560e --- /dev/null +++ b/src/vhdl/sem_inst.adb @@ -0,0 +1,639 @@ +-- Package (and subprograms) instantiations + +-- When a package is instantiated, we need to 'duplicate' its declaration. +-- This looks useless for analysis but it isn't: a type from a package +-- instantiated twice declares two different types. Without duplication, we +-- need to attach to each declaration its instance, which looks more expansive +-- that duplicating the declaration. +-- +-- Furthermore, for generic type interface, it looks a good idea to duplicate +-- the body (macro expansion). +-- +-- Duplicating is not trivial: internal links must be kept and external +-- links preserved. A table is used to map nodes from the uninstantiated +-- package to its duplicated node. Links from instantiated declaration to +-- the original declaration are also stored in that table. + +with GNAT.Table; +with Nodes; +with Nodes_Meta; +with Types; use Types; +with Iirs_Utils; use Iirs_Utils; +with Errorout; use Errorout; + +package body Sem_Inst is + -- Table of origin. This is an extension of vhdl nodes to track the + -- origin of a node. If a node has a non-null origin, then the node was + -- instantiated for the origin node. + -- + -- Furthermore, during instantiation, we need to keep track of instantiated + -- nodes (ie nodes created by instantiation) used by references. As an + -- instance cannot be uninstantiated, there is no collisions, as soon as + -- such entries are cleaned after instantiation. + -- + -- As an example, here are declarations of an uninstantiated package: + -- type Nat is range 0 to 1023; + -- constant N : Nat := 5; + -- A node Nat1 will be created from node Nat (an integer type definition). + -- The origin of Nat1 is Nat and this is true forever. During + -- instantiation, the instance of Nat is Nat1, so that the type of N will + -- be set to Nat1. + package Origin_Table is new GNAT.Table + (Table_Component_Type => Iir, + Table_Index_Type => Iir, + Table_Low_Bound => 2, + Table_Initial => 1024, + Table_Increment => 100); + + procedure Expand_Origin_Table + is + use Nodes; + Last : constant Iir := Iirs.Get_Last_Node; + El: Iir; + begin + El := Origin_Table.Last; + if El < Last then + Origin_Table.Set_Last (Last); + Origin_Table.Table (El + 1 .. Last) := (others => Null_Iir); + end if; + end Expand_Origin_Table; + + -- This is the public function; the table may not have been extended. + function Get_Origin (N : Iir) return Iir + is + -- Make the '<=' operator visible. + use Nodes; + begin + if N <= Origin_Table.Last then + return Origin_Table.Table (N); + else + return Null_Iir; + end if; + end Get_Origin; + + -- This is the private function: the table *must* have been extended. + function Get_Instance (N : Iir) return Iir + is + -- Make '<=' operator visible for the assert. + use Nodes; + begin + pragma Assert (N <= Origin_Table.Last); + return Origin_Table.Table (N); + end Get_Instance; + + procedure Set_Origin (N : Iir; Orig : Iir) is + begin + -- As nodes are created, we need to expand origin table. + Expand_Origin_Table; + + pragma Assert (Orig = Null_Iir + or else Origin_Table.Table (N) = Null_Iir); + Origin_Table.Table (N) := Orig; + end Set_Origin; + + type Instance_Entry_Type is record + -- Node + N : Iir; + + -- Old value in Origin_Table. + Old_Origin : Iir; + end record; + + type Instance_Index_Type is new Natural; + + -- Table of previous values in Origin_Table. The first purpose of this + -- table is to be able to revert the calls to Set_Instance, so that a unit + -- can be instantiated several times. Keep the nodes that have been + -- instantiated is cheaper than walking the tree a second time. + -- The second purpose of this table is not yet implemented: being able to + -- have uninstantiated packages in instantiated packages. In that case, + -- the slot in Origin_Table cannot be the origin and the instance at the + -- same time. + package Prev_Instance_Table is new GNAT.Table + (Table_Component_Type => Instance_Entry_Type, + Table_Index_Type => Instance_Index_Type, + Table_Low_Bound => 1, + Table_Initial => 256, + Table_Increment => 100); + + procedure Set_Instance (Orig : Iir; N : Iir) + is + use Nodes; + begin + pragma Assert (Orig <= Origin_Table.Last); + + -- Save the old entry + Prev_Instance_Table.Append + (Instance_Entry_Type'(N => Orig, + Old_Origin => Origin_Table.Table (Orig))); + + -- Set the entry. + Origin_Table.Table (Orig) := N; + end Set_Instance; + + procedure Restore_Origin (Mark : Instance_Index_Type) is + begin + for I in reverse Mark + 1 .. Prev_Instance_Table.Last loop + declare + El : Instance_Entry_Type renames Prev_Instance_Table.Table (I); + begin + Origin_Table.Table (El.N) := El.Old_Origin; + end; + end loop; + Prev_Instance_Table.Set_Last (Mark); + end Restore_Origin; + + -- The location to be used while instantiated nodes. + Instantiate_Loc : Location_Type; + + function Instantiate_Iir (N : Iir; Is_Ref : Boolean) return Iir; + + -- Instantiate a list. Simply create a new list and instantiate nodes of + -- that list. + function Instantiate_Iir_List (L : Iir_List; Is_Ref : Boolean) + return Iir_List + is + Res : Iir_List; + El : Iir; + begin + case L is + when Null_Iir_List + | Iir_List_All + | Iir_List_Others => + return L; + when others => + Res := Create_Iir_List; + for I in Natural loop + El := Get_Nth_Element (L, I); + exit when El = Null_Iir; + Append_Element (Res, Instantiate_Iir (El, Is_Ref)); + end loop; + return Res; + end case; + end Instantiate_Iir_List; + + -- Instantiate a chain. This is a special case to reduce stack depth. + function Instantiate_Iir_Chain (N : Iir) return Iir + is + First : Iir; + Last : Iir; + Next_N : Iir; + Next_R : Iir; + begin + if N = Null_Iir then + return Null_Iir; + end if; + + First := Instantiate_Iir (N, False); + Last := First; + Next_N := Get_Chain (N); + while Next_N /= Null_Iir loop + Next_R := Instantiate_Iir (Next_N, False); + Set_Chain (Last, Next_R); + Last := Next_R; + Next_N := Get_Chain (Next_N); + end loop; + + return First; + end Instantiate_Iir_Chain; + + procedure Instantiate_Iir_Field + (Res : Iir; N : Iir; F : Nodes_Meta.Fields_Enum) + is + use Nodes_Meta; + begin + case Get_Field_Type (F) is + when Type_Iir => + declare + S : constant Iir := Get_Iir (N, F); + R : Iir; + begin + case Get_Field_Attribute (F) is + when Attr_None => + R := Instantiate_Iir (S, False); + when Attr_Ref => + R := Instantiate_Iir (S, True); + when Attr_Maybe_Ref => + R := Instantiate_Iir (S, Get_Is_Ref (N)); + when Attr_Chain => + R := Instantiate_Iir_Chain (S); + when Attr_Chain_Next => + R := Null_Iir; + when Attr_Of_Ref => + -- Can only appear in list. + raise Internal_Error; + end case; + Set_Iir (Res, F, R); + end; + when Type_Iir_List => + declare + S : constant Iir_List := Get_Iir_List (N, F); + R : Iir_List; + begin + case Get_Field_Attribute (F) is + when Attr_None => + R := Instantiate_Iir_List (S, False); + when Attr_Of_Ref => + R := Instantiate_Iir_List (S, True); + when others => + -- Ref is specially handled in Instantiate_Iir. + -- Others cannot appear for lists. + raise Internal_Error; + end case; + Set_Iir_List (Res, F, R); + end; + when Type_PSL_NFA + | Type_PSL_Node => + -- TODO + raise Internal_Error; + when Type_String_Id => + Set_String_Id (Res, F, Get_String_Id (N, F)); + when Type_Source_Ptr => + Set_Source_Ptr (Res, F, Get_Source_Ptr (N, F)); + when Type_Date_Type + | Type_Date_State_Type + | Type_Time_Stamp_Id => + -- Can this happen ? + raise Internal_Error; + when Type_Base_Type => + Set_Base_Type (Res, F, Get_Base_Type (N, F)); + when Type_Iir_Constraint => + Set_Iir_Constraint (Res, F, Get_Iir_Constraint (N, F)); + when Type_Iir_Mode => + Set_Iir_Mode (Res, F, Get_Iir_Mode (N, F)); + when Type_Iir_Index32 => + Set_Iir_Index32 (Res, F, Get_Iir_Index32 (N, F)); + when Type_Iir_Int64 => + Set_Iir_Int64 (Res, F, Get_Iir_Int64 (N, F)); + when Type_Boolean => + Set_Boolean (Res, F, Get_Boolean (N, F)); + when Type_Iir_Staticness => + Set_Iir_Staticness (Res, F, Get_Iir_Staticness (N, F)); + when Type_Iir_All_Sensitized => + Set_Iir_All_Sensitized (Res, F, Get_Iir_All_Sensitized (N, F)); + when Type_Iir_Signal_Kind => + Set_Iir_Signal_Kind (Res, F, Get_Iir_Signal_Kind (N, F)); + when Type_Tri_State_Type => + Set_Tri_State_Type (Res, F, Get_Tri_State_Type (N, F)); + when Type_Iir_Pure_State => + Set_Iir_Pure_State (Res, F, Get_Iir_Pure_State (N, F)); + when Type_Iir_Delay_Mechanism => + Set_Iir_Delay_Mechanism (Res, F, Get_Iir_Delay_Mechanism (N, F)); + when Type_Iir_Lexical_Layout_Type => + Set_Iir_Lexical_Layout_Type + (Res, F, Get_Iir_Lexical_Layout_Type (N, F)); + when Type_Iir_Predefined_Functions => + Set_Iir_Predefined_Functions + (Res, F, Get_Iir_Predefined_Functions (N, F)); + when Type_Iir_Direction => + Set_Iir_Direction (Res, F, Get_Iir_Direction (N, F)); + when Type_Location_Type => + Set_Location_Type (Res, F, Instantiate_Loc); + when Type_Iir_Int32 => + Set_Iir_Int32 (Res, F, Get_Iir_Int32 (N, F)); + when Type_Int32 => + Set_Int32 (Res, F, Get_Int32 (N, F)); + when Type_Iir_Fp64 => + Set_Iir_Fp64 (Res, F, Get_Iir_Fp64 (N, F)); + when Type_Token_Type => + Set_Token_Type (Res, F, Get_Token_Type (N, F)); + when Type_Name_Id => + Set_Name_Id (Res, F, Get_Name_Id (N, F)); + end case; + end Instantiate_Iir_Field; + + function Instantiate_Iir (N : Iir; Is_Ref : Boolean) return Iir + is + Res : Iir; + begin + -- Nothing to do for null node. + if N = Null_Iir then + return Null_Iir; + end if; + + -- For a reference, do not create a new node. + if Is_Ref then + Res := Get_Instance (N); + if Res /= Null_Iir then + -- There is an instance for N. + return Res; + else + -- Reference outside the instance. + return N; + end if; + end if; + + declare + use Nodes_Meta; + Kind : constant Iir_Kind := Get_Kind (N); + Fields : constant Fields_Array := Get_Fields (Kind); + F : Fields_Enum; + begin + Res := Get_Instance (N); + + if Kind = Iir_Kind_Interface_Constant_Declaration + and then Get_Identifier (N) = Null_Identifier + and then Res /= Null_Iir + then + -- Anonymous constant interface declarations are the only nodes + -- that can be shared. Handle that very special case. + return Res; + end if; + + pragma Assert (Res = Null_Iir); + + -- Create a new node. + Res := Create_Iir (Kind); + + -- The origin of this new node is N. + Set_Origin (Res, N); + + -- And the instance of N is RES. + Set_Instance (N, Res); + + Set_Location (Res, Instantiate_Loc); + + for I in Fields'Range loop + F := Fields (I); + + -- Fields that are handled specially. + case F is + when Field_Index_Subtype_List => + -- Index_Subtype_List is always a reference, so retrieve + -- the instance of the referenced list. This is a special + -- case because there is no origins for list. + declare + List : Iir_List; + begin + case Kind is + when Iir_Kind_Array_Type_Definition => + List := Get_Index_Subtype_Definition_List (Res); + when Iir_Kind_Array_Subtype_Definition => + List := Get_Index_Constraint_List (Res); + if List = Null_Iir_List then + List := Get_Index_Subtype_List + (Get_Denoted_Type_Mark (Res)); + end if; + when others => + -- All the nodes where Index_Subtype_List appears + -- are handled above. + raise Internal_Error; + end case; + Set_Index_Subtype_List (Res, List); + end; + + when others => + -- Common case. + Instantiate_Iir_Field (Res, N, F); + end case; + end loop; + + case Kind is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- Subprogram body is a forward declaration. + Set_Subprogram_Body (Res, Null_Iir); + when others => + -- TODO: other forward references: + -- incomplete constant + -- attribute_value + null; + end case; + + return Res; + end; + end Instantiate_Iir; + + -- As the scope generic interfaces extends beyond the immediate scope (see + -- LRM08 12.2 Scope of declarations), they must be instantiated. + function Instantiate_Generic_Chain (Inst : Iir; Inters : Iir) return Iir + is + Inter : Iir; + First : Iir; + Last : Iir; + Res : Iir; + begin + First := Null_Iir; + Last := Null_Iir; + + Inter := Inters; + while Inter /= Null_Iir loop + -- Create a copy of the interface. FIXME: is it really needed ? + Res := Create_Iir (Get_Kind (Inter)); + Set_Location (Res, Instantiate_Loc); + Set_Parent (Res, Inst); + Set_Identifier (Res, Get_Identifier (Inter)); + Set_Visible_Flag (Res, Get_Visible_Flag (Inter)); + + Set_Origin (Res, Inter); + Set_Instance (Inter, Res); + + case Get_Kind (Res) is + when Iir_Kind_Interface_Constant_Declaration => + Set_Type (Res, Get_Type (Inter)); + Set_Subtype_Indication (Res, Get_Subtype_Indication (Inter)); + Set_Mode (Res, Get_Mode (Inter)); + Set_Lexical_Layout (Res, Get_Lexical_Layout (Inter)); + Set_Expr_Staticness (Res, Get_Expr_Staticness (Inter)); + Set_Name_Staticness (Res, Get_Name_Staticness (Inter)); + when Iir_Kind_Interface_Package_Declaration => + Set_Uninstantiated_Package_Name + (Res, Get_Uninstantiated_Package_Name (Inter)); + when others => + Error_Kind ("instantiate_generic_chain", Res); + end case; + + -- Append + if First = Null_Iir then + First := Res; + else + Set_Chain (Last, Res); + end if; + Last := Res; + + Inter := Get_Chain (Inter); + end loop; + + return First; + end Instantiate_Generic_Chain; + + procedure Set_Instance_On_Chain (Chain : Iir; Inst_Chain : Iir); + procedure Set_Instance_On_Iir_List (N : Iir_List; Inst : Iir_List); + + procedure Set_Instance_On_Iir (N : Iir; Inst : Iir) is + begin + if N = Null_Iir then + pragma Assert (Inst = Null_Iir); + return; + end if; + pragma Assert (Inst /= Null_Iir); + + declare + use Nodes_Meta; + Kind : constant Iir_Kind := Get_Kind (N); + Fields : constant Fields_Array := Get_Fields (Kind); + F : Fields_Enum; + begin + pragma Assert (Get_Kind (Inst) = Kind); + + if Kind = Iir_Kind_Interface_Constant_Declaration + and then Get_Identifier (N) = Null_Identifier + then + -- Anonymous constant interface declarations are the only nodes + -- that can be shared. Handle that very special case. + return; + end if; + + -- pragma Assert (Get_Instance (N) = Null_Iir); + Set_Instance (N, Inst); + + for I in Fields'Range loop + F := Fields (I); + + case Get_Field_Type (F) is + when Type_Iir => + declare + S : constant Iir := Get_Iir (N, F); + S_Inst : constant Iir := Get_Iir (Inst, F); + begin + case Get_Field_Attribute (F) is + when Attr_None => + Set_Instance_On_Iir (S, S_Inst); + when Attr_Ref => + null; + when Attr_Maybe_Ref => + if not Get_Is_Ref (N) then + Set_Instance_On_Iir (S, S_Inst); + end if; + when Attr_Chain => + Set_Instance_On_Chain (S, S_Inst); + when Attr_Chain_Next => + null; + when Attr_Of_Ref => + -- Can only appear in list. + raise Internal_Error; + end case; + end; + when Type_Iir_List => + declare + S : constant Iir_List := Get_Iir_List (N, F); + S_Inst : constant Iir_List := Get_Iir_List (Inst, F); + begin + case Get_Field_Attribute (F) is + when Attr_None => + Set_Instance_On_Iir_List (S, S_Inst); + when Attr_Of_Ref + | Attr_Ref => + null; + when others => + -- Ref is specially handled in Instantiate_Iir. + -- Others cannot appear for lists. + raise Internal_Error; + end case; + end; + when others => + null; + end case; + end loop; + end; + end Set_Instance_On_Iir; + + procedure Set_Instance_On_Iir_List (N : Iir_List; Inst : Iir_List) + is + El : Iir; + El_Inst : Iir; + begin + case N is + when Null_Iir_List + | Iir_List_All + | Iir_List_Others => + pragma Assert (Inst = N); + return; + when others => + for I in Natural loop + El := Get_Nth_Element (N, I); + El_Inst := Get_Nth_Element (Inst, I); + exit when El = Null_Iir; + pragma Assert (El_Inst /= Null_Iir); + + Set_Instance_On_Iir (El, El_Inst); + end loop; + pragma Assert (El_Inst = Null_Iir); + end case; + end Set_Instance_On_Iir_List; + + procedure Set_Instance_On_Chain (Chain : Iir; Inst_Chain : Iir) + is + El : Iir; + Inst_El : Iir; + begin + El := Chain; + Inst_El := Inst_Chain; + while El /= Null_Iir loop + pragma Assert (Inst_El /= Null_Iir); + Set_Instance_On_Iir (El, Inst_El); + El := Get_Chain (El); + Inst_El := Get_Chain (Inst_El); + end loop; + pragma Assert (Inst_El = Null_Iir); + end Set_Instance_On_Chain; + + -- In the instance, replace references (and inner references) to interface + -- package declaration to the associated package. + procedure Instantiate_Generic_Map_Chain (Inst : Iir; Pkg : Iir) + is + pragma Unreferenced (Pkg); + Assoc : Iir; + begin + Assoc := Get_Generic_Map_Aspect_Chain (Inst); + while Assoc /= Null_Iir loop + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression + | Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Open => + null; + when Iir_Kind_Association_Element_Package => + declare + Sub_Inst : constant Iir := + Get_Named_Entity (Get_Actual (Assoc)); + Sub_Pkg : constant Iir := Get_Associated_Interface (Assoc); + begin + Set_Instance (Sub_Pkg, Sub_Inst); + Set_Instance_On_Chain (Get_Generic_Chain (Sub_Pkg), + Get_Generic_Chain (Sub_Inst)); + Set_Instance_On_Chain (Get_Declaration_Chain (Sub_Pkg), + Get_Declaration_Chain (Sub_Inst)); + end; + when others => + Error_Kind ("instantiate_generic_map_chain", Assoc); + end case; + Assoc := Get_Chain (Assoc); + end loop; + end Instantiate_Generic_Map_Chain; + + procedure Instantiate_Package_Declaration (Inst : Iir; Pkg : Iir) + is + Header : constant Iir := Get_Package_Header (Pkg); + Prev_Loc : constant Location_Type := Instantiate_Loc; + Mark : constant Instance_Index_Type := Prev_Instance_Table.Last; + begin + Instantiate_Loc := Get_Location (Inst); + + -- Be sure Get_Origin_Priv can be called on existing nodes. + Expand_Origin_Table; + + -- For Parent: the instance of PKG is INST. + Set_Origin (Pkg, Inst); + + Set_Generic_Chain + (Inst, Instantiate_Generic_Chain (Inst, Get_Generic_Chain (Header))); + Instantiate_Generic_Map_Chain (Inst, Pkg); + Set_Declaration_Chain + (Inst, Instantiate_Iir_Chain (Get_Declaration_Chain (Pkg))); + + Set_Origin (Pkg, Null_Iir); + + Instantiate_Loc := Prev_Loc; + Restore_Origin (Mark); + end Instantiate_Package_Declaration; +end Sem_Inst; diff --git a/src/vhdl/sem_inst.ads b/src/vhdl/sem_inst.ads new file mode 100644 index 000000000..da8cd5d27 --- /dev/null +++ b/src/vhdl/sem_inst.ads @@ -0,0 +1,26 @@ +-- Package (and subprograms) instantiations + +-- When a package is instantiated, we need to 'duplicate' its declaration. +-- This looks useless for analysis but it isn't: a type from a package +-- instantiated twice declares two different types. Without duplication, we +-- need to attach to each declaration its instance, which looks more expansive +-- that duplicating the declaration. +-- +-- Furthermore, for generic type interface, it looks a good idea to duplicate +-- the body (macro expansion). +-- +-- Duplicating is not trivial: internal links must be kept and external +-- links preserved. A table is used to map nodes from the uninstantiated +-- package to its duplicated node. Links from instantiated declaration to +-- the original declaration are also stored in that table. + +with Iirs; use Iirs; + +package Sem_Inst is + -- Return the origin of node N, the node from which N was instantiated. + -- If N is not an instance, this function returns Null_Iir. + function Get_Origin (N : Iir) return Iir; + + -- Create declaration chain and generic declarations for INST from PKG. + procedure Instantiate_Package_Declaration (Inst : Iir; Pkg : Iir); +end Sem_Inst; diff --git a/src/vhdl/sem_names.adb b/src/vhdl/sem_names.adb new file mode 100644 index 000000000..151e81708 --- /dev/null +++ b/src/vhdl/sem_names.adb @@ -0,0 +1,3788 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Evaluation; use Evaluation; +with Iirs_Utils; use Iirs_Utils; +with Libraries; +with Errorout; use Errorout; +with Flags; use Flags; +with Name_Table; +with Std_Package; use Std_Package; +with Types; use Types; +with Iir_Chains; use Iir_Chains; +with Std_Names; +with Sem; +with Sem_Scopes; use Sem_Scopes; +with Sem_Expr; use Sem_Expr; +with Sem_Stmts; use Sem_Stmts; +with Sem_Decls; use Sem_Decls; +with Sem_Assocs; use Sem_Assocs; +with Sem_Types; +with Sem_Psl; +with Xrefs; use Xrefs; + +package body Sem_Names is + -- Finish the semantization of NAME using RES as named entity. + -- This is called when the semantization is finished and an uniq + -- interpretation has been determined (RES). + -- + -- Error messages are emitted here. + function Finish_Sem_Name (Name : Iir; Res : Iir) return Iir; + + procedure Error_Overload (Expr: Iir) is + begin + Error_Msg_Sem ("can't resolve overload for " & Disp_Node (Expr), Expr); + end Error_Overload; + + procedure Disp_Overload_List (List : Iir_List; Loc : Iir) + is + El : Iir; + begin + Error_Msg_Sem ("possible interpretations are:", Loc); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + Error_Msg_Sem (Disp_Subprg (El), El); + when Iir_Kind_Function_Call => + El := Get_Implementation (El); + Error_Msg_Sem (Disp_Subprg (El), El); + when others => + Error_Msg_Sem (Disp_Node (El), El); + end case; + end loop; + end Disp_Overload_List; + + -- Create an overload list. + -- must be destroyed with free_iir. + function Get_Overload_List return Iir_Overload_List + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Overload_List); + return Res; + end Get_Overload_List; + + function Create_Overload_List (List : Iir_List) return Iir_Overload_List + is + Res : Iir_Overload_List; + begin + Res := Get_Overload_List; + Set_Overload_List (Res, List); + return Res; + end Create_Overload_List; + + procedure Free_Overload_List (N : in out Iir_Overload_List) + is + List : Iir_List; + begin + List := Get_Overload_List (N); + Destroy_Iir_List (List); + Free_Iir (N); + N := Null_Iir; + end Free_Overload_List; + + function Simplify_Overload_List (List : Iir_List) return Iir + is + Res : Iir; + L1 : Iir_List; + begin + case Get_Nbr_Elements (List) is + when 0 => + L1 := List; + Destroy_Iir_List (L1); + return Null_Iir; + when 1 => + L1 := List; + Res := Get_First_Element (List); + Destroy_Iir_List (L1); + return Res; + when others => + return Create_Overload_List (List); + end case; + end Simplify_Overload_List; + + -- Return true if AN_IIR is an overload list. + function Is_Overload_List (An_Iir: Iir) return Boolean is + begin + return Get_Kind (An_Iir) = Iir_Kind_Overload_List; + end Is_Overload_List; + + -- From the list LIST of function or enumeration literal, extract the + -- list of (return) types. + -- If there is only one type, return it. + -- If there is no types, return NULL. + -- Otherwise, return the list as an overload list. + function Create_List_Of_Types (List : Iir_List) + return Iir + is + Res_List : Iir_List; + Decl : Iir; + begin + -- Create the list of possible return types. + Res_List := Create_Iir_List; + for I in Natural loop + Decl := Get_Nth_Element (List, I); + exit when Decl = Null_Iir; + case Get_Kind (Decl) is + when Iir_Kinds_Function_Declaration => + Add_Element (Res_List, Get_Return_Type (Decl)); + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Call + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element => + Add_Element (Res_List, Get_Type (Decl)); + when others => + Error_Kind ("create_list_of_types", Decl); + end case; + end loop; + return Simplify_Overload_List (Res_List); + end Create_List_Of_Types; + + procedure Add_Result (Res : in out Iir; Decl : Iir) + is + Nres : Iir; + Nres_List : Iir_List; + begin + if Decl = Null_Iir then + return; + end if; + if Res = Null_Iir then + Res := Decl; + elsif Is_Overload_List (Res) then + Append_Element (Get_Overload_List (Res), Decl); + else + Nres_List := Create_Iir_List; + Nres := Create_Overload_List (Nres_List); + Append_Element (Nres_List, Res); + Append_Element (Nres_List, Decl); + Res := Nres; + end if; + end Add_Result; + + -- Move elements of result list LIST to result list RES. + -- Destroy LIST if necessary. + procedure Add_Result_List (Res : in out Iir; List : Iir); + pragma Unreferenced (Add_Result_List); + + procedure Add_Result_List (Res : in out Iir; List : Iir) + is + El : Iir; + List_List : Iir_List; + Res_List : Iir_List; + begin + if Res = Null_Iir then + Res := List; + elsif List = Null_Iir then + null; + elsif not Is_Overload_List (List) then + Add_Result (Res, List); + else + if not Is_Overload_List (Res) then + El := Res; + Res := Get_Overload_List; + Append_Element (Get_Overload_List (Res), El); + end if; + List_List := Get_Overload_List (List); + Res_List := Get_Overload_List (Res); + for I in Natural loop + El := Get_Nth_Element (List_List, I); + exit when El = Null_Iir; + Append_Element (Res_List, El); + end loop; + Free_Iir (List); + end if; + end Add_Result_List; + + -- Free interpretations of LIST except KEEP. + procedure Sem_Name_Free_Result (List : Iir; Keep : Iir) + is + procedure Sem_Name_Free (El : Iir) is + begin + case Get_Kind (El) is + when Iir_Kind_Function_Call + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element => + Sem_Name_Free (Get_Prefix (El)); + Free_Iir (El); + when Iir_Kind_Attribute_Name => + Free_Iir (El); + when Iir_Kinds_Function_Declaration + | Iir_Kinds_Procedure_Declaration + | Iir_Kind_Enumeration_Literal => + null; + when Iir_Kinds_Denoting_Name => + null; + when others => + Error_Kind ("sem_name_free", El); + end case; + end Sem_Name_Free; + + El : Iir; + List_List : Iir_List; + begin + if List = Null_Iir then + return; + elsif not Is_Overload_List (List) then + if List /= Keep then + Sem_Name_Free (List); + end if; + else + List_List := Get_Overload_List (List); + for I in Natural loop + El := Get_Nth_Element (List_List, I); + exit when El = Null_Iir; + if El /= Keep then + Sem_Name_Free (El); + end if; + end loop; + Free_Iir (List); + end if; + end Sem_Name_Free_Result; + + procedure Free_Parenthesis_Name (Name : Iir; Res : Iir) + is + Chain, Next_Chain : Iir; + begin + pragma Assert (Get_Kind (Res) /= Iir_Kind_Function_Call); + Chain := Get_Association_Chain (Name); + while Chain /= Null_Iir loop + Next_Chain := Get_Chain (Chain); + Free_Iir (Chain); + Chain := Next_Chain; + end loop; + Free_Iir (Name); + end Free_Parenthesis_Name; + + -- Find all named declaration whose identifier is ID in DECL_LIST and + -- return it. + -- The result can be NULL (if no such declaration exist), + -- a declaration, or an overload_list containing all declarations. + function Find_Declarations_In_List + (Decl: Iir; Name : Iir_Selected_Name; Keep_Alias : Boolean) + return Iir + is + Res: Iir := Null_Iir; + + -- If indentifier of DECL is ID, then add DECL in the result. + procedure Handle_Decl (Decl : Iir; Id : Name_Id) is + begin + -- Use_clauses may appear in a declaration list. + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause + | Iir_Kind_Anonymous_Type_Declaration => + return; + when Iir_Kind_Non_Object_Alias_Declaration => + if Get_Identifier (Decl) = Id then + if Keep_Alias then + Add_Result (Res, Decl); + else + Add_Result (Res, Get_Named_Entity (Get_Name (Decl))); + end if; + end if; + when others => + if Get_Identifier (Decl) = Id then + Add_Result (Res, Decl); + end if; + end case; + end Handle_Decl; + + procedure Iterator_Decl is new Sem_Scopes.Iterator_Decl + (Arg_Type => Name_Id, Handle_Decl => Handle_Decl); + --procedure Iterator_Decl_List is new Sem_Scopes.Iterator_Decl_List + -- (Arg_Type => Name_Id, Handle_Decl => Iterator_Decl); + procedure Iterator_Decl_Chain is new Sem_Scopes.Iterator_Decl_Chain + (Arg_Type => Name_Id, Handle_Decl => Iterator_Decl); + + Id : Name_Id; + Decl_Body : Iir; + begin + Id := Get_Identifier (Name); + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Iterator_Decl_Chain (Get_Interface_Declaration_Chain (Decl), Id); + when Iir_Kind_Entity_Declaration => + Iterator_Decl_Chain (Get_Generic_Chain (Decl), Id); + Iterator_Decl_Chain (Get_Port_Chain (Decl), Id); + when Iir_Kind_Architecture_Body => + null; + when Iir_Kind_Generate_Statement => + null; + when Iir_Kind_Package_Declaration => + null; + when Iir_Kind_Package_Instantiation_Declaration => + Iterator_Decl_Chain (Get_Generic_Chain (Decl), Id); + when Iir_Kind_Block_Statement => + declare + Header : constant Iir := Get_Block_Header (Decl); + begin + if Header /= Null_Iir then + Iterator_Decl_Chain (Get_Generic_Chain (Header), Id); + Iterator_Decl_Chain (Get_Port_Chain (Header), Id); + end if; + end; + when Iir_Kind_For_Loop_Statement => + Handle_Decl (Get_Parameter_Specification (Decl), Id); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + null; + when others => + Error_Kind ("find_declarations_in_list", Decl); + end case; + + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Decl_Body := Get_Subprogram_Body (Decl); + Iterator_Decl_Chain + (Get_Declaration_Chain (Decl_Body), Id); + Iterator_Decl_Chain + (Get_Sequential_Statement_Chain (Decl_Body), Id); + when Iir_Kind_Architecture_Body + | Iir_Kind_Entity_Declaration + | Iir_Kind_Generate_Statement + | Iir_Kind_Block_Statement => + Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id); + Iterator_Decl_Chain (Get_Concurrent_Statement_Chain (Decl), Id); + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id); + Iterator_Decl_Chain (Get_Sequential_Statement_Chain (Decl), Id); + when Iir_Kind_For_Loop_Statement => + null; + when others => + Error_Kind ("find_declarations_in_list", Decl); + end case; + --if Res = Null_Iir then + -- Error_Msg_Sem ("""" & Name_Table.Image (Id) & """ not defined in " + -- & Disp_Node (Decl), Name); + --end if; + return Res; + end Find_Declarations_In_List; + + -- Create an implicit_dereference node if PREFIX is of type access. + -- Return PREFIX otherwise. + -- PARENT is used if an implicit dereference node is created, to copy + -- location from. + function Insert_Implicit_Dereference (Prefix : Iir; Parent : Iir) + return Iir + is + Prefix_Type : Iir; + Res : Iir_Implicit_Dereference; + begin + Prefix_Type := Get_Type (Prefix); + + case Get_Kind (Prefix_Type) is + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + null; + when others => + return Prefix; + end case; + Check_Read (Prefix); + Res := Create_Iir (Iir_Kind_Implicit_Dereference); + Location_Copy (Res, Parent); + Set_Type (Res, Get_Designated_Type (Prefix_Type)); + Set_Prefix (Res, Prefix); + Set_Base_Name (Res, Res); + Set_Expr_Staticness (Res, None); + return Res; + end Insert_Implicit_Dereference; + + -- If PREFIX is a function specification that cannot be converted to a + -- function call (because of lack of association), return FALSE. + function Maybe_Function_Call (Prefix : Iir) return Boolean + is + Inter : Iir; + begin + if Get_Kind (Prefix) not in Iir_Kinds_Function_Declaration then + return True; + end if; + Inter := Get_Interface_Declaration_Chain (Prefix); + while Inter /= Null_Iir loop + if Get_Default_Value (Inter) = Null_Iir then + return False; + end if; + Inter := Get_Chain (Inter); + end loop; + return True; + end Maybe_Function_Call; + + procedure Name_To_Method_Object (Call : Iir; Name : Iir) + is + Prefix : Iir; + Obj : Iir; + begin + if Get_Kind (Name) /= Iir_Kind_Selected_Name then + return; + end if; + + Prefix := Get_Prefix (Name); + Obj := Get_Named_Entity (Prefix); + if Obj /= Null_Iir + and then Kind_In (Obj, Iir_Kind_Variable_Declaration, + Iir_Kind_Interface_Variable_Declaration) + and then Get_Type (Obj) /= Null_Iir + then + if Get_Kind (Get_Type (Obj)) /= Iir_Kind_Protected_Type_Declaration + then + Error_Msg_Sem ("type of the prefix should be a protected type", + Prefix); + return; + end if; + Set_Method_Object (Call, Obj); + end if; + end Name_To_Method_Object; + + -- NAME is the name of the function (and not the parenthesis name) + function Sem_As_Function_Call (Name : Iir; Spec : Iir; Assoc_Chain : Iir) + return Iir_Function_Call + is + Call : Iir_Function_Call; + begin + -- Check. + pragma Assert (Get_Kind (Name) in Iir_Kinds_Denoting_Name); + + Call := Create_Iir (Iir_Kind_Function_Call); + Location_Copy (Call, Name); + if Get_Kind (Name) = Iir_Kind_Parenthesis_Name then + Set_Prefix (Call, Get_Prefix (Name)); + else + Set_Prefix (Call, Name); + end if; + Name_To_Method_Object (Call, Name); + Set_Implementation (Call, Spec); + Set_Parameter_Association_Chain (Call, Assoc_Chain); + Set_Type (Call, Get_Return_Type (Spec)); + Set_Base_Name (Call, Call); + return Call; + end Sem_As_Function_Call; + + -- If SPEC is a function specification, then return a function call, + -- else return SPEC. + function Maybe_Insert_Function_Call (Name : Iir; Spec : Iir) return Iir + is + begin + if Get_Kind (Spec) in Iir_Kinds_Function_Declaration then + return Sem_As_Function_Call (Name, Spec, Null_Iir); + else + return Spec; + end if; + end Maybe_Insert_Function_Call; + + -- If PTR_TYPE is not NULL_IIR, then return an implciti dereference to + -- PREFIX, else return PREFIX. + function Maybe_Insert_Dereference (Prefix : Iir; Ptr_Type : Iir) return Iir + is + Id : Iir; + begin + if Ptr_Type /= Null_Iir then + Id := Create_Iir (Iir_Kind_Implicit_Dereference); + Location_Copy (Id, Prefix); + Set_Type (Id, Get_Designated_Type (Ptr_Type)); + Set_Prefix (Id, Prefix); + Set_Base_Name (Id, Id); + return Id; + else + return Prefix; + end if; + end Maybe_Insert_Dereference; + + procedure Finish_Sem_Indexed_Name (Expr : Iir) + is + Prefix : constant Iir := Get_Prefix (Expr); + Prefix_Type : constant Iir := Get_Type (Prefix); + Index_List : constant Iir_List := Get_Index_List (Expr); + Index_Subtype : Iir; + Index : Iir; + Expr_Staticness : Iir_Staticness; + begin + Expr_Staticness := Locally; + + -- LRM93 §6.4: there must be one such expression for each index + -- position of the array and each expression must be of the + -- type of the corresponding index. + -- Loop on the indexes. + for I in Natural loop + Index_Subtype := Get_Index_Type (Prefix_Type, I); + exit when Index_Subtype = Null_Iir; + Index := Get_Nth_Element (Index_List, I); + -- The index_subtype can be an unconstrained index type. + Index := Check_Is_Expression (Index, Index); + if Index /= Null_Iir then + Index := Sem_Expression (Index, Get_Base_Type (Index_Subtype)); + end if; + if Index /= Null_Iir then + if Get_Expr_Staticness (Index) = Locally + and then Get_Type_Staticness (Index_Subtype) = Locally + then + Index := Eval_Expr_Check (Index, Index_Subtype); + end if; + Replace_Nth_Element (Get_Index_List (Expr), I, Index); + Expr_Staticness := Min (Expr_Staticness, + Get_Expr_Staticness (Index)); + else + Expr_Staticness := None; + end if; + end loop; + + Set_Type (Expr, Get_Element_Subtype (Prefix_Type)); + + -- An indexed name cannot be locally static. + Set_Expr_Staticness + (Expr, Min (Globally, Min (Expr_Staticness, + Get_Expr_Staticness (Prefix)))); + + -- LRM93 §6.1: + -- a name is said to be a static name iff: + -- The name is an indexed name whose prefix is a static name + -- and every expression that appears as part of the name is a + -- static expression. + -- + -- a name is said to be a locally static name iif: + -- The name is an indexed name whose prefix is a locally + -- static name and every expression that appears as part + -- of the name is a locally static expression. + Set_Name_Staticness (Expr, Min (Expr_Staticness, + Get_Name_Staticness (Prefix))); + + Set_Base_Name (Expr, Get_Base_Name (Prefix)); + end Finish_Sem_Indexed_Name; + + procedure Finish_Sem_Dereference (Res : Iir) + is + begin + Set_Base_Name (Res, Res); + Check_Read (Get_Prefix (Res)); + Set_Expr_Staticness (Res, None); + Set_Name_Staticness (Res, None); + end Finish_Sem_Dereference; + + procedure Finish_Sem_Slice_Name (Name : Iir_Slice_Name) + is + -- The prefix of the slice + Prefix : constant Iir := Get_Prefix (Name); + Prefix_Type : constant Iir := Get_Type (Prefix); + Prefix_Base_Type : Iir; + Prefix_Bt : constant Iir := Get_Base_Type (Prefix_Type); + Index_List: Iir_List; + Index_Type: Iir; + Suffix: Iir; + Slice_Type : Iir; + Expr_Type : Iir; + Staticness : Iir_Staticness; + Prefix_Rng : Iir; + begin + Set_Base_Name (Name, Get_Base_Name (Prefix)); + + -- LRM93 §6.5: the prefix of an indexed name must be appropriate + -- for an array type. + if Get_Kind (Prefix_Bt) /= Iir_Kind_Array_Type_Definition then + Error_Msg_Sem ("slice can only be applied to an array", Name); + return; + end if; + + -- LRM93 §6.5: + -- The prefix of a slice must be appropriate for a + -- one-dimensionnal array object. + Index_List := Get_Index_Subtype_List (Prefix_Type); + if Get_Nbr_Elements (Index_List) /= 1 then + Error_Msg_Sem ("slice prefix must be an unidimensional array", Name); + return; + end if; + + Index_Type := Get_Index_Type (Index_List, 0); + Prefix_Rng := Eval_Static_Range (Index_Type); + + -- LRM93 6.5 + -- It is an error if either the bounds of the discrete range does not + -- belong to the index range of the prefixing array, *unless* the slice + -- is a null slice. + -- + -- LRM93 6.5 + -- The slice is a null slice if the discrete range is a null range. + + -- LRM93 §6.5: + -- The bounds of the discrete range [...] must be of the + -- type of the index of the array. + Suffix := Sem_Discrete_Range_Expression + (Get_Suffix (Name), Index_Type, False); + if Suffix = Null_Iir then + return; + end if; + Suffix := Eval_Range_If_Static (Suffix); + Set_Suffix (Name, Suffix); + + -- LRM93 §6.5: + -- It is an error if the direction of the discrete range is not + -- the same as that of the index range of the array denoted + -- by the prefix of the slice name. + + -- Check this only if the type is a constrained type. + if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition + and then Get_Index_Constraint_Flag (Prefix_Type) + and then Get_Expr_Staticness (Suffix) = Locally + and then Prefix_Rng /= Null_Iir + and then Get_Direction (Suffix) /= Get_Direction (Prefix_Rng) + then + if False and then Flags.Vhdl_Std = Vhdl_87 then + -- emit a warning for a null slice. + Warning_Msg_Sem + ("direction mismatch results in a null slice", Name); + end if; + Error_Msg_Sem ("direction of the range mismatch", Name); + end if; + + -- LRM93 §7.4.1 + -- A slice is never a locally static expression. + case Get_Kind (Suffix) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Suffix := Get_Type (Suffix); + Staticness := Get_Type_Staticness (Suffix); + when Iir_Kind_Range_Expression + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Staticness := Get_Expr_Staticness (Suffix); + when others => + Error_Kind ("finish_sem_slice_name", Suffix); + end case; + Set_Expr_Staticness + (Name, Min (Min (Staticness, Get_Expr_Staticness (Prefix)), Globally)); + Set_Name_Staticness + (Name, Min (Staticness, Get_Name_Staticness (Prefix))); + + -- The type of the slice is a subtype of the base type whose + -- range contraint is the slice itself. + if Get_Kind (Suffix) in Iir_Kinds_Discrete_Type_Definition then + Slice_Type := Suffix; + else + case Get_Kind (Get_Base_Type (Index_Type)) is + when Iir_Kind_Integer_Type_Definition => + Slice_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition); + when Iir_Kind_Enumeration_Type_Definition => + Slice_Type := + Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + when others => + Error_Kind ("sem_expr: slice_name", Get_Base_Type (Index_Type)); + end case; + Set_Range_Constraint (Slice_Type, Suffix); + Set_Type_Staticness (Slice_Type, Staticness); + Set_Base_Type (Slice_Type, Get_Base_Type (Index_Type)); + Set_Location (Slice_Type, Get_Location (Suffix)); + end if; + + Expr_Type := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Location (Expr_Type, Get_Location (Suffix)); + Set_Index_Subtype_List (Expr_Type, Create_Iir_List); + Prefix_Base_Type := Get_Base_Type (Prefix_Type); + Set_Base_Type (Expr_Type, Prefix_Base_Type); + Set_Signal_Type_Flag (Expr_Type, + Get_Signal_Type_Flag (Prefix_Base_Type)); + Append_Element (Get_Index_Subtype_List (Expr_Type), Slice_Type); + Set_Element_Subtype (Expr_Type, Get_Element_Subtype (Prefix_Type)); + if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition then + Set_Resolution_Indication + (Expr_Type, Get_Resolution_Indication (Prefix_Type)); + else + Set_Resolution_Indication (Expr_Type, Null_Iir); + end if; + Set_Type_Staticness + (Expr_Type, Min (Get_Type_Staticness (Prefix_Type), + Get_Type_Staticness (Slice_Type))); + Set_Type (Name, Expr_Type); + Set_Slice_Subtype (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; + end Finish_Sem_Slice_Name; + + -- PREFIX is the name denoting the function declaration, and its analysis + -- is already finished. + procedure Finish_Sem_Function_Call (Call : Iir; Prefix : Iir) + is + Rtype : Iir; + begin + Set_Prefix (Call, Prefix); + Set_Implementation (Call, Get_Named_Entity (Prefix)); + + -- LRM08 8.1 Names + -- The name is a simple name or seleted name that does NOT denote a + -- function call [...] + -- + -- GHDL: so function calls are never static names. + Set_Name_Staticness (Call, None); + + -- FIXME: modify sem_subprogram_call to avoid such a type swap. + Rtype := Get_Type (Call); + Set_Type (Call, Null_Iir); + if Sem_Subprogram_Call (Call, Null_Iir) = Null_Iir then + Set_Type (Call, Rtype); + end if; + end Finish_Sem_Function_Call; + + function Sem_Type_Mark (Name : Iir; Incomplete : Boolean := False) + return Iir + is + Atype : Iir; + Res : Iir; + begin + -- The name must not have been analyzed. + pragma Assert (Get_Type (Name) = Null_Iir); + + -- Analyze the name (if not already done). + if Get_Named_Entity (Name) = Null_Iir then + Sem_Name (Name); + end if; + Res := Finish_Sem_Name (Name); + + if Get_Kind (Res) in Iir_Kinds_Denoting_Name then + -- Common correct case. + Atype := Get_Named_Entity (Res); + if Get_Kind (Atype) = Iir_Kind_Type_Declaration then + Atype := Get_Type_Definition (Atype); + elsif Get_Kind (Atype) = Iir_Kind_Subtype_Declaration then + Atype := Get_Type (Atype); + else + Error_Msg_Sem + ("a type mark must denote a type or a subtype", Name); + Atype := Create_Error_Type (Atype); + Set_Named_Entity (Res, Atype); + end if; + else + if Get_Kind (Res) /= Iir_Kind_Error then + Error_Msg_Sem + ("a type mark must be a simple or expanded name", Name); + end if; + Res := Name; + Atype := Create_Error_Type (Name); + Set_Named_Entity (Res, Atype); + end if; + + if not Incomplete then + if Get_Kind (Atype) = Iir_Kind_Incomplete_Type_Definition then + Error_Msg_Sem + ("invalid use of an incomplete type definition", Name); + Atype := Create_Error_Type (Name); + Set_Named_Entity (Res, Atype); + end if; + end if; + + Set_Type (Res, Atype); + + return Res; + end Sem_Type_Mark; + + procedure Finish_Sem_Array_Attribute + (Attr_Name : Iir; Attr : Iir; Param : Iir) + is + Parameter : Iir; + Prefix_Type : Iir; + Index_Type : Iir; + Prefix : Iir; + Prefix_Name : Iir; + Staticness : Iir_Staticness; + begin + -- LRM93 14.1 + -- Parameter: A locally static expression of type universal_integer, the + -- value of which must not exceed the dimensionality of A. If omitted, + -- it defaults to 1. + if Param = Null_Iir then + Parameter := Universal_Integer_One; + else + Parameter := Sem_Expression + (Param, Universal_Integer_Type_Definition); + if Parameter = Null_Iir then + Parameter := Universal_Integer_One; + else + if Get_Expr_Staticness (Parameter) /= Locally then + Error_Msg_Sem ("parameter must be locally static", Parameter); + Parameter := Universal_Integer_One; + end if; + end if; + end if; + + Prefix_Name := Get_Prefix (Attr_Name); + if Is_Type_Name (Prefix_Name) /= Null_Iir then + Prefix := Sem_Type_Mark (Prefix_Name); + else + Prefix := Finish_Sem_Name (Prefix_Name, Get_Prefix (Attr)); + end if; + Set_Prefix (Attr, Prefix); + + Prefix_Type := Get_Type (Prefix); + if Is_Error (Prefix_Type) then + return; + end if; + + declare + Dim : Iir_Int64; + Indexes_List : constant Iir_List := + Get_Index_Subtype_List (Prefix_Type); + begin + Dim := Get_Value (Parameter); + if Dim < 1 or else Dim > Iir_Int64 (Get_Nbr_Elements (Indexes_List)) + then + Error_Msg_Sem ("parameter value out of bound", Attr); + Parameter := Universal_Integer_One; + Dim := 1; + end if; + Index_Type := Get_Index_Type (Indexes_List, Natural (Dim - 1)); + end; + + case Get_Kind (Attr) is + when Iir_Kind_Left_Array_Attribute + | Iir_Kind_Right_Array_Attribute + | Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute => + Set_Type (Attr, Index_Type); + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Set_Type (Attr, Index_Type); + when Iir_Kind_Length_Array_Attribute => + Set_Type (Attr, Convertible_Integer_Type_Definition); + when Iir_Kind_Ascending_Array_Attribute => + Set_Type (Attr, Boolean_Type_Definition); + when others => + raise Internal_Error; + end case; + + pragma Assert (Get_Parameter (Attr) = Null_Iir); + + Set_Parameter (Attr, Parameter); + + -- If the corresponding type is known, save it so that it is not + -- necessary to extract it from the object. + if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition + and then Get_Constraint_State (Prefix_Type) = Fully_Constrained + then + Set_Index_Subtype (Attr, Index_Type); + end if; + + -- LRM 7.4.1 + -- A locally static range is either [...], or a range of the first form + -- whose prefix denotes either a locally static subtype or an object + -- that is of a locally static subtype. + + -- LRM 7.4.2 + -- A globally static range is either [...], or a range of the first form + -- whose prefix denotes either a globally static subtype or an object + -- that is of a globally static subtype. + -- + -- A globally static subtype is either a globally static scalar subtype, + -- a globally static array subtype, [...] + -- + -- A globally static array subtype is a constrained array subtype + -- formed by imposing on an unconstrained array type a globally static + -- index constraint. + Staticness := Get_Type_Staticness (Prefix_Type); + if Flags.Vhdl_Std = Vhdl_93c + and then Get_Kind (Prefix) not in Iir_Kinds_Type_Declaration + then + -- For 93c: + -- if the prefix is a static expression, the staticness of the + -- expression may be higher than the staticness of the type + -- (eg: generic whose type is an unconstrained array). + -- Also consider expression staticness. + Staticness := Iir_Staticness'Max (Staticness, + Get_Expr_Staticness (Prefix)); + end if; + Set_Expr_Staticness (Attr, Staticness); + end Finish_Sem_Array_Attribute; + + procedure Finish_Sem_Scalar_Type_Attribute + (Attr_Name : Iir; Attr : Iir; Param : Iir) + is + Prefix : Iir; + Prefix_Type : Iir; + Prefix_Bt : Iir; + Parameter : Iir; + Param_Type : Iir; + begin + if Param = Null_Iir then + Error_Msg_Sem (Disp_Node (Attr) & " requires a parameter", Attr); + return; + end if; + + Prefix := Get_Prefix (Attr); + if Get_Kind (Prefix) = Iir_Kind_Attribute_Name then + Prefix := Finish_Sem_Name (Prefix); + Set_Prefix (Attr, Prefix); + pragma Assert (Get_Kind (Prefix) = Iir_Kind_Base_Attribute); + else + Prefix := Sem_Type_Mark (Prefix); + end if; + Set_Prefix (Attr, Prefix); + Free_Iir (Attr_Name); + Prefix_Type := Get_Type (Prefix); + Prefix_Bt := Get_Base_Type (Prefix_Type); + + case Get_Kind (Attr) is + when Iir_Kind_Pos_Attribute => + -- LRM93 14.1 + -- Parameter: An expression whose type is the base type of T. + Parameter := Sem_Expression (Param, Prefix_Bt); + when Iir_Kind_Val_Attribute => + -- LRM93 14.1 + -- Parameter: An expression of any integer type. + Param_Type := Get_Type (Param); + if Is_Overload_List (Param_Type) then + Parameter := Sem_Expression + (Param, Universal_Integer_Type_Definition); + else + if Get_Kind (Get_Base_Type (Param_Type)) + /= Iir_Kind_Integer_Type_Definition + then + Error_Msg_Sem ("parameter must be an integer", Attr); + return; + end if; + Parameter := Param; + end if; + when Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute + | Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute => + -- LRM93 14.1 + -- Parameter: An expression whose type is the base type of T. + Parameter := Sem_Expression (Param, Prefix_Bt); + when Iir_Kind_Image_Attribute => + -- LRM93 14.1 + -- Parameter: An expression whose type is the base type of T. + Parameter := Sem_Expression (Param, Prefix_Bt); + when Iir_Kind_Value_Attribute => + -- Parameter: An expression of type string. + Parameter := Sem_Expression (Param, String_Type_Definition); + when others => + raise Internal_Error; + end case; + if Get_Parameter (Attr) /= Null_Iir then + raise Internal_Error; + end if; + if Parameter = Null_Iir then + Set_Parameter (Attr, Param); + Set_Expr_Staticness (Attr, None); + return; + end if; + Set_Parameter (Attr, Parameter); + Set_Expr_Staticness (Attr, Min (Get_Type_Staticness (Prefix_Type), + Get_Expr_Staticness (Parameter))); + Set_Name_Staticness (Attr, Get_Expr_Staticness (Attr)); + end Finish_Sem_Scalar_Type_Attribute; + + procedure Finish_Sem_Signal_Attribute + (Attr_Name : Iir; Attr : Iir; Parameter : Iir) + is + Param : Iir; + Prefix : Iir; + Prefix_Name : Iir; + begin + Prefix_Name := Get_Prefix (Attr_Name); + Prefix := Finish_Sem_Name (Prefix_Name, Get_Prefix (Attr)); + Set_Prefix (Attr, Prefix); + Free_Iir (Attr_Name); + + if Parameter = Null_Iir then + return; + end if; + if Get_Kind (Attr) = Iir_Kind_Transaction_Attribute then + Error_Msg_Sem ("'transaction does not allow a parameter", Attr); + else + Param := Sem_Expression (Parameter, Time_Subtype_Definition); + if Param /= Null_Iir then + -- LRM93 14.1 + -- Parameter: A static expression of type TIME [that evaluate + -- to a nonnegative value.] + if Get_Expr_Staticness (Param) = None then + Error_Msg_Sem + ("parameter of signal attribute must be static", Param); + end if; + Set_Parameter (Attr, Param); + end if; + end if; + end Finish_Sem_Signal_Attribute; + + function Is_Type_Abstract_Numeric (Atype : Iir) return Boolean is + begin + case Get_Kind (Atype) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition => + return True; + when others => + return False; + end case; + end Is_Type_Abstract_Numeric; + + function Are_Types_Closely_Related (Type1, Type2 : Iir) return Boolean + is + Base_Type1 : constant Iir := Get_Base_Type (Type1); + Base_Type2 : constant Iir := Get_Base_Type (Type2); + Ant1, Ant2 : Boolean; + Index_List1, Index_List2 : Iir_List; + El1, El2 : Iir; + begin + -- LRM 7.3.5 + -- In particular, a type is closely related to itself. + if Base_Type1 = Base_Type2 then + return True; + end if; + + -- LRM 7.3.5 + -- a) Abstract Numeric Types: Any abstract numeric type is closely + -- related to any other abstract numeric type. + Ant1 := Is_Type_Abstract_Numeric (Type1); + Ant2 := Is_Type_Abstract_Numeric (Type2); + if Ant1 and Ant2 then + return True; + end if; + if Ant1 or Ant2 then + return False; + end if; + + -- LRM 7.3.5 + -- b) Array Types: Two array types are closely related if and only if + -- The types have the same dimensionality; For each index position, + -- the index types are either the same or are closely related; and + -- The element types are the same. + -- + -- No other types are closely related. + if not (Get_Kind (Base_Type1) = Iir_Kind_Array_Type_Definition + and then Get_Kind (Base_Type2) = Iir_Kind_Array_Type_Definition) + then + return False; + end if; + Index_List1 := Get_Index_Subtype_List (Base_Type1); + Index_List2 := Get_Index_Subtype_List (Base_Type2); + if Get_Nbr_Elements (Index_List1) /= Get_Nbr_Elements (Index_List2) then + return False; + end if; + if Get_Base_Type (Get_Element_Subtype (Base_Type1)) + /= Get_Base_Type (Get_Element_Subtype (Base_Type2)) + then + return False; + end if; + for I in Natural loop + El1 := Get_Index_Type (Index_List1, I); + exit when El1 = Null_Iir; + El2 := Get_Index_Type (Index_List2, I); + if not Are_Types_Closely_Related (El1, El2) then + return False; + end if; + end loop; + return True; + end Are_Types_Closely_Related; + + function Sem_Type_Conversion (Loc : Iir; Type_Mark : Iir; Actual : Iir) + return Iir + is + Conv_Type : constant Iir := Get_Type (Type_Mark); + Conv: Iir_Type_Conversion; + Expr: Iir; + Staticness : Iir_Staticness; + begin + Conv := Create_Iir (Iir_Kind_Type_Conversion); + Location_Copy (Conv, Loc); + Set_Type_Mark (Conv, Type_Mark); + Set_Type (Conv, Conv_Type); + Set_Expression (Conv, Actual); + + -- Default staticness in case of error. + Set_Expr_Staticness (Conv, None); + + -- Bail out if no actual (or invalid one). + if Actual = Null_Iir then + return Conv; + end if; + + -- LRM93 7.3.5 + -- Furthermore, the operand of a type conversion is not allowed to be + -- the literal null, an allocator, an aggregate, or a string literal. + case Get_Kind (Actual) is + when Iir_Kind_Null_Literal + | Iir_Kind_Aggregate + | Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + Error_Msg_Sem + (Disp_Node (Actual) & " cannot be a type conversion operand", + Actual); + return Conv; + when others => + -- LRM93 7.3.5 + -- The type of the operand of a type conversion must be + -- determinable independent of the context (in particular, + -- independent of the target type). + Expr := Sem_Expression_Universal (Actual); + if Expr = Null_Iir then + return Conv; + end if; + if Get_Kind (Expr) in Iir_Kinds_Allocator then + Error_Msg_Sem + (Disp_Node (Expr) & " cannot be a type conversion operand", + Expr); + end if; + Set_Expression (Conv, Expr); + end case; + + -- LRM93 7.4.1 Locally Static Primaries. + -- 9. a type conversion whose expression is a locally static expression. + -- LRM93 7.4.2 Globally Static Primaries. + -- 14. a type conversion whose expression is a globally static + -- expression. + if Expr /= Null_Iir then + Staticness := Get_Expr_Staticness (Expr); + + -- If the type mark is not locally static, the expression cannot + -- be locally static. This was clarified in VHDL 08, but a type + -- mark that denotes an unconstrained array type, does not prevent + -- the expression from being static. + if Get_Kind (Conv_Type) not in Iir_Kinds_Array_Type_Definition + or else Get_Constraint_State (Conv_Type) = Fully_Constrained + then + Staticness := Min (Staticness, Get_Type_Staticness (Conv_Type)); + end if; + + -- LRM87 7.4 Static Expressions + -- A type conversion is not a locally static expression. + if Flags.Vhdl_Std = Vhdl_87 then + Staticness := Min (Globally, Staticness); + end if; + Set_Expr_Staticness (Conv, Staticness); + + if not Are_Types_Closely_Related (Conv_Type, Get_Type (Expr)) + then + -- FIXME: should explain why the types are not closely related. + Error_Msg_Sem + ("conversion not allowed between not closely related types", + Conv); + -- Avoid error storm in evaluation. + Set_Expr_Staticness (Conv, None); + else + Check_Read (Expr); + end if; + end if; + return Conv; + end Sem_Type_Conversion; + + -- OBJ is an 'impure' object (variable, signal or file) referenced at + -- location LOC. + -- Check the pure rules (LRM08 4 Subprograms and packages, + -- LRM08 4.3 Subprograms bodies). + procedure Sem_Check_Pure (Loc : Iir; Obj : Iir) + is + procedure Update_Impure_Depth (Subprg_Spec : Iir; Depth : Iir_Int32) + is + Bod : Iir; + begin + Bod := Get_Subprogram_Body (Subprg_Spec); + if Bod = Null_Iir then + return; + end if; + if Depth < Get_Impure_Depth (Bod) then + Set_Impure_Depth (Bod, Depth); + end if; + end Update_Impure_Depth; + + procedure Error_Pure (Subprg : Iir; Obj : Iir) + is + begin + Error_Msg_Sem + ("reference to " & Disp_Node (Obj) & " violate pure rule for " + & Disp_Node (Subprg), Loc); + end Error_Pure; + + Subprg : constant Iir := Sem_Stmts.Get_Current_Subprogram; + Subprg_Body : Iir; + Parent : Iir; + begin + -- Apply only in subprograms. + if Subprg = Null_Iir then + return; + end if; + case Get_Kind (Subprg) is + when Iir_Kinds_Process_Statement => + return; + when Iir_Kind_Procedure_Declaration => + -- Exit now if already known as impure. + if Get_Purity_State (Subprg) = Impure then + return; + end if; + when Iir_Kind_Function_Declaration => + -- Exit now if impure. + if Get_Pure_Flag (Subprg) = False then + return; + end if; + when others => + Error_Kind ("sem_check_pure", Subprg); + end case; + + -- Not all objects are impure. + case Get_Kind (Obj) is + when Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_File_Declaration => + null; + when Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration => + -- When referenced as a formal name (FIXME: this is an + -- approximation), the rules don't apply. + if not Get_Is_Within_Flag (Get_Parent (Obj)) then + return; + end if; + when Iir_Kind_File_Declaration => + -- LRM 93 2.2 + -- If a pure function is the parent of a given procedure, then + -- that procedure must not contain a reference to an explicitly + -- declared file object [...] + -- + -- A pure function must not contain a reference to an explicitly + -- declared file. + if Flags.Vhdl_Std > Vhdl_93c then + if Get_Kind (Subprg) = Iir_Kind_Function_Declaration then + Error_Pure (Subprg, Obj); + else + Set_Purity_State (Subprg, Impure); + Set_Impure_Depth (Get_Subprogram_Body (Subprg), + Iir_Depth_Impure); + end if; + end if; + return; + when others => + return; + end case; + + -- OBJ is declared in the immediate declarative part of the subprogram. + Parent := Get_Parent (Obj); + Subprg_Body := Get_Subprogram_Body (Subprg); + if Parent = Subprg or else Parent = Subprg_Body then + return; + end if; + + -- Function. + if Get_Kind (Subprg) = Iir_Kind_Function_Declaration then + Error_Pure (Subprg, Obj); + return; + end if; + + case Get_Kind (Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kinds_Process_Statement + | Iir_Kind_Protected_Type_Body => + -- The procedure is impure. + Set_Purity_State (Subprg, Impure); + Set_Impure_Depth (Subprg_Body, Iir_Depth_Impure); + return; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Update_Impure_Depth + (Subprg, + Get_Subprogram_Depth (Get_Subprogram_Specification (Parent))); + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Update_Impure_Depth (Subprg, Get_Subprogram_Depth (Parent)); + when others => + Error_Kind ("sem_check_pure(2)", Parent); + end case; + end Sem_Check_Pure; + + -- Set All_Sensitized_State to False iff OBJ is a signal declaration + -- and the current subprogram is in a package body. + procedure Sem_Check_All_Sensitized (Obj : Iir) + is + Subprg : Iir; + begin + -- We cares only of signals. + if Get_Kind (Obj) /= Iir_Kind_Signal_Declaration then + return; + end if; + -- We cares only of subprograms. Give up if we are in a process. + Subprg := Sem_Stmts.Get_Current_Subprogram; + if Subprg = Null_Iir + or else Get_Kind (Subprg) not in Iir_Kinds_Subprogram_Declaration + then + return; + end if; + if Get_Kind (Get_Library_Unit (Sem.Get_Current_Design_Unit)) + = Iir_Kind_Package_Body + then + Set_All_Sensitized_State (Subprg, Invalid_Signal); + else + Set_All_Sensitized_State (Subprg, Read_Signal); + end if; + end Sem_Check_All_Sensitized; + + function Finish_Sem_Denoting_Name (Name : Iir; Res : Iir) return Iir + is + Prefix : Iir; + begin + case Iir_Kinds_Denoting_Name (Get_Kind (Name)) is + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Operator_Symbol => + Xref_Ref (Name, Res); + return Name; + when Iir_Kind_Selected_Name => + Xref_Ref (Name, Res); + Prefix := Get_Prefix (Name); + loop + pragma Assert (Get_Kind (Prefix) in Iir_Kinds_Denoting_Name); + Xref_Ref (Prefix, Get_Named_Entity (Prefix)); + exit when Get_Kind (Prefix) /= Iir_Kind_Selected_Name; + Prefix := Get_Prefix (Prefix); + end loop; + return Name; + end case; + end Finish_Sem_Denoting_Name; + + function Finish_Sem_Name_1 (Name : Iir; Res : Iir) return Iir + is + Prefix : Iir; + Name_Prefix : Iir; + Name_Res : Iir; + begin + case Get_Kind (Res) is + when Iir_Kinds_Library_Unit_Declaration => + return Finish_Sem_Denoting_Name (Name, Res); + when Iir_Kinds_Sequential_Statement + | Iir_Kinds_Concurrent_Statement => + -- Label or part of an expanded name (for process, block + -- and generate). + return Finish_Sem_Denoting_Name (Name, Res); + when Iir_Kinds_Object_Declaration + | Iir_Kinds_Quantity_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Unit_Declaration => + Name_Res := Finish_Sem_Denoting_Name (Name, Res); + Set_Base_Name (Name_Res, Res); + Set_Name_Staticness (Name_Res, Get_Name_Staticness (Res)); + Set_Expr_Staticness (Name_Res, Get_Expr_Staticness (Res)); + Sem_Check_Pure (Name_Res, Res); + Sem_Check_All_Sensitized (Res); + Set_Type (Name_Res, Get_Type (Res)); + return Name_Res; + when Iir_Kind_Attribute_Value => + pragma Assert (Get_Kind (Name) = Iir_Kind_Attribute_Name); + Prefix := Finish_Sem_Name (Get_Prefix (Name)); + Set_Prefix (Name, Prefix); + Set_Base_Name (Name, Res); + Set_Type (Name, Get_Type (Res)); + Set_Name_Staticness (Name, Get_Name_Staticness (Res)); + Set_Expr_Staticness (Name, Get_Expr_Staticness (Res)); + return Name; + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Library_Declaration + | Iir_Kind_Interface_Package_Declaration => + Name_Res := Finish_Sem_Denoting_Name (Name, Res); + Set_Base_Name (Name_Res, Res); + return Name_Res; + when Iir_Kinds_Function_Declaration => + Name_Res := Finish_Sem_Denoting_Name (Name, Res); + Set_Type (Name_Res, Get_Return_Type (Res)); + return Name_Res; + when Iir_Kinds_Procedure_Declaration => + return Finish_Sem_Denoting_Name (Name, Res); + when Iir_Kind_Type_Conversion => + pragma Assert (Get_Kind (Name) = Iir_Kind_Parenthesis_Name); + Set_Type_Mark (Res, Sem_Type_Mark (Get_Prefix (Name))); + Free_Parenthesis_Name (Name, Res); + return Res; + when Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Slice_Name + | Iir_Kind_Dereference => + -- Fall through. + null; + when Iir_Kind_Implicit_Dereference => + -- The name may not have a prefix. + Prefix := Finish_Sem_Name (Name, Get_Prefix (Res)); + Set_Prefix (Res, Prefix); + Finish_Sem_Dereference (Res); + return Res; + when Iir_Kind_Function_Call => + case Get_Kind (Name) is + when Iir_Kind_Parenthesis_Name => + Prefix := Finish_Sem_Name + (Get_Prefix (Name), Get_Implementation (Res)); + Finish_Sem_Function_Call (Res, Prefix); + Free_Iir (Name); + when Iir_Kinds_Denoting_Name => + Prefix := Finish_Sem_Name (Name, Get_Implementation (Res)); + Finish_Sem_Function_Call (Res, Prefix); + when others => + Error_Kind ("Finish_Sem_Name(function call)", Name); + end case; + return Res; + when Iir_Kinds_Array_Attribute => + if Get_Parameter (Res) = Null_Iir then + Finish_Sem_Array_Attribute (Name, Res, Null_Iir); + end if; + if Get_Kind (Name) = Iir_Kind_Attribute_Name then + Free_Iir (Name); + else + Free_Iir (Get_Prefix (Name)); + Free_Parenthesis_Name (Name, Res); + end if; + return Res; + when Iir_Kinds_Scalar_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute => + if Get_Parameter (Res) = Null_Iir then + Finish_Sem_Scalar_Type_Attribute (Name, Res, Null_Iir); + else + Free_Parenthesis_Name (Name, Res); + end if; + return Res; + when Iir_Kinds_Signal_Value_Attribute => + null; + when Iir_Kinds_Signal_Attribute => + if Get_Parameter (Res) = Null_Iir then + Finish_Sem_Signal_Attribute (Name, Res, Null_Iir); + else + Free_Parenthesis_Name (Name, Res); + end if; + return Res; + when Iir_Kinds_Type_Attribute => + Free_Iir (Name); + return Res; + when Iir_Kind_Base_Attribute => + return Res; + when Iir_Kind_Simple_Name_Attribute + | Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + Free_Iir (Name); + return Res; + when Iir_Kind_Psl_Expression => + return Res; + when Iir_Kind_Psl_Declaration => + return Name; + when Iir_Kind_Element_Declaration + | Iir_Kind_Error => + -- Certainly an error! + return Res; + when others => + Error_Kind ("finish_sem_name", Res); + end case; + + -- Finish prefix. + Prefix := Get_Prefix (Res); + Name_Prefix := Get_Prefix (Name); + Prefix := Finish_Sem_Name_1 (Name_Prefix, Prefix); + Set_Prefix (Res, Prefix); + + case Get_Kind (Res) is + when Iir_Kind_Indexed_Name => + Finish_Sem_Indexed_Name (Res); + Free_Parenthesis_Name (Name, Res); + when Iir_Kind_Slice_Name => + Finish_Sem_Slice_Name (Res); + Free_Parenthesis_Name (Name, Res); + when Iir_Kind_Selected_Element => + pragma Assert (Get_Kind (Name) = Iir_Kind_Selected_Name); + Xref_Ref (Res, Get_Selected_Element (Res)); + Set_Name_Staticness (Res, Get_Name_Staticness (Prefix)); + Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix)); + Set_Base_Name (Res, Get_Base_Name (Prefix)); + Free_Iir (Name); + when Iir_Kind_Dereference => + pragma Assert (Get_Kind (Name) = Iir_Kind_Selected_By_All_Name); + Finish_Sem_Dereference (Res); + Free_Iir (Name); + when Iir_Kinds_Signal_Value_Attribute => + Sem_Name_Free_Result (Name, Res); + when others => + Error_Kind ("finish_sem_name(2)", Res); + end case; + return Res; + end Finish_Sem_Name_1; + + function Finish_Sem_Name (Name : Iir; Res : Iir) return Iir + is + Old_Res : Iir; + begin + if Get_Kind (Res) /= Iir_Kind_Implicit_Dereference then + Old_Res := Get_Named_Entity (Name); + if Old_Res /= Null_Iir and then Old_Res /= Res then + pragma Assert (Is_Overload_List (Old_Res)); + Sem_Name_Free_Result (Old_Res, Res); + end if; + Set_Named_Entity (Name, Res); + end if; + return Finish_Sem_Name_1 (Name, Res); + end Finish_Sem_Name; + + function Finish_Sem_Name (Name : Iir) return Iir is + begin + return Finish_Sem_Name_1 (Name, Get_Named_Entity (Name)); + end Finish_Sem_Name; + + -- LRM93 6.2 + -- The evaluation of a simple name has no other effect than to determine + -- the named entity denoted by the name. + -- + -- NAME may be a simple name, a strig literal or a character literal. + -- GHDL: set interpretation of NAME (possibly an overload list) or + -- error_mark for unknown names. + -- If SOFT is TRUE, then no error message is reported in case of failure. + procedure Sem_Simple_Name (Name : Iir; Keep_Alias : Boolean; Soft : Boolean) + is + Id : constant Name_Id := Get_Identifier (Name); + Interpretation: Name_Interpretation_Type; + Res: Iir; + Res_List : Iir_List; + N : Natural; + begin + Interpretation := Get_Interpretation (Id); + + if not Valid_Interpretation (Interpretation) then + -- Unknown name. + if not Soft then + Error_Msg_Sem + ("no declaration for """ & Image_Identifier (Name) & """", Name); + end if; + Res := Error_Mark; + elsif not Valid_Interpretation (Get_Next_Interpretation (Interpretation)) + then + -- One simple interpretation. + Res := Get_Declaration (Interpretation); + + -- For a design unit, return the library unit + if Get_Kind (Res) = Iir_Kind_Design_Unit then + -- FIXME: should replace interpretation ? + Libraries.Load_Design_Unit (Res, Name); + Sem.Add_Dependence (Res); + Res := Get_Library_Unit (Res); + end if; + + -- Check visibility. + if not Get_Visible_Flag (Res) then + if Flag_Relaxed_Rules + and then Get_Kind (Res) in Iir_Kinds_Object_Declaration + and then Valid_Interpretation (Get_Under_Interpretation (Id)) + then + Res := Get_Declaration (Get_Under_Interpretation (Id)); + else + if not Soft then + Error_Msg_Sem + (Disp_Node (Res) & " is not visible here", Name); + end if; + -- Even if a named entity was found, return an error_mark. + -- Indeed, the named entity found is certainly the one being + -- semantized, and the semantization may be uncomplete. + Res := Error_Mark; + end if; + end if; + + if not Keep_Alias + and then Get_Kind (Res) = Iir_Kind_Non_Object_Alias_Declaration + then + Set_Alias_Declaration (Name, Res); + Res := Get_Named_Entity (Get_Name (Res)); + end if; + else + -- Name is overloaded. + Res_List := Create_Iir_List; + N := 0; + -- The SEEN_FLAG is used to get only one meaning which can be reached + -- through several pathes (such as aliases). + while Valid_Interpretation (Interpretation) loop + if Keep_Alias then + Res := Get_Declaration (Interpretation); + else + Res := Get_Non_Alias_Declaration (Interpretation); + end if; + if not Get_Seen_Flag (Res) then + Set_Seen_Flag (Res, True); + N := N + 1; + Append_Element (Res_List, Res); + end if; + Interpretation := Get_Next_Interpretation (Interpretation); + end loop; + + -- FIXME: there can be only one element (a function and its alias!). + + -- Clear SEEN_FLAG. + for I in 0 .. N - 1 loop + Res := Get_Nth_Element (Res_List, I); + Set_Seen_Flag (Res, False); + end loop; + + Res := Create_Overload_List (Res_List); + end if; + + Set_Base_Name (Name, Res); + Set_Named_Entity (Name, Res); + end Sem_Simple_Name; + + -- LRM93 §6.3 + -- Selected Names. + procedure Sem_Selected_Name (Name: Iir; Keep_Alias : Boolean := False) + is + Suffix : constant Name_Id := Get_Identifier (Name); + Prefix_Name : constant Iir := Get_Prefix (Name); + Prefix_Loc : constant Location_Type := Get_Location (Prefix_Name); + + Prefix: Iir; + Res : Iir; + + -- Semantize SUB_NAME.NAME as an expanded name (ie, NAME is declared + -- within SUB_NAME). This is possible only if the expanded name is + -- analyzed within the context of SUB_NAME. + procedure Sem_As_Expanded_Name (Sub_Name : Iir) + is + Sub_Res : Iir; + begin + if Get_Is_Within_Flag (Sub_Name) then + Sub_Res := Find_Declarations_In_List (Sub_Name, Name, Keep_Alias); + if Sub_Res /= Null_Iir then + Add_Result (Res, Sub_Res); + end if; + end if; + end Sem_As_Expanded_Name; + + -- LRM93 §6.3 + -- For a selected name that is used to denote a record element, + -- the suffix must be a simple name denoting an element of a + -- record object or value. The prefix must be appropriate for the + -- type of this object or value. + -- + -- Semantize SUB_NAME.NAME as a selected element. + procedure Sem_As_Selected_Element (Sub_Name : Iir) + is + Base_Type : Iir; + Ptr_Type : Iir; + Rec_El : Iir; + R : Iir; + Se : Iir; + begin + -- FIXME: if not is_expr (sub_name) return. + Base_Type := Get_Base_Type (Get_Type (Sub_Name)); + if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition then + Ptr_Type := Base_Type; + Base_Type := Get_Base_Type (Get_Designated_Type (Base_Type)); + else + Ptr_Type := Null_Iir; + end if; + + if Get_Kind (Base_Type) /= Iir_Kind_Record_Type_Definition then + return; + end if; + + Rec_El := Find_Name_In_List + (Get_Elements_Declaration_List (Base_Type), Suffix); + if Rec_El = Null_Iir then + return; + end if; + + if not Maybe_Function_Call (Sub_Name) then + return; + end if; + + R := Maybe_Insert_Function_Call (Prefix_Name, Sub_Name); + R := Maybe_Insert_Dereference (R, Ptr_Type); + + Se := Create_Iir (Iir_Kind_Selected_Element); + Location_Copy (Se, Name); + Set_Prefix (Se, R); + Set_Type (Se, Get_Type (Rec_El)); + Set_Selected_Element (Se, Rec_El); + Set_Base_Name (Se, Get_Object_Prefix (R, False)); + Add_Result (Res, Se); + end Sem_As_Selected_Element; + + procedure Error_Selected_Element (Prefix_Type : Iir) + is + Base_Type : Iir; + begin + Base_Type := Get_Base_Type (Prefix_Type); + if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition then + Base_Type := Get_Base_Type (Get_Designated_Type (Base_Type)); + end if; + if Get_Kind (Base_Type) /= Iir_Kind_Record_Type_Definition then + Error_Msg_Sem + (Disp_Node (Prefix) & " does not designate a record", Name); + else + Error_Msg_Sem + ("no element """ & Name_Table.Image (Suffix) + & """ in " & Disp_Node (Base_Type), Name); + end if; + end Error_Selected_Element; + + procedure Sem_As_Protected_Item (Sub_Name : Iir) + is + Prot_Type : constant Iir := Get_Type (Sub_Name); + Method : Iir; + begin + -- LRM98 12.3 Visibility + -- s) For a subprogram declared immediately within a given protected + -- type declaration: at the place of the suffix in a selected + -- name whose prefix denotes an object of the protected type. + Method := Get_Declaration_Chain (Prot_Type); + while Method /= Null_Iir loop + case Get_Kind (Method) is + when Iir_Kind_Function_Declaration | + Iir_Kind_Procedure_Declaration => + if Get_Identifier (Method) = Suffix then + Add_Result (Res, Method); + end if; + when Iir_Kind_Attribute_Specification + | Iir_Kind_Use_Clause => + null; + when others => + Error_Kind ("sem_as_protected_item", Method); + end case; + Method := Get_Chain (Method); + end loop; + end Sem_As_Protected_Item; + + procedure Error_Protected_Item (Prot_Type : Iir) is + begin + Error_Msg_Sem + ("no method " & Name_Table.Image (Suffix) & " in " + & Disp_Node (Prot_Type), Name); + end Error_Protected_Item; + begin + -- Analyze prefix. + Sem_Name (Prefix_Name); + Prefix := Get_Named_Entity (Prefix_Name); + if Prefix = Error_Mark then + Set_Named_Entity (Name, Prefix); + return; + end if; + + Res := Null_Iir; + + case Get_Kind (Prefix) is + when Iir_Kind_Overload_List => + -- LRM93 6.3 + -- If, according to the visibility rules, there is at + -- least one possible interpretation of the prefix of a + -- selected name as the name of an enclosing entity + -- interface, architecture, subprogram, block statement, + -- process statement, generate statement, or loop + -- statement, then the only interpretations considered are + -- those of the immediately preceding paragraph. + -- + -- In this case, the selected name is always interpreted + -- as an expanded name. In particular, no interpretations + -- of the prefix as a function call are considered. + declare + Prefix_List : Iir_List; + El : Iir; + begin + -- So, first try as expanded name. + Prefix_List := Get_Overload_List (Prefix); + for I in Natural loop + El := Get_Nth_Element (Prefix_List, I); + exit when El = Null_Iir; + Sem_As_Expanded_Name (El); + end loop; + + -- If no expanded name are found, try as selected element. + if Res = Null_Iir then + for I in Natural loop + El := Get_Nth_Element (Prefix_List, I); + exit when El = Null_Iir; + Sem_As_Selected_Element (El); + end loop; + end if; + end; + if Res = Null_Iir then + Error_Msg_Sem ("no suffix """ & Name_Table.Image (Suffix) + & """ for overloaded selected name", Name); + end if; + when Iir_Kind_Library_Declaration => + -- LRM93 6.3 + -- An expanded name denotes a primary unit constained in a design + -- library if the prefix denotes the library and the suffix is the + -- simple name if a primary unit whose declaration is contained + -- in that library. + -- An expanded name is not allowed for a secondary unit, + -- particularly for an architecture body. + -- GHDL: FIXME: error message more explicit + Res := Libraries.Load_Primary_Unit (Prefix, Suffix, Name); + if Res = Null_Iir then + Error_Msg_Sem + ("primary unit """ & Name_Table.Image (Suffix) + & """ not found in " & Disp_Node (Prefix), Name); + else + Sem.Add_Dependence (Res); + Res := Get_Library_Unit (Res); + end if; + when Iir_Kind_Process_Statement + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Architecture_Body + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Generate_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_For_Loop_Statement => + -- LRM93 §6.3 + -- An expanded name denotes a named entity declared immediatly + -- within a named construct if the prefix that is an entity + -- interface, an architecture, a subprogram, a block statement, + -- a process statement, a generate statement, or a loop + -- statement, and the suffix is the simple name, character + -- literal, or operator symbol of an named entity whose + -- declaration occurs immediatly within that construct. + if Get_Kind (Prefix) = Iir_Kind_Design_Unit then + Libraries.Load_Design_Unit (Prefix, Name); + Sem.Add_Dependence (Prefix); + Prefix := Get_Library_Unit (Prefix); + -- Modified only for xrefs, since a design_unit points to + -- the first context clause, while a library unit points to + -- the identifier. + Set_Named_Entity (Get_Prefix (Name), Prefix); + end if; + + Res := Find_Declarations_In_List (Prefix, Name, Keep_Alias); + + if Res = Null_Iir then + Error_Msg_Sem + ("no declaration for """ & Name_Table.Image (Suffix) + & """ in " & Disp_Node (Prefix), Name); + else + -- LRM93 §6.3 + -- This form of expanded name is only allowed within the + -- construct itself. + if not Kind_In (Prefix, + Iir_Kind_Package_Declaration, + Iir_Kind_Package_Instantiation_Declaration) + and then not Get_Is_Within_Flag (Prefix) + then + Error_Msg_Sem + ("this expanded name is only allowed within the construct", + Prefix_Loc); + -- Hum, keep res. + end if; + end if; + when Iir_Kind_Function_Declaration => + Sem_As_Expanded_Name (Prefix); + if Res = Null_Iir then + Sem_As_Selected_Element (Prefix); + end if; + if Res = Null_Iir then + Error_Selected_Element (Get_Return_Type (Prefix)); + end if; + when Iir_Kinds_Object_Declaration + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Attribute_Value + | Iir_Kind_Function_Call => + if Get_Kind (Get_Type (Prefix)) + = Iir_Kind_Protected_Type_Declaration + then + Sem_As_Protected_Item (Prefix); + if Res = Null_Iir then + Error_Protected_Item (Prefix); + end if; + else + Sem_As_Selected_Element (Prefix); + if Res = Null_Iir then + Error_Selected_Element (Get_Type (Prefix)); + end if; + end if; + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Slice_Name => + Error_Msg_Sem + (Disp_Node (Prefix) & " cannot be selected by name", Prefix_Loc); + + when others => + Error_Kind ("sem_selected_name(2)", Prefix); + end case; + if Res = Null_Iir then + Res := Error_Mark; + end if; + Set_Named_Entity (Name, Res); + end Sem_Selected_Name; + + -- If ASSOC_LIST has one element, which is an expression without formal, + -- return the actual, else return NULL_IIR. + function Get_One_Actual (Assoc_Chain : Iir) return Iir + is + Assoc : Iir; + begin + -- Only one actual ? + if Assoc_Chain = Null_Iir or else Get_Chain (Assoc_Chain) /= Null_Iir + then + return Null_Iir; + end if; + + -- Not 'open' association element ? + Assoc := Assoc_Chain; + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then + return Null_Iir; + end if; + + -- Not an association (ie no formal) ? + if Get_Formal (Assoc) /= Null_Iir then + return Null_Iir; + end if; + + return Get_Actual (Assoc); + end Get_One_Actual; + + function Slice_Or_Index (Actual : Iir) return Iir_Kind is + begin + -- But it may be a slice name. + case Get_Kind (Actual) is + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Range_Expression => + return Iir_Kind_Slice_Name; + when others => + if Is_Range_Attribute_Name (Actual) then + return Iir_Kind_Slice_Name; + end if; + end case; + -- By default, this is an indexed name. + return Iir_Kind_Indexed_Name; + end Slice_Or_Index; + + -- Check whether association chain ASSOCS may be interpreted as indexes. + function Index_Or_Not (Assocs : Iir) return Iir_Kind + is + El : Iir; + begin + El := Assocs; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Association_Element_By_Expression => + if Get_Formal (El) /= Null_Iir then + return Iir_Kind_Error; + end if; + when others => + -- Only expression are allowed. + return Iir_Kind_Error; + end case; + El := Get_Chain (El); + end loop; + return Iir_Kind_Indexed_Name; + end Index_Or_Not; + + function Sem_Index_Specification (Name : Iir_Parenthesis_Name; Itype : Iir) + return Iir + is + Actual : Iir; + Kind : Iir_Kind; + Res : Iir; + begin + -- FIXME: reuse Sem_Name for the whole analysis ? + + Actual := Get_One_Actual (Get_Association_Chain (Name)); + if Actual = Null_Iir then + Error_Msg_Sem ("only one index specification is allowed", Name); + return Null_Iir; + end if; + case Get_Kind (Actual) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Sem_Name (Actual); + Kind := Slice_Or_Index (Get_Named_Entity (Actual)); + -- FIXME: semantization to be finished. + --Maybe_Finish_Sem_Name (Actual); + when others => + Kind := Slice_Or_Index (Actual); + end case; + + Res := Create_Iir (Kind); + Location_Copy (Res, Name); + case Kind is + when Iir_Kind_Indexed_Name => + Actual := Sem_Expression (Actual, Itype); + if Actual = Null_Iir then + return Null_Iir; + end if; + Check_Read (Actual); + if Get_Expr_Staticness (Actual) < Globally then + Error_Msg_Sem ("index must be a static expression", Name); + end if; + Set_Index_List (Res, Create_Iir_List); + Append_Element (Get_Index_List (Res), Actual); + when Iir_Kind_Slice_Name => + Actual := Sem_Discrete_Range_Expression (Actual, Itype, False); + if Actual = Null_Iir then + return Null_Iir; + end if; + if Get_Expr_Staticness (Actual) < Globally then + Error_Msg_Sem ("index must be a static expression", Name); + end if; + Set_Suffix (Res, Actual); + when others => + raise Internal_Error; + end case; + Free_Parenthesis_Name (Name, Res); + return Res; + end Sem_Index_Specification; + + procedure Sem_Parenthesis_Name (Name : Iir_Parenthesis_Name) + is + Prefix: Iir; + Prefix_Name : Iir; + Res : Iir; + Assoc_Chain : Iir; + + Slice_Index_Kind : Iir_Kind; + + -- If FINISH is TRUE, then display error message in case of error. + function Sem_As_Indexed_Or_Slice_Name (Sub_Name : Iir; Finish : Boolean) + return Iir + is + Base_Type : Iir; + Ptr_Type : Iir; + P : Iir; + R : Iir; + begin + if Slice_Index_Kind = Iir_Kind_Error then + if Finish then + Error_Msg_Sem ("prefix is not a function name", Name); + end if; + -- No way. + return Null_Iir; + end if; + + -- Only values can be indexed or sliced. + -- Catch errors such as slice of a type conversion. + if not Is_Object_Name (Sub_Name) + and then Get_Kind (Sub_Name) not in Iir_Kinds_Function_Declaration + then + if Finish then + Error_Msg_Sem ("prefix is not an array value (found " + & Disp_Node (Sub_Name) & ")", Name); + end if; + return Null_Iir; + end if; + + -- Extract type of prefix, handle possible implicit deference. + Base_Type := Get_Base_Type (Get_Type (Sub_Name)); + if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition then + Ptr_Type := Base_Type; + Base_Type := Get_Base_Type (Get_Designated_Type (Base_Type)); + else + Ptr_Type := Null_Iir; + end if; + + if Get_Kind (Base_Type) /= Iir_Kind_Array_Type_Definition then + if Finish then + Error_Msg_Sem ("type of prefix is not an array", Name); + end if; + return Null_Iir; + end if; + if Get_Nbr_Elements (Get_Index_Subtype_List (Base_Type)) /= + Get_Chain_Length (Assoc_Chain) + then + if Finish then + Error_Msg_Sem + ("number of indexes mismatches array dimension", Name); + end if; + return Null_Iir; + end if; + + if not Maybe_Function_Call (Sub_Name) then + if Finish then + Error_Msg_Sem ("missing parameters for function call", Name); + end if; + return Null_Iir; + end if; + + P := Maybe_Insert_Function_Call (Prefix_Name, Sub_Name); + P := Maybe_Insert_Dereference (P, Ptr_Type); + + R := Create_Iir (Slice_Index_Kind); + Location_Copy (R, Name); + Set_Prefix (R, P); + Set_Base_Name (R, Get_Object_Prefix (P)); + + case Slice_Index_Kind is + when Iir_Kind_Slice_Name => + Set_Suffix (R, Get_Actual (Assoc_Chain)); + Set_Type (R, Get_Base_Type (Get_Type (P))); + when Iir_Kind_Indexed_Name => + declare + Idx_El : Iir; + Idx_List : Iir_List; + begin + Idx_List := Create_Iir_List; + Set_Index_List (R, Idx_List); + Idx_El := Assoc_Chain; + while Idx_El /= Null_Iir loop + Append_Element (Idx_List, Get_Actual (Idx_El)); + Idx_El := Get_Chain (Idx_El); + end loop; + end; + Set_Type (R, Get_Element_Subtype (Base_Type)); + when others => + raise Internal_Error; + end case; + + return R; + end Sem_As_Indexed_Or_Slice_Name; + + -- Sem parenthesis name when the prefix is a function declaration. + -- Can be either a function call (and the expression is the actual) or + -- a slice/index of the result of a call without actual. + procedure Sem_Parenthesis_Function (Sub_Name : Iir) is + Used : Boolean; + R : Iir; + Match : Boolean; + begin + Used := False; + if Get_Kind (Sub_Name) in Iir_Kinds_Function_Declaration then + Sem_Association_Chain + (Get_Interface_Declaration_Chain (Sub_Name), + Assoc_Chain, False, Missing_Parameter, Name, Match); + if Match then + Add_Result + (Res, + Sem_As_Function_Call (Prefix_Name, Sub_Name, Assoc_Chain)); + Used := True; + end if; + end if; + if Get_Kind (Sub_Name) not in Iir_Kinds_Procedure_Declaration then + R := Sem_As_Indexed_Or_Slice_Name (Sub_Name, False); + if R /= Null_Iir then + Add_Result (Res, R); + Used := True; + end if; + end if; + if not Used then + Sem_Name_Free_Result (Sub_Name, Null_Iir); + end if; + end Sem_Parenthesis_Function; + + procedure Error_Parenthesis_Function (Spec : Iir) + is + Match : Boolean; + begin + Error_Msg_Sem + ("cannot match " & Disp_Node (Prefix) & " with actuals", Name); + -- Display error message. + Sem_Association_Chain + (Get_Interface_Declaration_Chain (Spec), + Assoc_Chain, True, Missing_Parameter, Name, Match); + end Error_Parenthesis_Function; + + Actual : Iir; + Actual_Expr : Iir; + begin + -- The prefix is a function name, a type mark or an array. + Prefix_Name := Get_Prefix (Name); + Sem_Name (Prefix_Name); + Prefix := Get_Named_Entity (Prefix_Name); + if Prefix = Error_Mark then + Set_Named_Entity (Name, Error_Mark); + return; + end if; + Res := Null_Iir; + + Assoc_Chain := Get_Association_Chain (Name); + Actual := Get_One_Actual (Assoc_Chain); + + if Get_Kind (Prefix) = Iir_Kind_Type_Declaration + or else Get_Kind (Prefix) = Iir_Kind_Subtype_Declaration + then + -- A type conversion. The prefix is a type mark. + + if Actual = Null_Iir then + -- More than one actual. Keep only the first. + Error_Msg_Sem + ("type conversion allows only one expression", Name); + end if; + + -- This is certainly the easiest case: the prefix is not overloaded, + -- so the result can be computed. + Set_Named_Entity (Name, Sem_Type_Conversion (Name, Prefix, Actual)); + return; + end if; + + -- Select between slice or indexed name. + Actual_Expr := Null_Iir; + if Actual /= Null_Iir then + if Get_Kind (Actual) in Iir_Kinds_Name + or else Get_Kind (Actual) = Iir_Kind_Attribute_Name + then + -- Maybe a discrete range name. + Sem_Name (Actual); + Actual_Expr := Get_Named_Entity (Actual); + if Actual_Expr = Error_Mark then + Set_Named_Entity (Name, Actual_Expr); + return; + end if; + -- Decides between sliced or indexed name to actual. + Slice_Index_Kind := Slice_Or_Index (Actual_Expr); + elsif Get_Kind (Actual) = Iir_Kind_Range_Expression then + -- This can only be a slice. + Slice_Index_Kind := Iir_Kind_Slice_Name; + -- Actual_Expr := + -- Sem_Discrete_Range_Expression (Actual, Null_Iir, False); + -- Set_Actual (Assoc_Chain, Actual_Expr); + else + Slice_Index_Kind := Iir_Kind_Indexed_Name; + end if; + else + -- FIXME: improve error message for multi-dim slice ? + Slice_Index_Kind := Index_Or_Not (Assoc_Chain); + end if; + + if Slice_Index_Kind /= Iir_Kind_Slice_Name then + if Sem_Actual_Of_Association_Chain (Assoc_Chain) = False then + Actual := Null_Iir; + else + Actual := Get_One_Actual (Assoc_Chain); + end if; + end if; + + case Get_Kind (Prefix) is + when Iir_Kind_Overload_List => + declare + El : Iir; + Prefix_List : Iir_List; + begin + Prefix_List := Get_Overload_List (Prefix); + for I in Natural loop + El := Get_Nth_Element (Prefix_List, I); + exit when El = Null_Iir; + Sem_Parenthesis_Function (El); + end loop; + end; + if Res = Null_Iir then + Error_Msg_Sem + ("no overloaded function found matching " + & Disp_Node (Prefix_Name), Name); + end if; + when Iir_Kinds_Function_Declaration => + Sem_Parenthesis_Function (Prefix); + if Res = Null_Iir then + Error_Parenthesis_Function (Prefix); + end if; + + when Iir_Kinds_Object_Declaration + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Selected_Element + | Iir_Kind_Attribute_Value + | Iir_Kind_Function_Call => + Add_Result (Res, Sem_As_Indexed_Or_Slice_Name (Prefix, True)); + + when Iir_Kinds_Array_Attribute => + if Actual /= Null_Iir then + Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Actual); + Set_Named_Entity (Name, Prefix); + else + Error_Msg_Sem ("bad attribute parameter", Name); + Set_Named_Entity (Name, Error_Mark); + end if; + return; + + when Iir_Kinds_Scalar_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute => + if Get_Parameter (Prefix) /= Null_Iir then + -- Attribute already has a parameter, the expression + -- is either a slice or an index. + Add_Result + (Res, Sem_As_Indexed_Or_Slice_Name (Prefix, True)); + elsif Actual /= Null_Iir then + Finish_Sem_Scalar_Type_Attribute (Prefix_Name, Prefix, Actual); + Set_Named_Entity (Name, Prefix); + return; + else + Error_Msg_Sem ("bad attribute parameter", Name); + Set_Named_Entity (Name, Error_Mark); + return; + end if; + + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + Error_Msg_Sem + ("subprogram name is a type mark (missing apostrophe)", Name); + + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute => + if Actual /= Null_Iir then + Finish_Sem_Signal_Attribute (Prefix_Name, Prefix, Actual); + Set_Named_Entity (Name, Prefix); + else + Error_Msg_Sem ("bad attribute parameter", Name); + Set_Named_Entity (Name, Error_Mark); + end if; + return; + + when Iir_Kinds_Procedure_Declaration => + Error_Msg_Sem ("function name is a procedure", Name); + + when Iir_Kinds_Process_Statement + | Iir_Kind_Component_Declaration + | Iir_Kind_Type_Conversion => + Error_Msg_Sem + (Disp_Node (Prefix) & " cannot be indexed or sliced", Name); + Res := Null_Iir; + + when Iir_Kind_Psl_Declaration => + Res := Sem_Psl.Sem_Psl_Name (Name); + + when Iir_Kinds_Library_Unit_Declaration => + Error_Msg_Sem ("function name is a design unit", Name); + + when others => + Error_Kind ("sem_parenthesis_name", Prefix); + end case; + + if Res = Null_Iir then + Res := Error_Mark; + end if; + Set_Named_Entity (Name, Res); + end Sem_Parenthesis_Name; + + procedure Sem_Selected_By_All_Name (Name : Iir_Selected_By_All_Name) + is + Prefix : Iir; + Prefix_Name : Iir; + Res : Iir; + + procedure Sem_As_Selected_By_All_Name (Sub_Name : Iir) + is + Base_Type : Iir; + R, R1 : Iir; + begin + -- Only accept prefix of access type. + Base_Type := Get_Base_Type (Get_Type (Sub_Name)); + if Get_Kind (Base_Type) /= Iir_Kind_Access_Type_Definition then + return; + end if; + + if not Maybe_Function_Call (Sub_Name) then + return; + end if; + + R1 := Maybe_Insert_Function_Call (Get_Prefix (Name), Sub_Name); + + R := Create_Iir (Iir_Kind_Dereference); + Location_Copy (R, Name); + Set_Prefix (R, R1); + -- FIXME: access subtype. + Set_Type (R, Get_Designated_Type (Base_Type)); + Add_Result (Res, R); + end Sem_As_Selected_By_All_Name; + begin + Prefix := Get_Prefix (Name); + Sem_Name (Prefix); + Prefix_Name := Prefix; + Prefix := Get_Named_Entity (Prefix); + if Prefix = Null_Iir then + return; + end if; + Res := Null_Iir; + + case Get_Kind (Prefix) is + when Iir_Kind_Overload_List => + declare + Prefix_List : Iir_List; + El : Iir; + begin + Prefix_List := Get_Overload_List (Prefix); + for I in Natural loop + El := Get_Nth_Element (Prefix_List, I); + exit when El = Null_Iir; + Sem_As_Selected_By_All_Name (El); + end loop; + end; + when Iir_Kinds_Object_Declaration + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Indexed_Name + | Iir_Kind_Function_Call => + Sem_As_Selected_By_All_Name (Prefix); + when Iir_Kinds_Function_Declaration => + Prefix := Sem_As_Function_Call (Name => Prefix_Name, + Spec => Prefix, + Assoc_Chain => Null_Iir); + Sem_As_Selected_By_All_Name (Prefix); + when Iir_Kind_Error => + Set_Named_Entity (Name, Error_Mark); + return; + when others => + Error_Kind ("sem_selected_by_all_name", Prefix); + end case; + if Res = Null_Iir then + Error_Msg_Sem ("prefix is not an access", Name); + Res := Error_Mark; + end if; + Set_Named_Entity (Name, Res); + end Sem_Selected_By_All_Name; + + function Sem_Base_Attribute (Attr : Iir_Attribute_Name) return Iir + is + Prefix_Name : Iir; + Prefix : Iir; + Res : Iir; + Base_Type : Iir; + Type_Decl : Iir; + begin + Prefix_Name := Finish_Sem_Name (Get_Prefix (Attr)); + -- FIXME: handle error + Prefix := Get_Named_Entity (Prefix_Name); + case Get_Kind (Prefix) is + when Iir_Kind_Type_Declaration => + Base_Type := Get_Type_Definition (Prefix); + when Iir_Kind_Subtype_Declaration => + Base_Type := Get_Base_Type (Get_Type (Prefix)); + -- Get the first subtype. FIXME: ref? + Type_Decl := Get_Type_Declarator (Base_Type); + if Get_Kind (Type_Decl) = Iir_Kind_Anonymous_Type_Declaration then + Base_Type := Get_Subtype_Definition (Type_Decl); + end if; + when others => + Error_Msg_Sem + ("prefix of 'base attribute must be a type or a subtype", Attr); + return Error_Mark; + end case; + Res := Create_Iir (Iir_Kind_Base_Attribute); + Location_Copy (Res, Attr); + Set_Prefix (Res, Prefix_Name); + Set_Type (Res, Base_Type); + return Res; + end Sem_Base_Attribute; + + function Sem_User_Attribute (Attr : Iir_Attribute_Name) return Iir + is + Prefix : Iir; + Value : Iir; + Attr_Id : Name_Id; + Spec : Iir_Attribute_Specification; + begin + Prefix := Get_Named_Entity (Get_Prefix (Attr)); + + -- LRM93 6.6 + -- If the attribute name denotes an alias, then the attribute name + -- denotes an attribute of the aliased name and not the alias itself, + -- except when the attribute designator denotes any of the predefined + -- attributes 'simple_name, 'path_name, or 'instance_name. + if Get_Kind (Prefix) = Iir_Kind_Object_Alias_Declaration then + -- GHDL: according to 4.3.3, the name cannot be an alias. + Prefix := Strip_Denoting_Name (Get_Name (Prefix)); + end if; + + -- LRM93 6.6 + -- If the attribute designator denotes a user-defined attribute, the + -- prefix cannot denote a subelement or a slice of an object. + case Get_Kind (Prefix) is + when Iir_Kind_Selected_By_All_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name => + Error_Msg_Sem ("prefix of user defined attribute cannot be an " + & "object subelement", Attr); + return Error_Mark; + when Iir_Kind_Dereference => + Error_Msg_Sem ("prefix of user defined attribute cannot be an " + & "anonymous object", Attr); + return Error_Mark; + when Iir_Kinds_Object_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kinds_Function_Declaration + | Iir_Kinds_Procedure_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kinds_Sequential_Statement + | Iir_Kinds_Concurrent_Statement + | Iir_Kind_Component_Declaration + | Iir_Kinds_Library_Unit_Declaration => + -- FIXME: to complete + null; + when others => + Error_Kind ("sem_user_attribute", Prefix); + end case; + + Attr_Id := Get_Identifier (Attr); + Value := Get_Attribute_Value_Chain (Prefix); + while Value /= Null_Iir loop + Spec := Get_Attribute_Specification (Value); + exit when Get_Identifier (Get_Attribute_Designator (Spec)) = Attr_Id; + Value := Get_Chain (Value); + end loop; + if Value = Null_Iir then + Error_Msg_Sem + (Disp_Node (Prefix) & " was not annotated with attribute '" + & Name_Table.Image (Attr_Id) & ''', Attr); + if Attr_Id = Std_Names.Name_First or Attr_Id = Std_Names.Name_Last + then + -- Nice (?) message for Ada users. + Error_Msg_Sem + ("(you may use 'high, 'low, 'left or 'right attribute)", Attr); + end if; + return Error_Mark; + end if; + + Xref_Ref (Attr, Value); + + return Value; + end Sem_User_Attribute; + + -- The prefix of scalar type attributes is a type name (or 'base), and + -- therefore isn't overloadable. So at the end of the function, the + -- analyze is finished. + function Sem_Scalar_Type_Attribute (Attr : Iir_Attribute_Name) + return Iir + is + use Std_Names; + Prefix_Name : constant Iir := Get_Prefix (Attr); + Id : constant Name_Id := Get_Identifier (Attr); + Prefix : Iir; + Prefix_Type : Iir; + Res : Iir; + begin + Prefix := Get_Named_Entity (Prefix_Name); + + -- LRM93 14.1 + -- Prefix: Any discrete or physical type of subtype T. + case Get_Kind (Prefix) is + when Iir_Kind_Type_Declaration => + Prefix_Type := Get_Type_Definition (Prefix); + when Iir_Kind_Subtype_Declaration => + Prefix_Type := Get_Type (Prefix); + when Iir_Kind_Base_Attribute => + Prefix_Type := Get_Type (Prefix); + when others => + Error_Msg_Sem ("prefix of '" & Name_Table.Image (Id) + & " attribute must be a type", Attr); + return Error_Mark; + end case; + + case Id is + when Name_Image + | Name_Value => + if Get_Kind (Prefix_Type) not in Iir_Kinds_Scalar_Type_Definition + then + Error_Msg_Sem + ("prefix of '" & Name_Table.Image (Id) + & " attribute must be a scalar type", Attr); + Error_Msg_Sem + ("found " & Disp_Node (Prefix_Type) + & " defined at " & Disp_Location (Prefix_Type), Attr); + return Error_Mark; + end if; + when others => + case Get_Kind (Prefix_Type) is + when Iir_Kinds_Discrete_Type_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Physical_Type_Definition => + null; + when others => + Error_Msg_Sem + ("prefix of '" & Name_Table.Image (Id) + & " attribute must be discrete or physical type", Attr); + Error_Msg_Sem + ("found " & Disp_Node (Prefix_Type) + & " defined at " & Disp_Location (Prefix_Type), Attr); + return Error_Mark; + end case; + end case; + + -- Create the resulting node. + case Get_Identifier (Attr) is + when Name_Pos => + Res := Create_Iir (Iir_Kind_Pos_Attribute); + when Name_Val => + Res := Create_Iir (Iir_Kind_Val_Attribute); + when Name_Succ => + Res := Create_Iir (Iir_Kind_Succ_Attribute); + when Name_Pred => + Res := Create_Iir (Iir_Kind_Pred_Attribute); + when Name_Leftof => + Res := Create_Iir (Iir_Kind_Leftof_Attribute); + when Name_Rightof => + Res := Create_Iir (Iir_Kind_Rightof_Attribute); + when Name_Image => + Res := Create_Iir (Iir_Kind_Image_Attribute); + when Name_Value => + Res := Create_Iir (Iir_Kind_Value_Attribute); + when others => + raise Internal_Error; + end case; + Location_Copy (Res, Attr); + Set_Prefix (Res, Prefix_Name); + Set_Base_Name (Res, Res); + + case Get_Identifier (Attr) is + when Name_Pos => + -- LRM93 14.1 + -- Result type: universal_integer. + Set_Type (Res, Convertible_Integer_Type_Definition); + when Name_Val => + -- LRM93 14.1 + -- Result type: the base type of T + Set_Type (Res, Get_Base_Type (Prefix_Type)); + when Name_Succ + | Name_Pred + | Name_Leftof + | Name_Rightof => + -- LRM93 14.1 + -- Result type: the base type of T. + Set_Type (Res, Get_Base_Type (Prefix_Type)); + when Name_Image => + -- LRM93 14.1 + -- Result type: type string + Set_Type (Res, String_Type_Definition); + when Name_Value => + -- LRM93 14.1 + -- Result type: the base type of T. + Set_Type (Res, Get_Base_Type (Prefix_Type)); + when others => + raise Internal_Error; + end case; + return Res; + end Sem_Scalar_Type_Attribute; + + -- Analyze attributes whose prefix is a type or a subtype and result is + -- a value (not a function). + function Sem_Predefined_Type_Attribute (Attr : Iir_Attribute_Name) + return Iir + is + use Std_Names; + Prefix_Name : constant Iir := Get_Prefix (Attr); + Id : constant Name_Id := Get_Identifier (Attr); + Res : Iir; + Prefix : Iir; + Prefix_Type : Iir; + begin + case Id is + when Name_Left => + Res := Create_Iir (Iir_Kind_Left_Type_Attribute); + when Name_Right => + Res := Create_Iir (Iir_Kind_Right_Type_Attribute); + when Name_High => + Res := Create_Iir (Iir_Kind_High_Type_Attribute); + when Name_Low => + Res := Create_Iir (Iir_Kind_Low_Type_Attribute); + when Name_Ascending => + Res := Create_Iir (Iir_Kind_Ascending_Type_Attribute); + when Name_Range + | Name_Reverse_Range => + Error_Msg_Sem + ("prefix of range attribute must be an array type or object", + Attr); + return Error_Mark; + when others => + Error_Msg_Sem ("Attribute '" & Name_Table.Image (Id) + & " not valid on this type", Attr); + return Error_Mark; + end case; + Location_Copy (Res, Attr); + Set_Base_Name (Res, Res); + + Prefix := Get_Named_Entity (Prefix_Name); + case Get_Kind (Prefix) is + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Prefix := Finish_Sem_Name (Prefix_Name, Prefix); + Prefix_Type := Get_Type (Prefix); + Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix)); + when Iir_Kind_Base_Attribute => + -- Base_Attribute is already finished. + Prefix_Type := Get_Type (Prefix); + Set_Expr_Staticness (Res, Get_Type_Staticness (Prefix_Type)); + when others => + Prefix := Sem_Type_Mark (Prefix_Name); + Prefix_Type := Get_Type (Prefix); + Set_Expr_Staticness (Res, Get_Type_Staticness (Prefix_Type)); + end case; + Set_Prefix (Res, Prefix); + + case Get_Identifier (Attr) is + when Name_Ascending => + -- LRM93 14.1 + -- Result Type: type boolean. + Set_Type (Res, Boolean_Type_Definition); + when others => + -- LRM 14.1 + -- Result Type: Same type as T. + Set_Type (Res, Prefix_Type); + end case; + return Res; + end Sem_Predefined_Type_Attribute; + + -- Called for attributes Length, Left, Right, High, Low, Range, + -- Reverse_Range, Ascending. + -- FIXME: handle overload + function Sem_Array_Attribute_Name (Attr : Iir_Attribute_Name) return Iir + is + use Std_Names; + Prefix: Iir; + Prefix_Name : constant Iir := Get_Prefix (Attr); + Prefix_Type : Iir; + Res : Iir; + Res_Type : Iir; + begin + Prefix := Get_Named_Entity (Prefix_Name); + + -- LRM93 14.1 + -- Prefix: Any prefix A that is appropriate for an array object, or an + -- alias thereof, or that denotes a constrained array subtype. + case Get_Kind (Prefix) is + when Iir_Kind_Dereference + | Iir_Kinds_Object_Declaration + | Iir_Kind_Function_Call + | Iir_Kind_Selected_Element + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Attribute_Value + | Iir_Kind_Image_Attribute => + -- FIXME: list of expr. + Prefix_Type := Get_Type (Prefix); + case Get_Kind (Prefix_Type) is + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + declare + Designated_Type : Iir; + begin + Designated_Type := + Get_Designated_Type (Get_Base_Type (Prefix_Type)); + Prefix := Insert_Implicit_Dereference (Prefix, Attr); + Prefix_Type := Designated_Type; + end; + when Iir_Kinds_Array_Type_Definition => + null; + when others => + Error_Msg_Sem ("object prefix must be an array", Attr); + return Error_Mark; + end case; + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Base_Attribute => + Prefix_Type := Get_Type (Prefix); + 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 + -- constrained, the base type would be the same. + end if; + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + -- For names such as pfx'Range'Left. + -- Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Null_Iir); + Prefix_Type := Get_Type (Prefix); + when Iir_Kind_Process_Statement => + Error_Msg_Sem + (Disp_Node (Prefix) & " is not an appropriate prefix for '" + & Name_Table.Image (Get_Identifier (Attr)) + & " attribute", + Attr); + return Error_Mark; + when others => + Error_Msg_Sem ("prefix must denote an array object or type", Attr); + return Error_Mark; + end case; + + case Get_Kind (Prefix_Type) is + when Iir_Kinds_Scalar_Type_Definition => + -- Note: prefix is a scalar type or subtype. + return Sem_Predefined_Type_Attribute (Attr); + when Iir_Kinds_Array_Type_Definition => + null; + when others => + Error_Msg_Sem + ("prefix of '" + & Name_Table.Image (Get_Identifier (Attr)) + & " attribute must denote a constrained array subtype", + Attr); + return Error_Mark; + end case; + + -- Type of the attribute. This is correct unless there is a parameter, + -- and furthermore 'range and 'reverse_range has to be handled + -- specially because the result is a range and not a value. + Res_Type := Get_Index_Type (Get_Index_Subtype_List (Prefix_Type), 0); + + -- Create the node for the attribute. + case Get_Identifier (Attr) is + when Name_Left => + Res := Create_Iir (Iir_Kind_Left_Array_Attribute); + when Name_Right => + Res := Create_Iir (Iir_Kind_Right_Array_Attribute); + when Name_High => + Res := Create_Iir (Iir_Kind_High_Array_Attribute); + when Name_Low => + Res := Create_Iir (Iir_Kind_Low_Array_Attribute); + when Name_Range => + Res := Create_Iir (Iir_Kind_Range_Array_Attribute); + when Name_Reverse_Range => + Res := Create_Iir (Iir_Kind_Reverse_Range_Array_Attribute); + when Name_Length => + Res := Create_Iir (Iir_Kind_Length_Array_Attribute); + -- FIXME: Error if ambiguous + Res_Type := Convertible_Integer_Type_Definition; + when Name_Ascending => + Res := Create_Iir (Iir_Kind_Ascending_Array_Attribute); + -- FIXME: Error if ambiguous + Res_Type := Boolean_Type_Definition; + when others => + raise Internal_Error; + end case; + Location_Copy (Res, Attr); + Set_Prefix (Res, Prefix); + Set_Type (Res, Res_Type); + return Res; + end Sem_Array_Attribute_Name; + + function Sem_Signal_Signal_Attribute + (Attr : Iir_Attribute_Name; Kind : Iir_Kind) + return Iir + is + Res : Iir; + Prefix : Iir; + begin + Prefix := Get_Named_Entity (Get_Prefix (Attr)); + Res := Create_Iir (Kind); + if Kind = Iir_Kind_Delayed_Attribute then + Set_Type (Res, Get_Type (Prefix)); + elsif Kind = Iir_Kind_Transaction_Attribute then + Set_Type (Res, Bit_Type_Definition); + else + Set_Type (Res, Boolean_Type_Definition); + end if; + Set_Base_Name (Res, Res); + + if Get_Kind (Prefix) = Iir_Kind_Interface_Signal_Declaration then + -- LRM93 2.1.1.2 / LRM08 4.2.2.3 + -- + -- It is an error if signal-valued attributes 'STABLE , 'QUIET, + -- 'TRANSACTION, and 'DELAYED of formal signal paramaters of any + -- mode are read within a subprogram. + case Get_Kind (Get_Parent (Prefix)) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Error_Msg_Sem + ("'" & Name_Table.Image (Get_Identifier (Attr)) & + " is not allowed for a signal parameter", Attr); + when others => + null; + end case; + end if; + Sem_Stmts.Add_Declaration_For_Implicit_Signal (Res); + return Res; + end Sem_Signal_Signal_Attribute; + + function Sem_Signal_Attribute (Attr : Iir_Attribute_Name) return Iir + is + use Std_Names; + Prefix: Iir; + Res : Iir; + Base : Iir; + begin + Prefix := Get_Named_Entity (Get_Prefix (Attr)); + Base := Get_Object_Prefix (Prefix); + case Get_Kind (Base) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kinds_Signal_Attribute => + null; + when others => + Error_Msg_Sem + ("prefix of '" + & Name_Table.Image (Get_Identifier (Attr)) + & " attribute must denote a signal", Attr); + return Error_Mark; + end case; + case Get_Identifier (Attr) is + when Name_Stable => + Res := Sem_Signal_Signal_Attribute + (Attr, Iir_Kind_Stable_Attribute); + when Name_Quiet => + Res := Sem_Signal_Signal_Attribute + (Attr, Iir_Kind_Quiet_Attribute); + when Name_Delayed => + Res := Sem_Signal_Signal_Attribute + (Attr, Iir_Kind_Delayed_Attribute); + when Name_Transaction => + Res := Sem_Signal_Signal_Attribute + (Attr, Iir_Kind_Transaction_Attribute); + when Name_Event => + Res := Create_Iir (Iir_Kind_Event_Attribute); + Set_Type (Res, Boolean_Type_Definition); + when Name_Active => + Res := Create_Iir (Iir_Kind_Active_Attribute); + Set_Type (Res, Boolean_Type_Definition); + when Name_Last_Value => + Res := Create_Iir (Iir_Kind_Last_Value_Attribute); + Set_Type (Res, Get_Type (Prefix)); + when Name_Last_Event => + Res := Create_Iir (Iir_Kind_Last_Event_Attribute); + Set_Type (Res, Time_Type_Definition); + when Name_Last_Active => + Res := Create_Iir (Iir_Kind_Last_Active_Attribute); + Set_Type (Res, Time_Type_Definition); + when Name_Driving_Value => + Res := Create_Iir (Iir_Kind_Driving_Value_Attribute); + Set_Type (Res, Get_Type (Prefix)); + -- FIXME: check restrictions. + when Name_Driving => + Res := Create_Iir (Iir_Kind_Driving_Attribute); + Set_Type (Res, Boolean_Type_Definition); + -- FIXME: check restrictions. + when others => + -- Not yet implemented attribute, or really an internal error. + raise Internal_Error; + end case; + Location_Copy (Res, Attr); + + -- LRM 4.3.2 + -- The value of an object is said to be read when one of the following + -- conditions is satisfied: + -- [...] + -- * When the object is a signal and the value of any of its predefined + -- attributes 'STABLE, 'QUIET, 'DELAYED, 'TRANSACTION, 'EVENT, + -- 'ACTIVE, 'LAST_EVENT, 'LAST_ACTIVE, or 'LAST_VALUE is read. + + -- LRM 14.1 + -- S'Driving Restrictions: + -- S'Driving_Value Restrictions: + -- This attribute is available only from within a process, a + -- concurrent statement with an equivalent process, or a subprogram. + -- If the prefix denotes a port, it is an error if the port does not + -- have a mode of INOUT, OUT or BUFFER. It is also an error if the + -- attribute name appears in a subprogram body that is not a declarative + -- item contained within a process statement and the prefix is not a + -- formal parameter of the given subprogram or of a parent of that + -- subprogram. Finally, it is an error if the prefix denotes a + -- subprogram formal parameter whose mode is not INOUT or OUT, or if + -- S'Driving is False at the time of the evaluation of S'Driving_Value. + case Get_Kind (Res) is + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Event_Attribute + | Iir_Kind_Active_Attribute + | Iir_Kind_Last_Event_Attribute + | Iir_Kind_Last_Active_Attribute + | Iir_Kind_Last_Value_Attribute => + Check_Read (Prefix); + when Iir_Kind_Driving_Attribute + | Iir_Kind_Driving_Value_Attribute => + -- FIXME: complete checks. + if Get_Current_Concurrent_Statement = Null_Iir then + Error_Msg_Sem + ("'driving or 'driving_value is available only within a " + & "concurrent statement", Attr); + else + case Get_Kind (Get_Current_Concurrent_Statement) is + when Iir_Kinds_Process_Statement + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Concurrent_Procedure_Call_Statement => + null; + when others => + Error_Msg_Sem + ("'driving or 'driving_value not available within " + & "this concurrent statement", Attr); + end case; + end if; + + case Get_Kind (Base) is + when Iir_Kind_Signal_Declaration => + null; + when Iir_Kind_Interface_Signal_Declaration => + case Get_Mode (Base) is + when Iir_Buffer_Mode + | Iir_Inout_Mode + | Iir_Out_Mode => + null; + when others => + Error_Msg_Sem + ("mode of 'driving or 'driving_value prefix must " + & "be out, inout or buffer", Attr); + end case; + when others => + Error_Msg_Sem + ("bad prefix for 'driving or 'driving_value", Attr); + end case; + when others => + null; + end case; + + -- According to LRM 7.4, signal attributes are not static expressions + -- since the prefix (a signal) is not a static expression. + Set_Expr_Staticness (Res, None); + + -- LRM 6.1 + -- A name is said to be a static name if and only if at least one of + -- the following conditions holds: + -- [...] + -- - The name is a attribute name whose prefix is a static signal name + -- and whose suffix is one of the predefined attributes 'DELAYED, + -- 'STABLE, 'QUIET or 'TRANSACTION. + -- According to LRM 6.1, attributes are not static names. + if Flags.Vhdl_Std = Vhdl_93c or Flags.Vhdl_Std >= Vhdl_02 then + case Get_Kind (Res) is + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute => + Set_Name_Staticness (Res, Get_Name_Staticness (Prefix)); + when others => + Set_Name_Staticness (Res, None); + end case; + else + Set_Name_Staticness (Res, None); + end if; + + Set_Prefix (Res, Prefix); + + -- Set has_active_flag when activity is read. + case Get_Kind (Res) is + when Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Active_Attribute + | Iir_Kind_Last_Active_Attribute => + Set_Has_Active_Flag (Base, True); + when others => + null; + end case; + + return Res; + end Sem_Signal_Attribute; + + -- 'Simple_name, 'instance_name and 'path_name. + function Sem_Name_Attribute (Attr : Iir_Attribute_Name) return Iir + is + use Std_Names; + Prefix_Name : constant Iir := Get_Prefix (Attr); + Prefix: Iir; + Res : Iir; + Attr_Type : Iir; + begin + Prefix := Get_Named_Entity (Prefix_Name); + Set_Prefix (Attr, Finish_Sem_Name (Prefix_Name, Prefix)); + + -- LRM 14.1 Predefined attributes + -- E'SIMPLE_NAME + -- Prefix: Any named entity as defined in 5.1 + -- E'INSTANCE_NAME + -- Prefix: Any named entity other than the local ports and generics + -- of a component declaration. + -- E'PATH_NAME + -- Prefix: Any named entity other than the local ports and generics + -- of a component declaration. + case Get_Kind (Prefix) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Group_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_File_Declaration + | Iir_Kinds_Library_Unit_Declaration + | Iir_Kind_Non_Object_Alias_Declaration => + null; + + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Constant_Declaration => + if Get_Identifier (Attr) /= Name_Simple_Name + and then Get_Kind (Get_Parent (Prefix)) + = Iir_Kind_Component_Declaration + then + Error_Msg_Sem + ("local ports or generics of a component cannot be a prefix", + Attr); + end if; + when others => + Error_Msg_Sem (Disp_Node (Prefix) & " is not a named entity", + Attr); + end case; + + case Get_Identifier (Attr) is + when Name_Simple_Name => + Res := Create_Iir (Iir_Kind_Simple_Name_Attribute); + Eval_Simple_Name (Get_Identifier (Prefix)); + Set_Simple_Name_Identifier (Res, Name_Table.Get_Identifier); + Attr_Type := Create_Unidim_Array_By_Length + (String_Type_Definition, + Iir_Int64 (Name_Table.Name_Length), + Attr); + Set_Simple_Name_Subtype (Res, Attr_Type); + Set_Expr_Staticness (Res, Locally); + + when Name_Path_Name => + Res := Create_Iir (Iir_Kind_Path_Name_Attribute); + Set_Expr_Staticness (Res, Globally); + Attr_Type := String_Type_Definition; + + when Name_Instance_Name => + Res := Create_Iir (Iir_Kind_Instance_Name_Attribute); + Set_Expr_Staticness (Res, Globally); + Attr_Type := String_Type_Definition; + + when others => + raise Internal_Error; + end case; + + Location_Copy (Res, Attr); + Set_Prefix (Res, Prefix_Name); + Set_Type (Res, Attr_Type); + return Res; + end Sem_Name_Attribute; + + procedure Sem_Attribute_Name (Attr : Iir_Attribute_Name) + is + use Std_Names; + Prefix : Iir; + Res : Iir; + Sig : Iir_Signature; + begin + -- LRM93 6.6 Attribute names + -- The meaning of the prefix of an attribute name must be determinable + -- independently of the attribute designator and independently of the + -- fact that it is the prefix of an attribute. + Prefix := Get_Prefix (Attr); + + -- LRM93 6.6 + -- If the prefix of an attribute name denotes an alias, then the + -- attribute name denotes an attribute of the aliased name and not the + -- alias itself, except when the attribute designator denotes any of + -- the predefined attributes 'Simple_Name, 'Path_Name or 'Instance_Name. + -- If the prefix of an attribute name denotes an alias and the + -- attribute designator denotes any of the predefined attributes + -- 'Simple_Name, 'Path_Name or 'Instance_Name, then the attribute name + -- denotes the attribute of the alias and not of the aliased name. + if Flags.Vhdl_Std > Vhdl_87 + and then Get_Identifier (Attr) in Name_Id_Name_Attributes + then + Sem_Name (Prefix, True); + else + Sem_Name (Prefix, False); + end if; + Prefix := Get_Named_Entity (Prefix); + + if Prefix = Error_Mark then + Set_Named_Entity (Attr, Prefix); + return; + end if; + + -- LRM93 6.6 + -- A signature may follow the prefix if and only if the prefix denotes + -- a subprogram or enumeration literal, or an alias thereof. + -- In this case, the signature is required to match (see Section 2.3.2) + -- the parameter and result type profile of exactly one visible + -- subprogram or enumeration literal, as is appropriate to the prefix. + -- GHDL: this is done by Sem_Signature. + Sig := Get_Attribute_Signature (Attr); + if Sig /= Null_Iir then + Prefix := Sem_Signature (Prefix, Sig); + if Prefix = Null_Iir then + Set_Named_Entity (Attr, Error_Mark); + return; + end if; + Set_Named_Entity (Get_Prefix (Attr), Prefix); + end if; + + if Get_Kind (Prefix) = Iir_Kind_Overload_List then + -- FIXME: this should be allowed. + Error_Msg_Sem ("prefix of attribute is overloaded", Attr); + Set_Named_Entity (Attr, Error_Mark); + return; + end if; + + -- Set_Prefix (Attr, Finish_Sem_Name (Get_Prefix (Attr), Prefix)); + + case Get_Identifier (Attr) is + when Name_Base => + Res := Sem_Base_Attribute (Attr); + when Name_Image + | Name_Value => + if Flags.Vhdl_Std > Vhdl_87 then + Res := Sem_Scalar_Type_Attribute (Attr); + else + Res := Sem_User_Attribute (Attr); + end if; + + when Name_Pos + | Name_Val + | Name_Succ + | Name_Pred + | Name_Rightof + | Name_Leftof => + Res := Sem_Scalar_Type_Attribute (Attr); + + when Name_Length + | Name_Left + | Name_Right + | Name_High + | Name_Low + | Name_Range + | Name_Reverse_Range => + Res := Sem_Array_Attribute_Name (Attr); + + when Name_Ascending => + if Flags.Vhdl_Std > Vhdl_87 then + Res := Sem_Array_Attribute_Name (Attr); + else + Res := Sem_User_Attribute (Attr); + end if; + + when Name_Stable + | Name_Event + | Name_Last_Value + | Name_Delayed + | Name_Quiet + | Name_Transaction + | Name_Active + | Name_Last_Active + | Name_Last_Event => + Res := Sem_Signal_Attribute (Attr); + + when Name_Driving + | Name_Driving_Value => + if Flags.Vhdl_Std > Vhdl_87 then + Res := Sem_Signal_Attribute (Attr); + else + Res := Sem_User_Attribute (Attr); + end if; + + when Name_Simple_Name + | Name_Path_Name + | Name_Instance_Name => + if Flags.Vhdl_Std > Vhdl_87 then + Res := Sem_Name_Attribute (Attr); + else + Res := Sem_User_Attribute (Attr); + end if; + + when others => + Res := Sem_User_Attribute (Attr); + end case; + + if Res = Null_Iir then + Error_Kind ("sem_attribute_name", Attr); + end if; + Set_Named_Entity (Attr, Res); + end Sem_Attribute_Name; + + -- LRM93 §6 + procedure Sem_Name (Name : Iir; Keep_Alias : Boolean := False) is + begin + -- Exit now if NAME was already semantized. + if Get_Named_Entity (Name) /= Null_Iir then + return; + end if; + + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Operator_Symbol => + -- String_Literal may be a symbol_operator. + Sem_Simple_Name (Name, Keep_Alias, Soft => False); + when Iir_Kind_Selected_Name => + Sem_Selected_Name (Name, Keep_Alias); + when Iir_Kind_Parenthesis_Name => + Sem_Parenthesis_Name (Name); + when Iir_Kind_Selected_By_All_Name => + Sem_Selected_By_All_Name (Name); + when Iir_Kind_Attribute_Name => + Sem_Attribute_Name (Name); + when others => + Error_Kind ("sem_name", Name); + end case; + end Sem_Name; + + procedure Sem_Name_Soft (Name : Iir) + is + begin + -- Exit now if NAME was already semantized. + if Get_Named_Entity (Name) /= Null_Iir then + return; + end if; + + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol => + -- String_Literal may be a symbol_operator. + Sem_Simple_Name (Name, False, Soft => True); + when others => + Error_Kind ("sem_name_soft", Name); + end case; + end Sem_Name_Soft; + + procedure Sem_Name_Clean (Name : Iir) + is + N : Iir; + Next_N : Iir; + Named_Entity : Iir; + Atype : Iir; + begin + N := Name; + while N /= Null_Iir loop + case Get_Kind (N) is + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol => + Next_N := Null_Iir; + when others => + Error_Kind ("sem_name_clean", N); + end case; + + -- Clear and free overload lists of Named_entity and type. + Named_Entity := Get_Named_Entity (N); + Set_Named_Entity (N, Null_Iir); + if Named_Entity /= Null_Iir + and then Is_Overload_List (Named_Entity) + then + Free_Iir (Named_Entity); + end if; + + Atype := Get_Type (N); + Set_Type (N, Null_Iir); + if Atype /= Null_Iir + and then Is_Overload_List (Atype) + then + Free_Iir (Atype); + end if; + + N := Next_N; + end loop; + end Sem_Name_Clean; + + -- Remove procedure specification from LIST. + function Remove_Procedures_From_List (Expr : Iir) return Iir + is + El : Iir; + P : Natural; + List : Iir_List; + begin + if not Is_Overload_List (Expr) then + return Expr; + end if; + List := Get_Overload_List (Expr); + P := 0; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + case Get_Kind (El) is + when Iir_Kinds_Procedure_Declaration => + null; + when Iir_Kinds_Function_Declaration => + if Maybe_Function_Call (El) then + Replace_Nth_Element (List, P, El); + P := P + 1; + end if; + when others => + Replace_Nth_Element (List, P, El); + P := P + 1; + end case; + end loop; + case P is + when 0 => + Free_Iir (Expr); + return Null_Iir; + when 1 => + El := Get_First_Element (List); + Free_Iir (Expr); + return El; + when others => + Set_Nbr_Elements (List, P); + return Expr; + end case; + end Remove_Procedures_From_List; + + -- Convert name EXPR to an expression (ie, create function call). + -- A_TYPE is the expected type of the expression. + -- Returns NULL_IIR in case of error. + function Name_To_Expression (Name : Iir; A_Type : Iir) return Iir + is + Ret_Type : Iir; + Res_Type : Iir; + Expr : Iir; + Expr_List : Iir_List; + Res : Iir; + El : Iir; + begin + Expr := Get_Named_Entity (Name); + if Get_Kind (Expr) = Iir_Kind_Error then + return Null_Iir; + end if; + if Check_Is_Expression (Expr, Name) = Null_Iir then + return Null_Iir; + end if; + + -- Note: EXPR may contain procedure names... + Expr := Remove_Procedures_From_List (Expr); + Set_Named_Entity (Name, Expr); + if Expr = Null_Iir then + Error_Msg_Sem ("procedure name " & Disp_Node (Name) + & " cannot be used as expression", Name); + return Null_Iir; + end if; + + if not Is_Overload_List (Expr) then + Res := Finish_Sem_Name (Name); + pragma Assert (Res /= Null_Iir); + if A_Type /= Null_Iir then + Res_Type := Get_Type (Res); + if Res_Type = Null_Iir then + return Null_Iir; + end if; + if not Are_Basetypes_Compatible (Get_Base_Type (Res_Type), A_Type) + then + Error_Not_Match (Res, A_Type, Name); + return Null_Iir; + end if; + -- Fall through. + end if; + else + -- EXPR is an overloaded name. + Expr_List := Get_Overload_List (Expr); + + if A_Type /= Null_Iir then + -- Find the name returning A_TYPE. + Res := Null_Iir; + for I in Natural loop + El := Get_Nth_Element (Expr_List, I); + exit when El = Null_Iir; + if Are_Basetypes_Compatible (Get_Base_Type (Get_Type (El)), + A_Type) + then + Add_Result (Res, El); + end if; + end loop; + if Res = Null_Iir then + Error_Not_Match (Name, A_Type, Name); + return Null_Iir; + elsif Is_Overload_List (Res) then + Error_Overload (Name); + Disp_Overload_List (Get_Overload_List (Res), Name); + return Null_Iir; + else + -- Free results + Sem_Name_Free_Result (Expr, Res); + + Ret_Type := Get_Type (Name); + if Ret_Type /= Null_Iir then + pragma Assert (Is_Overload_List (Ret_Type)); + Free_Overload_List (Ret_Type); + end if; + + Set_Named_Entity (Name, Res); + Res := Finish_Sem_Name (Name); + -- Fall through. + end if; + else + -- Create a list of type. + Ret_Type := Create_List_Of_Types (Expr_List); + if Ret_Type = Null_Iir or else not Is_Overload_List (Ret_Type) then + -- There is either no types or one type for + -- several meanings. + Error_Overload (Name); + Disp_Overload_List (Expr_List, Name); + --Free_Iir (Ret_Type); + return Null_Iir; + end if; + Set_Type (Name, Ret_Type); + return Name; + end if; + end if; + + -- NAME has only one meaning, which is RES. + case Get_Kind (Res) is + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Selected_Name => + Expr := Get_Named_Entity (Res); + case Get_Kind (Expr) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Function_Declaration => + if Maybe_Function_Call (Expr) then + Expr := Sem_As_Function_Call (Res, Expr, Null_Iir); + if Get_Kind (Expr) /= Iir_Kind_Function_Call then + raise Internal_Error; + end if; + Finish_Sem_Function_Call (Expr, Res); + return Expr; + else + Error_Msg_Sem + (Disp_Node (Expr) & " requires parameters", Res); + Set_Type (Res, Get_Type (Expr)); + Set_Expr_Staticness (Res, None); + return Res; + end if; + when others => + null; + end case; + Set_Type (Res, Get_Type (Expr)); + Set_Expr_Staticness (Res, Get_Expr_Staticness (Expr)); + --Set_Name_Staticness (Name, Get_Name_Staticness (Expr)); + --Set_Base_Name (Name, Get_Base_Name (Expr)); + return Res; + when Iir_Kind_Function_Call + | Iir_Kind_Selected_Element + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Type_Conversion + | Iir_Kind_Attribute_Name => + return Eval_Expr_If_Static (Res); + when Iir_Kind_Dereference => + -- Never static. + return Res; + when Iir_Kinds_Array_Attribute => + -- FIXME: exclude range and reverse_range. + return Eval_Expr_If_Static (Res); + when Iir_Kinds_Signal_Attribute + | Iir_Kinds_Signal_Value_Attribute => + -- Never static + return Res; + when Iir_Kinds_Type_Attribute + | Iir_Kinds_Scalar_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute + | Iir_Kind_Simple_Name_Attribute + | Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + return Eval_Expr_If_Static (Res); + when Iir_Kind_Parenthesis_Name + | Iir_Kind_Selected_By_All_Name => + raise Internal_Error; + when others => + Error_Kind ("name_to_expression", Res); + end case; + end Name_To_Expression; + + function Name_To_Range (Name : Iir) return Iir + is + Expr : Iir; + begin + Expr := Get_Named_Entity (Name); + if Get_Kind (Expr) = Iir_Kind_Error then + return Error_Mark; + end if; + + case Get_Kind (Expr) is + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration => + Expr := Sem_Type_Mark (Name); + Set_Expr_Staticness + (Expr, Get_Type_Staticness (Get_Type (Expr))); + return Expr; + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + if Get_Parameter (Expr) = Null_Iir then + Finish_Sem_Array_Attribute (Name, Expr, Null_Iir); + end if; + if Get_Kind (Name) = Iir_Kind_Attribute_Name then + Free_Iir (Name); + else + Free_Iir (Get_Prefix (Name)); + Free_Parenthesis_Name (Name, Expr); + end if; + return Expr; + when others => + Error_Msg_Sem ("name " & Disp_Node (Name) + & " doesn't denote a range", Name); + return Error_Mark; + end case; + end Name_To_Range; + + function Is_Object_Name (Name : Iir) return Boolean is + begin + case Get_Kind (Name) is + when Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Dereference + | Iir_Kind_Attribute_Value + | Iir_Kind_Function_Call + | Iir_Kinds_Attribute => + return True; + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return False; + when others => + return False; + end case; + end Is_Object_Name; + + function Name_To_Object (Name : Iir) return Iir is + begin + case Get_Kind (Name) is + when Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Dereference + | Iir_Kind_Attribute_Value + | Iir_Kind_Function_Call + | Iir_Kinds_Signal_Attribute => + return Name; + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Name_To_Object (Get_Named_Entity (Name)); + when others => + return Null_Iir; + end case; + end Name_To_Object; + + function Create_Error_Name (Orig : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Error); + Set_Expr_Staticness (Res, None); + Set_Error_Origin (Res, Orig); + Location_Copy (Res, Orig); + return Res; + end Create_Error_Name; + + function Sem_Denoting_Name (Name: Iir) return Iir + is + Res: Iir; + begin + pragma Assert (Get_Kind (Name) in Iir_Kinds_Denoting_Name); + + Sem_Name (Name); + Res := Get_Named_Entity (Name); + + case Get_Kind (Res) is + when Iir_Kind_Error => + -- A message must have been displayed. + return Name; + when Iir_Kind_Overload_List => + Error_Overload (Res); + Set_Named_Entity (Name, Create_Error_Name (Name)); + return Name; + when Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kinds_Object_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Library_Declaration + | Iir_Kinds_Subprogram_Declaration + | Iir_Kind_Component_Declaration => + Res := Finish_Sem_Name (Name, Res); + pragma Assert (Get_Kind (Res) in Iir_Kinds_Denoting_Name); + return Res; + when Iir_Kind_Selected_Element => + -- An error (to be diagnosticed by the caller). + return Name; + when others => + Error_Kind ("sem_denoting_name", Res); + end case; + end Sem_Denoting_Name; + + function Sem_Terminal_Name (Name : Iir) return Iir + is + Res : Iir; + Ent : Iir; + begin + Res := Sem_Denoting_Name (Name); + Ent := Get_Named_Entity (Res); + if Get_Kind (Ent) /= Iir_Kind_Terminal_Declaration then + Error_Class_Match (Name, "terminal"); + Set_Named_Entity (Res, Create_Error_Name (Name)); + end if; + return Res; + end Sem_Terminal_Name; + + procedure Error_Class_Match (Name : Iir; Class_Name : String) + is + Ent : constant Iir := Get_Named_Entity (Name); + begin + if Is_Error (Ent) then + Error_Msg_Sem (Class_Name & " name expected", Name); + else + Error_Msg_Sem + (Class_Name & " name expected, found " + & Disp_Node (Get_Named_Entity (Name)), Name); + end if; + end Error_Class_Match; +end Sem_Names; diff --git a/src/vhdl/sem_names.ads b/src/vhdl/sem_names.ads new file mode 100644 index 000000000..3bc85305d --- /dev/null +++ b/src/vhdl/sem_names.ads @@ -0,0 +1,159 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +package Sem_Names is + -- In VHDL, most of name notations are ambiguous: + -- P.N is either + -- an expanded name or + -- a selected name for an element (with a possible implicit dereference) + -- P (A1, A2, ...) can be + -- an indexed name (with a possible implicit dereference) + -- a slice name (with a possible implicit dereference) + -- a subprogram call + -- a type conversion + + -- The name analysis resolves two ambiguities: notation and overload. + -- In a first pass, all possible meaning are collected as an overload + -- list in the Named_Entity field of the name. Prefixes in that list + -- are always declarations and not simple or expanded names. This is done + -- to avoid creating nodes for simple or expanded names, as they cannot be + -- shared in the prefixes because they can have several meanings. + -- + -- In a second pass, when the caller has resolved the overloading (using + -- the context), the name is rewritten: parenthesis and selected names are + -- replaced (by slice, index, call, element selection...). Prefixes are + -- simple or expanded names (and never declarations). Checks are also + -- performed on the result (pure, all sensitized). + -- + -- The result of the name analysis may not be a name: a function_call or + -- a type conversion are not names. + + -- Analyze NAME: perform the first pass only. In case of error, a message + -- is displayed and the named entity is error_mark. + procedure Sem_Name (Name : Iir; Keep_Alias : Boolean := False); + + -- Finish semantisation of NAME, if necessary. The named entity must not + -- be an overload list (ie the overload resolution must have been done). + -- This make remaining checks, transforms function names into calls... + function Finish_Sem_Name (Name : Iir) return Iir; + + -- Analyze NAME as a type mark. NAME must be either a simple name or an + -- expanded name, and the denoted entity must be either a type or a subtype + -- declaration. Return the name (possibly modified) and set named_entity + -- and type. In case of error, the type is error_mark. NAME may have + -- already been analyzed by Sem_Name. + -- Incomplete types are allowed only if INCOMPLETE is True. + function Sem_Type_Mark (Name : Iir; Incomplete : Boolean := False) + return Iir; + + -- Same as Sem_Name but without any side-effect: + -- * do not report error + -- * do not set xrefs + -- Currently, only simple names (and expanded names) are handled. + -- This is to be used during sem of associations. Because there is no side + -- effect, NAME is not modified. + procedure Sem_Name_Soft (Name : Iir); + + -- Remove every named_entity of NAME. + -- If NAME is Null_Iir then this is no op. + -- To be used only for names (weakly) semantized by sem_name_soft. + procedure Sem_Name_Clean (Name : Iir); + + -- Return TRUE if NAME is a name that designate an object (ie a constant, + -- a variable, a signal or a file). + function Is_Object_Name (Name : Iir) return Boolean; + + -- Return an object node if NAME designates an object (ie either is an + -- object or a name for an object). + -- Otherwise, returns NULL_IIR. + function Name_To_Object (Name : Iir) return Iir; + + -- If NAME is a selected name whose prefix is a protected variable, set + -- method_object of CALL. + procedure Name_To_Method_Object (Call : Iir; Name : Iir); + + -- Convert name NAME to an expression (ie, can create function call). + -- A_TYPE is the expected type of the expression. + -- FIXME: it is unclear wether the result must be an expression or not + -- (ie, it *must* have a type, but may be a range). + function Name_To_Expression (Name : Iir; A_Type : Iir) return Iir; + + -- Finish analyze of NAME and expect a range (either a type or subtype + -- declaration or a range attribute). Return Error_Mark in case of error. + function Name_To_Range (Name : Iir) return Iir; + + -- Return true if AN_IIR is an overload list. + function Is_Overload_List (An_Iir: Iir) return Boolean; + pragma Inline (Is_Overload_List); + + -- Create an overload list, that must be destroyed by Destroy_Overload_List. + function Get_Overload_List return Iir_Overload_List; + pragma Inline (Get_Overload_List); + + function Create_Overload_List (List : Iir_List) return Iir_Overload_List; + pragma Inline (Create_Overload_List); + + -- Free the list node (and the list itself). + procedure Free_Overload_List (N : in out Iir_Overload_List); + + -- Display an error message if the overload resolution for EXPR find more + -- than one interpretation. + procedure Error_Overload (Expr: Iir); + + -- Disp the overload list LIST. + procedure Disp_Overload_List (List : Iir_List; Loc : Iir); + + -- Convert a list to either Null_Iir, an element or an overload list. + function Simplify_Overload_List (List : Iir_List) return Iir; + + -- Add new interpretation DECL to RES. + -- Create an overload_list if necessary. + -- Before the first call, RES should be set to NULL_IIR. + procedure Add_Result (Res : in out Iir; Decl : Iir); + + -- Free a Parenthesis_Name. This is a special case as in general the + -- Association_Chain field must be freed too. + procedure Free_Parenthesis_Name (Name : Iir; Res : Iir); + + -- Return TRUE iff TYPE1 and TYPE2 are closely related. + function Are_Types_Closely_Related (Type1, Type2 : Iir) return Boolean; + + -- From the list LIST of function or enumeration literal, extract the + -- list of (return) types. + -- If there is only one type, return it. + -- If there is no types, return NULL. + -- Otherwise, return the list as an overload list. + function Create_List_Of_Types (List : Iir_List) return Iir; + + function Sem_Index_Specification (Name : Iir_Parenthesis_Name; Itype : Iir) + return Iir; + + -- Analyze denoting name NAME. NAME must be either a simple name or an + -- expanded name and so is the result. + function Sem_Denoting_Name (Name: Iir) return Iir; + + -- Like Sem_Denoting_Name but expect a terminal name. + function Sem_Terminal_Name (Name : Iir) return Iir; + + -- Emit an error for NAME that doesn't match its class CLASS_NAME. + procedure Error_Class_Match (Name : Iir; Class_Name : String); + + -- Create an error node for name ORIG; set its expr staticness to none. + function Create_Error_Name (Orig : Iir) return Iir; +end Sem_Names; diff --git a/src/vhdl/sem_psl.adb b/src/vhdl/sem_psl.adb new file mode 100644 index 000000000..cae63f740 --- /dev/null +++ b/src/vhdl/sem_psl.adb @@ -0,0 +1,617 @@ +-- Semantic analysis pass for PSL. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with PSL.Nodes; use PSL.Nodes; +with PSL.Subsets; +with PSL.Hash; + +with Sem_Expr; +with Sem_Stmts; use Sem_Stmts; +with Sem_Scopes; +with Sem_Names; +with Std_Names; +with Iirs_Utils; use Iirs_Utils; +with Std_Package; +with Ieee.Std_Logic_1164; +with Errorout; use Errorout; +with Xrefs; use Xrefs; + +package body Sem_Psl is + -- Return TRUE iff Atype is a PSL boolean type. + -- See PSL1.1 5.1.2 Boolean expressions + function Is_Psl_Bool_Type (Atype : Iir) return Boolean + is + Btype : Iir; + begin + if Atype = Null_Iir then + return False; + end if; + Btype := Get_Base_Type (Atype); + return Btype = Std_Package.Boolean_Type_Definition + or else Btype = Std_Package.Bit_Type_Definition + or else Btype = Ieee.Std_Logic_1164.Std_Ulogic_Type; + end Is_Psl_Bool_Type; + + -- Return TRUE if EXPR type is a PSL boolean type. + function Is_Psl_Bool_Expr (Expr : Iir) return Boolean is + begin + return Is_Psl_Bool_Type (Get_Type (Expr)); + end Is_Psl_Bool_Expr; + + -- Convert VHDL and/or/not nodes to PSL nodes. + function Convert_Bool (Expr : Iir) return Node + is + use Std_Names; + Impl : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kinds_Dyadic_Operator => + declare + Left : Iir; + Right : Iir; + + function Build_Op (Kind : Nkind) return Node + is + N : Node; + begin + N := Create_Node (Kind); + Set_Location (N, Get_Location (Expr)); + Set_Left (N, Convert_Bool (Left)); + Set_Right (N, Convert_Bool (Right)); + Free_Iir (Expr); + return N; + end Build_Op; + begin + Impl := Get_Implementation (Expr); + Left := Get_Left (Expr); + Right := Get_Right (Expr); + if Impl /= Null_Iir + and then Is_Psl_Bool_Expr (Left) + and then Is_Psl_Bool_Expr (Right) + then + if Get_Identifier (Impl) = Name_And then + return Build_Op (N_And_Bool); + elsif Get_Identifier (Impl) = Name_Or then + return Build_Op (N_Or_Bool); + end if; + end if; + end; + when Iir_Kinds_Monadic_Operator => + declare + Operand : Iir; + + function Build_Op (Kind : Nkind) return Node + is + N : Node; + begin + N := Create_Node (Kind); + Set_Location (N, Get_Location (Expr)); + Set_Boolean (N, Convert_Bool (Operand)); + Free_Iir (Expr); + return N; + end Build_Op; + begin + Impl := Get_Implementation (Expr); + Operand := Get_Operand (Expr); + if Impl /= Null_Iir + and then Is_Psl_Bool_Expr (Operand) + then + if Get_Identifier (Impl) = Name_Not then + return Build_Op (N_Not_Bool); + end if; + end if; + end; + when Iir_Kinds_Name => + -- Get the named entity for names in order to hash it. + declare + Name : Iir; + begin + Name := Get_Named_Entity (Expr); + if Name /= Null_Iir then + return PSL.Hash.Get_PSL_Node (HDL_Node (Name)); + end if; + end; + when others => + null; + end case; + return PSL.Hash.Get_PSL_Node (HDL_Node (Expr)); + end Convert_Bool; + + -- Semantize an HDL expression. This may mostly a wrapper except in the + -- case when the expression is in fact a PSL expression. + function Sem_Hdl_Expr (N : Node) return Node + is + use Sem_Names; + + Expr : Iir; + Name : Iir; + Decl : Node; + Res : Node; + begin + Expr := Get_HDL_Node (N); + if Get_Kind (Expr) in Iir_Kinds_Name then + Sem_Name (Expr); + Expr := Finish_Sem_Name (Expr); + Set_HDL_Node (N, Expr); + + if Get_Kind (Expr) in Iir_Kinds_Denoting_Name then + Name := Get_Named_Entity (Expr); + else + Name := Expr; + end if; + + case Get_Kind (Name) is + when Iir_Kind_Error => + return N; + when Iir_Kind_Overload_List => + -- FIXME: todo. + raise Internal_Error; + when Iir_Kind_Psl_Declaration => + Decl := Get_Psl_Declaration (Name); + case Get_Kind (Decl) is + when N_Sequence_Declaration => + Res := Create_Node (N_Sequence_Instance); + when N_Endpoint_Declaration => + Res := Create_Node (N_Endpoint_Instance); + when N_Property_Declaration => + Res := Create_Node (N_Property_Instance); + when N_Boolean_Parameter + | N_Sequence_Parameter + | N_Const_Parameter + | N_Property_Parameter => + -- FIXME: create a n_name + Free_Node (N); + Free_Iir (Expr); + return Decl; + when others => + Error_Kind ("sem_hdl_expr(2)", Decl); + end case; + Set_Location (Res, Get_Location (N)); + Set_Declaration (Res, Decl); + if Get_Parameter_List (Decl) /= Null_Node then + Error_Msg_Sem ("no actual for instantiation", Res); + end if; + Free_Node (N); + Free_Iir (Expr); + return Res; + when Iir_Kind_Psl_Expression => + -- Remove the two bridge nodes: from PSL to HDL and from + -- HDL to PSL. + Free_Node (N); + Res := Get_Psl_Expression (Name); + Free_Iir (Expr); + if Name /= Expr then + Free_Iir (Name); + end if; + return Res; + when others => + Expr := Name; + end case; + else + Expr := Sem_Expr.Sem_Expression (Expr, Null_Iir); + end if; + + if Expr = Null_Iir then + return N; + end if; + Free_Node (N); + if not Is_Psl_Bool_Expr (Expr) then + Error_Msg_Sem ("type of expression must be boolean", Expr); + return PSL.Hash.Get_PSL_Node (HDL_Node (Expr)); + else + return Convert_Bool (Expr); + end if; + end Sem_Hdl_Expr; + + -- Sem a boolean node. + function Sem_Boolean (Bool : Node) return Node is + begin + case Get_Kind (Bool) is + when N_HDL_Expr => + return Sem_Hdl_Expr (Bool); + when N_And_Bool + | N_Or_Bool => + Set_Left (Bool, Sem_Boolean (Get_Left (Bool))); + Set_Right (Bool, Sem_Boolean (Get_Right (Bool))); + return Bool; + when others => + Error_Kind ("psl.sem_boolean", Bool); + end case; + end Sem_Boolean; + + -- Used by Sem_Property to rewrite a property logical operator to a + -- boolean logical operator. + function Reduce_Logic_Node (Prop : Node; Bool_Kind : Nkind) return Node + is + Res : Node; + begin + Res := Create_Node (Bool_Kind); + Set_Location (Res, Get_Location (Prop)); + Set_Left (Res, Get_Left (Prop)); + Set_Right (Res, Get_Right (Prop)); + Free_Node (Prop); + return Res; + end Reduce_Logic_Node; + + function Sem_Sequence (Seq : Node) return Node + is + Res : Node; + L, R : Node; + begin + case Get_Kind (Seq) is + when N_Braced_SERE => + Res := Sem_Sequence (Get_SERE (Seq)); + Set_SERE (Seq, Res); + return Seq; + when N_Concat_SERE + | N_Fusion_SERE + | N_Within_SERE + | N_Or_Seq + | N_And_Seq + | N_Match_And_Seq => + L := Sem_Sequence (Get_Left (Seq)); + Set_Left (Seq, L); + R := Sem_Sequence (Get_Right (Seq)); + Set_Right (Seq, R); + return Seq; + when N_Star_Repeat_Seq => + Res := Get_Sequence (Seq); + if Res /= Null_Node then + Res := Sem_Sequence (Get_Sequence (Seq)); + Set_Sequence (Seq, Res); + end if; + -- FIXME: range. + return Seq; + when N_Plus_Repeat_Seq => + Res := Get_Sequence (Seq); + if Res /= Null_Node then + Res := Sem_Sequence (Get_Sequence (Seq)); + Set_Sequence (Seq, Res); + end if; + return Seq; + when N_And_Bool + | N_Or_Bool + | N_Not_Bool => + return Sem_Boolean (Seq); + when N_HDL_Expr => + return Sem_Hdl_Expr (Seq); + when others => + Error_Kind ("psl.sem_sequence", Seq); + end case; + end Sem_Sequence; + + function Sem_Property (Prop : Node; Top : Boolean := False) return Node + is + Res : Node; + L, R : Node; + begin + case Get_Kind (Prop) is + when N_Braced_SERE => + return Sem_Sequence (Prop); + when N_Always + | N_Never => + -- By extension, clock_event is allowed within outermost + -- always/never. + Res := Sem_Property (Get_Property (Prop), Top); + Set_Property (Prop, Res); + return Prop; + when N_Eventually => + Res := Sem_Property (Get_Property (Prop)); + Set_Property (Prop, Res); + return Prop; + when N_Clock_Event => + Res := Sem_Property (Get_Property (Prop)); + Set_Property (Prop, Res); + Res := Sem_Boolean (Get_Boolean (Prop)); + Set_Boolean (Prop, Res); + if not Top then + Error_Msg_Sem ("inner clock event not supported", Prop); + end if; + return Prop; + when N_Abort => + Res := Sem_Property (Get_Property (Prop)); + Set_Property (Prop, Res); + Res := Sem_Boolean (Get_Boolean (Prop)); + Set_Boolean (Prop, Res); + return Prop; + when N_Until + | N_Before => + Res := Sem_Property (Get_Left (Prop)); + Set_Left (Prop, Res); + Res := Sem_Property (Get_Right (Prop)); + Set_Right (Prop, Res); + return Prop; + when N_Log_Imp_Prop + | N_And_Prop + | N_Or_Prop => + L := Sem_Property (Get_Left (Prop)); + Set_Left (Prop, L); + R := Sem_Property (Get_Right (Prop)); + Set_Right (Prop, R); + if Get_Psl_Type (L) = Type_Boolean + and then Get_Psl_Type (R) = Type_Boolean + then + case Get_Kind (Prop) is + when N_And_Prop => + return Reduce_Logic_Node (Prop, N_And_Bool); + when N_Or_Prop => + return Reduce_Logic_Node (Prop, N_Or_Bool); + when N_Log_Imp_Prop => + return Reduce_Logic_Node (Prop, N_Imp_Bool); + when others => + Error_Kind ("psl.sem_property(log)", Prop); + end case; + end if; + return Prop; + when N_Overlap_Imp_Seq + | N_Imp_Seq => + Res := Sem_Sequence (Get_Sequence (Prop)); + Set_Sequence (Prop, Res); + Res := Sem_Property (Get_Property (Prop)); + Set_Property (Prop, Res); + return Prop; + when N_Next => + -- FIXME: number. + Res := Sem_Property (Get_Property (Prop)); + Set_Property (Prop, Res); + return Prop; + when N_Next_A => + -- FIXME: range. + Res := Sem_Property (Get_Property (Prop)); + Set_Property (Prop, Res); + return Prop; + when N_HDL_Expr => + Res := Sem_Hdl_Expr (Prop); + if not Top and then Get_Kind (Res) = N_Property_Instance then + declare + Decl : constant Node := Get_Declaration (Res); + begin + if Decl /= Null_Node + and then Get_Global_Clock (Decl) /= Null_Node + then + Error_Msg_Sem ("property instance already has a clock", + Prop); + end if; + end; + end if; + return Res; + when others => + Error_Kind ("psl.sem_property", Prop); + end case; + end Sem_Property; + + -- Extract the clock from PROP. + procedure Extract_Clock (Prop : in out Node; Clk : out Node) + is + Child : Node; + begin + Clk := Null_Node; + case Get_Kind (Prop) is + when N_Clock_Event => + Clk := Get_Boolean (Prop); + Prop := Get_Property (Prop); + when N_Always + | N_Never => + Child := Get_Property (Prop); + if Get_Kind (Child) = N_Clock_Event then + Set_Property (Prop, Get_Property (Child)); + Clk := Get_Boolean (Child); + end if; + when N_Property_Instance => + Child := Get_Declaration (Prop); + Clk := Get_Global_Clock (Child); + when others => + null; + end case; + end Extract_Clock; + + -- Sem a property/sequence/endpoint declaration. + procedure Sem_Psl_Declaration (Stmt : Iir) + is + use Sem_Scopes; + Decl : Node; + Prop : Node; + Clk : Node; + Formal : Node; + El : Iir; + begin + Sem_Scopes.Add_Name (Stmt); + Xref_Decl (Stmt); + + Decl := Get_Psl_Declaration (Stmt); + + Open_Declarative_Region; + + -- Make formal parameters visible. + Formal := Get_Parameter_List (Decl); + while Formal /= Null_Node loop + El := Create_Iir (Iir_Kind_Psl_Declaration); + Set_Location (El, Get_Location (Formal)); + Set_Identifier (El, Get_Identifier (Formal)); + Set_Psl_Declaration (El, Formal); + + Sem_Scopes.Add_Name (El); + Xref_Decl (El); + Set_Visible_Flag (El, True); + + Formal := Get_Chain (Formal); + end loop; + + case Get_Kind (Decl) is + when N_Property_Declaration => + -- FIXME: sem formal list + Prop := Get_Property (Decl); + Prop := Sem_Property (Prop, True); + Extract_Clock (Prop, Clk); + Set_Property (Decl, Prop); + Set_Global_Clock (Decl, Clk); + -- Check simple subset restrictions. + PSL.Subsets.Check_Simple (Prop); + when N_Sequence_Declaration + | N_Endpoint_Declaration => + -- FIXME: sem formal list, do not allow property parameter. + Prop := Get_Sequence (Decl); + Prop := Sem_Sequence (Prop); + Set_Sequence (Decl, Prop); + PSL.Subsets.Check_Simple (Prop); + when others => + Error_Kind ("sem_psl_declaration", Decl); + end case; + Set_Visible_Flag (Stmt, True); + + Close_Declarative_Region; + end Sem_Psl_Declaration; + + procedure Sem_Psl_Assert_Statement (Stmt : Iir) + is + Prop : Node; + Clk : Node; + begin + Prop := Get_Psl_Property (Stmt); + Prop := Sem_Property (Prop, True); + Extract_Clock (Prop, Clk); + Set_Psl_Property (Stmt, Prop); + + -- Sem report and severity expressions. + Sem_Report_Statement (Stmt); + + -- Properties must be clocked. + if Clk = Null_Node then + if Current_Psl_Default_Clock = Null_Iir then + Error_Msg_Sem ("no clock for PSL assert", Stmt); + Clk := Null_Node; + else + Clk := Get_Psl_Boolean (Current_Psl_Default_Clock); + end if; + end if; + Set_PSL_Clock (Stmt, Clk); + + -- Check simple subset restrictions. + PSL.Subsets.Check_Simple (Prop); + end Sem_Psl_Assert_Statement; + + procedure Sem_Psl_Default_Clock (Stmt : Iir) + is + Expr : Node; + begin + if Current_Psl_Default_Clock /= Null_Iir + and then Get_Parent (Current_Psl_Default_Clock) = Get_Parent (Stmt) + then + Error_Msg_Sem + ("redeclaration of PSL default clock in the same region", Stmt); + Error_Msg_Sem (" (previous default clock declaration)", + Current_Psl_Default_Clock); + end if; + Expr := Sem_Boolean (Get_Psl_Boolean (Stmt)); + Set_Psl_Boolean (Stmt, Expr); + Current_Psl_Default_Clock := Stmt; + end Sem_Psl_Default_Clock; + + function Sem_Psl_Instance_Name (Name : Iir) return Iir + is + Prefix : Iir; + Ent : Iir; + Decl : Node; + Formal : Node; + Assoc : Iir; + Res : Node; + Last_Assoc : Node; + Assoc2 : Node; + Actual : Iir; + Psl_Actual : Node; + Res2 : Iir; + begin + Prefix := Get_Prefix (Name); + Ent := Get_Named_Entity (Prefix); + pragma Assert (Get_Kind (Ent) = Iir_Kind_Psl_Declaration); + Decl := Get_Psl_Declaration (Ent); + case Get_Kind (Decl) is + when N_Property_Declaration => + Res := Create_Node (N_Property_Instance); + when N_Sequence_Declaration => + Res := Create_Node (N_Sequence_Instance); + when N_Endpoint_Declaration => + Res := Create_Node (N_Endpoint_Instance); + when others => + Error_Msg_Sem ("can only instantiate a psl declaration", Name); + return Null_Iir; + end case; + Set_Declaration (Res, Decl); + Set_Location (Res, Get_Location (Name)); + Formal := Get_Parameter_List (Decl); + Assoc := Get_Association_Chain (Name); + Last_Assoc := Null_Node; + + while Formal /= Null_Node loop + if Assoc = Null_Iir then + Error_Msg_Sem ("not enough association", Name); + exit; + end if; + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then + Error_Msg_Sem + ("open or individual association not allowed", Assoc); + elsif Get_Formal (Assoc) /= Null_Iir then + Error_Msg_Sem ("named association not allowed in psl", Assoc); + else + Actual := Get_Actual (Assoc); + -- FIXME: currently only boolean are parsed. + Actual := Sem_Expr.Sem_Expression (Actual, Null_Iir); + if Get_Kind (Actual) in Iir_Kinds_Name then + Actual := Get_Named_Entity (Actual); + end if; + Psl_Actual := PSL.Hash.Get_PSL_Node (HDL_Node (Actual)); + end if; + + Assoc2 := Create_Node (N_Actual); + Set_Location (Assoc2, Get_Location (Assoc)); + Set_Formal (Assoc2, Formal); + Set_Actual (Assoc2, Psl_Actual); + if Last_Assoc = Null_Node then + Set_Association_Chain (Res, Assoc2); + else + Set_Chain (Last_Assoc, Assoc2); + end if; + Last_Assoc := Assoc2; + + Formal := Get_Chain (Formal); + Assoc := Get_Chain (Assoc); + end loop; + if Assoc /= Null_Iir then + Error_Msg_Sem ("too many association", Name); + end if; + + Res2 := Create_Iir (Iir_Kind_Psl_Expression); + Set_Psl_Expression (Res2, Res); + Location_Copy (Res2, Name); + return Res2; + end Sem_Psl_Instance_Name; + + -- Called by sem_names to semantize a psl name. + function Sem_Psl_Name (Name : Iir) return Iir is + begin + case Get_Kind (Name) is + when Iir_Kind_Parenthesis_Name => + return Sem_Psl_Instance_Name (Name); + when others => + Error_Kind ("sem_psl_name", Name); + end case; + return Null_Iir; + end Sem_Psl_Name; + +end Sem_Psl; diff --git a/src/vhdl/sem_psl.ads b/src/vhdl/sem_psl.ads new file mode 100644 index 000000000..59df96f7f --- /dev/null +++ b/src/vhdl/sem_psl.ads @@ -0,0 +1,26 @@ +-- Semantic analysis pass for PSL. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Iirs; use Iirs; + +package Sem_Psl is + procedure Sem_Psl_Declaration (Stmt : Iir); + procedure Sem_Psl_Assert_Statement (Stmt : Iir); + procedure Sem_Psl_Default_Clock (Stmt : Iir); + function Sem_Psl_Name (Name : Iir) return Iir; +end Sem_Psl; diff --git a/src/vhdl/sem_scopes.adb b/src/vhdl/sem_scopes.adb new file mode 100644 index 000000000..71c758575 --- /dev/null +++ b/src/vhdl/sem_scopes.adb @@ -0,0 +1,1412 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Text_IO; +with GNAT.Table; +with Flags; use Flags; +with Name_Table; -- use Name_Table; +with Errorout; use Errorout; +with Iirs_Utils; use Iirs_Utils; + +package body Sem_Scopes is + -- FIXME: names: + -- scopes => regions ? + + -- Debugging subprograms. + procedure Disp_All_Names; + pragma Unreferenced (Disp_All_Names); + + procedure Disp_Scopes; + pragma Unreferenced (Disp_Scopes); + + procedure Disp_Detailed_Interpretations (Ident : Name_Id); + pragma Unreferenced (Disp_Detailed_Interpretations); + + -- An interpretation cell is the element of the simply linked list + -- of interpratation for an identifier. + -- DECL is visible declaration; + -- NEXT is the next element of the list. + -- Interpretation cells are stored in a stack, Interpretations. + type Interpretation_Cell is record + Decl: Iir; + Is_Potential : Boolean; + Pad_0 : Boolean; + Next: Name_Interpretation_Type; + end record; + pragma Pack (Interpretation_Cell); + + -- To manage the list of interpretation and to add informations to this + -- list, a stack is used. + -- Elements of stack can be of kind: + -- Save_Cell: + -- the element contains the interpretation INTER for the indentifier ID + -- for the outer declarative region. + -- A save cell is always each time a declaration is added to save the + -- previous interpretation. + -- Region_Start: + -- A new declarative region start at interpretation INTER. Here, INTER + -- is used as an index in the interpretations stack (table). + -- ID is used as an index into the unidim_array stack. + -- Barrier_start, Barrier_end: + -- All currents interpretations are saved between both INTER, and + -- are cleared. This is used to call semantic during another semantic. + + type Scope_Cell_Kind_Type is + (Save_Cell, Hide_Cell, Region_Start, Barrier_Start, Barrier_End); + + type Scope_Cell is record + Kind: Scope_Cell_Kind_Type; + + -- Usage of Inter: + -- Save_Cell: previous value of name_table (id).info + -- Hide_Cell: interpretation hidden. + -- Region_Start: previous value of Current_Scope_Start. + -- Barrier_Start: previous value of current_scope_start. + -- Barrier_End: last index of interpretations table. + Inter: Name_Interpretation_Type; + + -- Usage of Id: + -- Save_Cell: ID whose interpretations are saved. + -- Hide_Cell: not used. + -- Region_Start: previous value of the last index of visible_types. + -- Barrier_Start: previous value of CURRENT_BARRIER. + -- Barrier_End: previous value of Current_composite_types_start. + Id: Name_Id; + end record; + + package Interpretations is new GNAT.Table + (Table_Component_Type => Interpretation_Cell, + Table_Index_Type => Name_Interpretation_Type, + Table_Low_Bound => First_Valid_Interpretation, + Table_Initial => 128, + Table_Increment => 50); + + package Scopes is new GNAT.Table + (Table_Component_Type => Scope_Cell, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 128, + Table_Increment => 50); + + -- Index into Interpretations marking the last interpretation of + -- the previous (immediate) declarative region. + Current_Scope_Start: Name_Interpretation_Type := No_Name_Interpretation; + + function Valid_Interpretation (Inter : Name_Interpretation_Type) + return Boolean is + begin + return Inter >= First_Valid_Interpretation; + end Valid_Interpretation; + + -- Get and Set the info field of the table table for a + -- name_interpretation. + function Get_Interpretation (Id: Name_Id) return Name_Interpretation_Type is + begin + return Name_Interpretation_Type (Name_Table.Get_Info (Id)); + end Get_Interpretation; + + procedure Set_Interpretation (Id: Name_Id; Inter: Name_Interpretation_Type) + is + begin + Name_Table.Set_Info (Id, Int32 (Inter)); + end Set_Interpretation; + + function Get_Under_Interpretation (Id : Name_Id) + return Name_Interpretation_Type + is + Inter : Name_Interpretation_Type; + begin + Inter := Name_Interpretation_Type (Name_Table.Get_Info (Id)); + + -- ID has no interpretation. + -- So, there is no 'under' interpretation (FIXME: prove it). + if not Valid_Interpretation (Inter) then + return No_Name_Interpretation; + end if; + for I in reverse Scopes.First .. Scopes.Last loop + declare + S : Scope_Cell renames Scopes.Table (I); + begin + case S.Kind is + when Save_Cell => + if S.Id = Id then + -- This is the previous one, return it. + return S.Inter; + end if; + when Region_Start + | Hide_Cell => + null; + when Barrier_Start + | Barrier_End => + return No_Name_Interpretation; + end case; + end; + end loop; + return No_Name_Interpretation; + end Get_Under_Interpretation; + + procedure Check_Interpretations; + pragma Unreferenced (Check_Interpretations); + + procedure Check_Interpretations + is + Inter: Name_Interpretation_Type; + Last : Name_Interpretation_Type; + Err : Boolean; + begin + Last := Interpretations.Last; + Err := False; + for I in 0 .. Name_Table.Last_Name_Id loop + Inter := Get_Interpretation (I); + if Inter > Last then + Ada.Text_IO.Put_Line + ("bad interpretation for " & Name_Table.Image (I)); + Err := True; + end if; + end loop; + if Err then + raise Internal_Error; + end if; + end Check_Interpretations; + + -- Create a new declarative region. + -- Simply push a region_start cell and update current_scope_start. + procedure Open_Declarative_Region is + begin + Scopes.Increment_Last; + Scopes.Table (Scopes.Last) := (Kind => Region_Start, + Inter => Current_Scope_Start, + Id => Null_Identifier); + Current_Scope_Start := Interpretations.Last; + end Open_Declarative_Region; + + -- Close a declarative region. + -- Update interpretation of identifiers. + procedure Close_Declarative_Region is + begin + loop + case Scopes.Table (Scopes.Last).Kind is + when Region_Start => + -- Discard interpretations cells added in this scopes. + Interpretations.Set_Last (Current_Scope_Start); + -- Restore Current_Scope_Start. + Current_Scope_Start := Scopes.Table (Scopes.Last).Inter; + Scopes.Decrement_Last; + return; + when Save_Cell => + -- Restore a previous interpretation. + Set_Interpretation (Scopes.Table (Scopes.Last).Id, + Scopes.Table (Scopes.Last).Inter); + when Hide_Cell => + -- Unhide previous interpretation. + declare + H, S : Name_Interpretation_Type; + begin + H := Scopes.Table (Scopes.Last).Inter; + S := Interpretations.Table (H).Next; + Interpretations.Table (H).Next := + Interpretations.Table (S).Next; + Interpretations.Table (S).Next := H; + end; + when Barrier_Start + | Barrier_End => + -- Barrier cannot exist inside a declarative region. + raise Internal_Error; + end case; + Scopes.Decrement_Last; + end loop; + end Close_Declarative_Region; + + procedure Open_Scope_Extension renames Open_Declarative_Region; + procedure Close_Scope_Extension renames Close_Declarative_Region; + + function Get_Next_Interpretation (Ni: Name_Interpretation_Type) + return Name_Interpretation_Type is + begin + if not Valid_Interpretation (Ni) then + raise Internal_Error; + end if; + return Interpretations.Table (Ni).Next; + end Get_Next_Interpretation; + + function Get_Declaration (Ni: Name_Interpretation_Type) + return Iir is + begin + if not Valid_Interpretation (Ni) then + raise Internal_Error; + end if; + return Interpretations.Table (Ni).Decl; + end Get_Declaration; + + function Strip_Non_Object_Alias (Decl : Iir) return Iir + is + Res : Iir; + begin + Res := Decl; + if Get_Kind (Res) = Iir_Kind_Non_Object_Alias_Declaration then + Res := Get_Named_Entity (Get_Name (Res)); + end if; + return Res; + end Strip_Non_Object_Alias; + + function Get_Non_Alias_Declaration (Ni: Name_Interpretation_Type) + return Iir is + begin + return Strip_Non_Object_Alias (Get_Declaration (Ni)); + end Get_Non_Alias_Declaration; + + -- Pointer just past the last barrier_end in the scopes stack. + Current_Barrier : Integer := 0; + + procedure Push_Interpretations is + begin + -- Add a barrier_start. + -- Save current_scope_start and current_barrier. + Scopes.Increment_Last; + Scopes.Table (Scopes.Last) := (Kind => Barrier_Start, + Inter => Current_Scope_Start, + Id => Name_Id (Current_Barrier)); + + -- Save all the current name interpretations. + -- (For each name that have interpretations, there is a save_cell + -- containing the interpretations for the outer scope). + -- FIXME: maybe we should only save the name_table info. + for I in Current_Barrier .. Scopes.Last - 1 loop + if Scopes.Table (I).Kind = Save_Cell then + Scopes.Increment_Last; + Scopes.Table (Scopes.Last) := + (Kind => Save_Cell, + Inter => Get_Interpretation (Scopes.Table (I).Id), + Id => Scopes.Table (I).Id); + Set_Interpretation (Scopes.Table (I).Id, No_Name_Interpretation); + end if; + end loop; + + -- Add a barrier_end. + -- Save interpretations.last. + Scopes.Increment_Last; + Scopes.Table (Scopes.Last) := + (Kind => Barrier_End, + Inter => Interpretations.Last, + Id => Null_Identifier); + + -- Start a completly new scope. + Current_Scope_Start := Interpretations.Last + 1; + + -- Keep the last barrier. + Current_Barrier := Scopes.Last + 1; + + pragma Debug (Name_Table.Assert_No_Infos); + end Push_Interpretations; + + procedure Pop_Interpretations is + begin + -- clear all name interpretations set by the current barrier. + for I in Current_Barrier .. Scopes.Last loop + if Scopes.Table (I).Kind = Save_Cell then + Set_Interpretation (Scopes.Table (I).Id, No_Name_Interpretation); + end if; + end loop; + Scopes.Set_Last (Current_Barrier - 1); + if Scopes.Table (Scopes.Last).Kind /= Barrier_End then + raise Internal_Error; + end if; + + pragma Debug (Name_Table.Assert_No_Infos); + + -- Restore the stack pointer of interpretations. + Interpretations.Set_Last (Scopes.Table (Scopes.Last).Inter); + Scopes.Decrement_Last; + + -- Restore all name interpretations. + while Scopes.Table (Scopes.Last).Kind /= Barrier_Start loop + Set_Interpretation (Scopes.Table (Scopes.Last).Id, + Scopes.Table (Scopes.Last).Inter); + Scopes.Decrement_Last; + end loop; + + -- Restore current_scope_start and current_barrier. + Current_Scope_Start := Scopes.Table (Scopes.Last).Inter; + Current_Barrier := Natural (Scopes.Table (Scopes.Last).Id); + + Scopes.Decrement_Last; + end Pop_Interpretations; + + -- Return TRUE if INTER was made directly visible via a use clause. + function Is_Potentially_Visible (Inter: Name_Interpretation_Type) + return Boolean + is + begin + return Interpretations.Table (Inter).Is_Potential; + end Is_Potentially_Visible; + + -- Return TRUE iif DECL can be overloaded. + function Is_Overloadable (Decl: Iir) return Boolean is + begin + -- LRM93 §10.3: + -- The overloaded declarations considered in this chapter are those for + -- subprograms and enumeration literals. + case Get_Kind (Decl) is + when Iir_Kind_Enumeration_Literal + | Iir_Kinds_Function_Declaration + | Iir_Kinds_Procedure_Declaration => + return True; + when Iir_Kind_Non_Object_Alias_Declaration => + case Get_Kind (Get_Named_Entity (Get_Name (Decl))) is + when Iir_Kind_Enumeration_Literal + | Iir_Kinds_Function_Declaration + | Iir_Kinds_Procedure_Declaration => + return True; + when Iir_Kind_Non_Object_Alias_Declaration => + raise Internal_Error; + when others => + return False; + end case; + when others => + return False; + end case; + end Is_Overloadable; + + -- Return TRUE if INTER was made direclty visible in the current + -- declarative region. + function Is_In_Current_Declarative_Region (Inter: Name_Interpretation_Type) + return Boolean is + begin + return Inter > Current_Scope_Start; + end Is_In_Current_Declarative_Region; + + -- Called when CURR is being declared in the same declarative region as + -- PREV, using the same identifier. + -- The function assumes CURR and PREV are both overloadable. + -- Return TRUE if this redeclaration is allowed. +-- function Redeclaration_Allowed (Prev, Curr : Iir) return Boolean is +-- begin +-- case Get_Kind (Curr) is +-- when Iir_Kinds_Function_Specification +-- | Iir_Kinds_Procedure_Specification => +-- if ((Get_Kind (Prev) in Iir_Kinds_User_Function_Specification +-- and then +-- Get_Kind (Curr) in Iir_Kinds_User_Function_Specification) +-- or else +-- (Get_Kind (Prev) in Iir_Kinds_User_Procedure_Specification +-- and then +-- Get_Kind (Curr) in Iir_Kinds_User_Procedure_Specification)) +-- then +-- return not Iirs_Utils.Is_Same_Profile (Prev, Curr); +-- else +-- return True; +-- end if; +-- when Iir_Kind_Enumeration_Literal => +-- if Get_Kind (Prev) /= Get_Kind (Curr) then +-- -- FIXME: PREV may be a function returning the type of the +-- -- literal. +-- return True; +-- end if; +-- return Get_Type (Prev) /= Get_Type (Curr); +-- when others => +-- return False; +-- end case; +-- end Redeclaration_Allowed; + + -- Add interpretation DECL to the identifier of DECL. + -- POTENTIALLY is true if the identifier comes from a use clause. + procedure Add_Name (Decl: Iir; Ident: Name_Id; Potentially: Boolean) + is + -- Current interpretation of ID. This is the one before DECL is + -- added (if so). + Current_Inter: Name_Interpretation_Type; + Current_Decl : Iir; + + -- Before adding a new interpretation, the current interpretation + -- must be saved so that it could be restored when the current scope + -- is removed. That must be done only once per scope and per + -- interpretation. Note that the saved interpretation is not removed + -- from the chain of interpretations. + procedure Save_Current_Interpretation is + begin + Scopes.Increment_Last; + Scopes.Table (Scopes.Last) := + (Kind => Save_Cell, Id => Ident, Inter => Current_Inter); + end Save_Current_Interpretation; + + -- Add DECL in the chain of interpretation for the identifier. + procedure Add_New_Interpretation is + begin + Interpretations.Increment_Last; + Interpretations.Table (Interpretations.Last) := + (Decl => Decl, Next => Current_Inter, + Is_Potential => Potentially, Pad_0 => False); + Set_Interpretation (Ident, Interpretations.Last); + end Add_New_Interpretation; + begin + Current_Inter := Get_Interpretation (Ident); + + if Current_Inter = No_Name_Interpretation + or else (Current_Inter = Conflict_Interpretation and not Potentially) + then + -- Very simple: no hidding, no overloading. + -- (current interpretation is Conflict_Interpretation if there is + -- only potentially visible declarations that are not made directly + -- visible). + -- Note: in case of conflict interpretation, it may be unnecessary + -- to save the current interpretation (but it is simpler to always + -- save it). + Save_Current_Interpretation; + Add_New_Interpretation; + return; + end if; + + if Potentially then + if Current_Inter = Conflict_Interpretation then + -- Yet another conflicting interpretation. + return; + end if; + + -- Do not re-add a potential decl. This handles cases like: + -- 'use p.all; use p.all;'. + -- FIXME: add a flag (or reuse Visible_Flag) to avoid walking all + -- the interpretations. + declare + Inter: Name_Interpretation_Type := Current_Inter; + begin + while Valid_Interpretation (Inter) loop + if Get_Declaration (Inter) = Decl then + return; + end if; + Inter := Get_Next_Interpretation (Inter); + end loop; + end; + end if; + + -- LRM 10.3 Visibility + -- Each of two declarations is said to be a homograph of the other if + -- both declarations have the same identifier, operator symbol, or + -- character literal, and overloading is allowed for at most one + -- of the two. + -- + -- GHDL: the condition 'overloading is allowed for at most one of the + -- two' is false iff overloading is allowed for both; this is a nand. + + -- Note: at this stage, current_inter is valid. + Current_Decl := Get_Declaration (Current_Inter); + + if Is_Overloadable (Current_Decl) and then Is_Overloadable (Decl) then + -- Current_Inter and Decl overloads (well, they have the same + -- designator). + + -- LRM 10.3 Visibility + -- If overloading is allowed for both declarations, then each of the + -- two is a homograph of the other if they have the same identifier, + -- operator symbol or character literal, as well as the same + -- parameter and result profile. + + declare + Homograph : Name_Interpretation_Type; + Prev_Homograph : Name_Interpretation_Type; + + -- Add DECL in the chain of interpretation, and save the current + -- one if necessary. + procedure Maybe_Save_And_Add_New_Interpretation is + begin + if not Is_In_Current_Declarative_Region (Current_Inter) then + Save_Current_Interpretation; + end if; + Add_New_Interpretation; + end Maybe_Save_And_Add_New_Interpretation; + + -- Hide HOMOGRAPH (ie unlink it from the chain of interpretation). + procedure Hide_Homograph + is + S : Name_Interpretation_Type; + begin + if Prev_Homograph = No_Name_Interpretation then + Prev_Homograph := Interpretations.Last; + end if; + if Interpretations.Table (Prev_Homograph).Next /= Homograph + then + -- PREV_HOMOGRAPH must be the interpretation just before + -- HOMOGRAPH. + raise Internal_Error; + end if; + + -- Hide previous interpretation. + S := Interpretations.Table (Homograph).Next; + Interpretations.Table (Homograph).Next := Prev_Homograph; + Interpretations.Table (Prev_Homograph).Next := S; + Scopes.Increment_Last; + Scopes.Table (Scopes.Last) := + (Kind => Hide_Cell, + Id => Null_Identifier, Inter => Homograph); + end Hide_Homograph; + + function Get_Hash_Non_Alias (D : Iir) return Iir_Int32 is + begin + return Get_Subprogram_Hash (Strip_Non_Object_Alias (D)); + end Get_Hash_Non_Alias; + + -- Return True iff D is an implicit declaration (either a + -- subprogram or an implicit alias). + function Is_Implicit_Declaration (D : Iir) return Boolean is + begin + case Get_Kind (D) is + when Iir_Kinds_Implicit_Subprogram_Declaration => + return True; + when Iir_Kind_Non_Object_Alias_Declaration => + return Get_Implicit_Alias_Flag (D); + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + return False; + when others => + Error_Kind ("is_implicit_declaration", D); + end case; + end Is_Implicit_Declaration; + + -- Return TRUE iff D is an implicit alias of an implicit + -- subprogram. + function Is_Implicit_Alias (D : Iir) return Boolean is + begin + -- FIXME: Is it possible to have an implicit alias of an + -- explicit subprogram ? Yes for enumeration literal and + -- physical units. + return Get_Kind (D) = Iir_Kind_Non_Object_Alias_Declaration + and then Get_Implicit_Alias_Flag (D) + and then (Get_Kind (Get_Named_Entity (Get_Name (D))) + in Iir_Kinds_Implicit_Subprogram_Declaration); + end Is_Implicit_Alias; + + -- Replace the homograph of DECL by DECL. + procedure Replace_Homograph is + begin + Interpretations.Table (Homograph).Decl := Decl; + end Replace_Homograph; + + Decl_Hash : Iir_Int32; + Hash : Iir_Int32; + begin + Decl_Hash := Get_Hash_Non_Alias (Decl); + if Decl_Hash = 0 then + -- The hash must have been computed. + raise Internal_Error; + end if; + + -- Find an homograph of this declaration (and also keep the + -- interpretation just before it in the chain), + Homograph := Current_Inter; + Prev_Homograph := No_Name_Interpretation; + while Homograph /= No_Name_Interpretation loop + Current_Decl := Get_Declaration (Homograph); + Hash := Get_Hash_Non_Alias (Current_Decl); + exit when Decl_Hash = Hash + and then Is_Same_Profile (Decl, Current_Decl); + Prev_Homograph := Homograph; + Homograph := Get_Next_Interpretation (Homograph); + end loop; + + if Homograph = No_Name_Interpretation then + -- Simple case: no homograph. + Maybe_Save_And_Add_New_Interpretation; + return; + end if; + + -- There is an homograph. + if Potentially then + -- Added DECL would be made potentially visible. + + -- LRM93 10.4 1) / LRM08 12.4 a) Use Clauses + -- 1. A potentially visible declaration is not made + -- directly visible if the place considered is within the + -- immediate scope of a homograph of the declaration. + if Is_In_Current_Declarative_Region (Homograph) then + if not Is_Potentially_Visible (Homograph) then + return; + end if; + end if; + + -- LRM08 12.4 Use Clauses + -- b) If two potentially visible declarations are homograph + -- and one is explicitly declared and the other is + -- implicitly declared, then the implicit declaration is + -- not made directly visible. + if (Flags.Flag_Explicit or else Flags.Vhdl_Std >= Vhdl_08) + and then Is_Potentially_Visible (Homograph) + then + declare + Implicit_Current_Decl : constant Boolean := + Is_Implicit_Declaration (Current_Decl); + Implicit_Decl : constant Boolean := + Is_Implicit_Declaration (Decl); + begin + if Implicit_Current_Decl and then not Implicit_Decl then + if Is_In_Current_Declarative_Region (Homograph) then + Replace_Homograph; + else + -- Hide homoraph and insert decl. + Maybe_Save_And_Add_New_Interpretation; + Hide_Homograph; + end if; + return; + elsif not Implicit_Current_Decl and then Implicit_Decl + then + -- Discard decl. + return; + elsif Strip_Non_Object_Alias (Decl) + = Strip_Non_Object_Alias (Current_Decl) + then + -- This rule is not written clearly in the LRM, but + -- if two designators denote the same named entity, + -- no need to make both visible. + return; + end if; + end; + end if; + + -- GHDL: if the homograph is in the same declarative + -- region than DECL, it must be an implicit declaration + -- to be hidden. + -- FIXME: this rule is not in the LRM93, but it is necessary + -- so that explicit declaration hides the implicit one. + if Flags.Vhdl_Std < Vhdl_08 + and then not Flags.Flag_Explicit + and then Get_Parent (Decl) = Get_Parent (Current_Decl) + then + declare + Implicit_Current_Decl : constant Boolean := + (Get_Kind (Current_Decl) + in Iir_Kinds_Implicit_Subprogram_Declaration); + Implicit_Decl : constant Boolean := + (Get_Kind (Decl) + in Iir_Kinds_Implicit_Subprogram_Declaration); + begin + if Implicit_Current_Decl and not Implicit_Decl then + -- Note: no need to save previous interpretation, as + -- it is in the same declarative region. + -- Replace the previous homograph with DECL. + Replace_Homograph; + return; + elsif not Implicit_Current_Decl and Implicit_Decl then + -- As we have replaced the homograph, it is possible + -- than the implicit declaration is re-added (by + -- a new use clause). Discard it. + return; + end if; + end; + end if; + + -- The homograph was made visible in an outer declarative + -- region. Therefore, it must not be hidden. + Maybe_Save_And_Add_New_Interpretation; + + return; + else + -- Added DECL would be made directly visible. + + if not Is_Potentially_Visible (Homograph) then + -- The homograph was also declared in that declarative + -- region or in an inner one. + if Is_In_Current_Declarative_Region (Homograph) then + -- ... and was declared in the same region + + -- To sum up: at this point both DECL and CURRENT_DECL + -- are overloadable, have the same profile (but may be + -- aliases) and are declared in the same declarative + -- region. + + -- LRM08 12.3 Visibility + -- LRM93 10.3 Visibility + -- Two declarations that occur immediately within + -- the same declarative regions [...] shall not be + -- homograph, unless exactely one of them is the + -- implicit declaration of a predefined operation, + + -- LRM08 12.3 Visibility + -- or is an implicit alias of such implicit declaration. + -- + -- GHDL: FIXME: 'implicit alias' + + -- LRM08 12.3 Visibility + -- LRM93 10.3 Visibility + -- Each of two declarations is said to be a + -- homograph of the other if and only if both + -- declarations have the same designator, [...] + -- + -- LRM08 12.3 Visibility + -- [...] and they denote different named entities, + -- and [...] + declare + Is_Decl_Implicit : Boolean; + Is_Current_Decl_Implicit : Boolean; + begin + if Flags.Vhdl_Std >= Vhdl_08 then + Is_Current_Decl_Implicit := + (Get_Kind (Current_Decl) in + Iir_Kinds_Implicit_Subprogram_Declaration) + or else Is_Implicit_Alias (Current_Decl); + Is_Decl_Implicit := + (Get_Kind (Decl) in + Iir_Kinds_Implicit_Subprogram_Declaration) + or else Is_Implicit_Alias (Decl); + + -- If they denote the same entity, they aren't + -- homograph. + if Strip_Non_Object_Alias (Decl) + = Strip_Non_Object_Alias (Current_Decl) + then + if Is_Current_Decl_Implicit + and then not Is_Decl_Implicit + then + -- They aren't homograph but DECL is stronger + -- (at it is not an implicit declaration) + -- than CURRENT_DECL + Replace_Homograph; + end if; + + return; + end if; + + if Is_Decl_Implicit + and then not Is_Current_Decl_Implicit + then + -- Re-declaration of an implicit subprogram via + -- an implicit alias is simply discarded. + return; + end if; + else + -- Can an implicit subprogram declaration appears + -- after an explicit one in vhdl 93? I don't + -- think so. + Is_Decl_Implicit := + (Get_Kind (Decl) + in Iir_Kinds_Implicit_Subprogram_Declaration); + Is_Current_Decl_Implicit := + (Get_Kind (Current_Decl) + in Iir_Kinds_Implicit_Subprogram_Declaration); + end if; + + if not (Is_Decl_Implicit xor Is_Current_Decl_Implicit) + then + Error_Msg_Sem + ("redeclaration of " & Disp_Node (Current_Decl) & + " defined at " & Disp_Location (Current_Decl), + Decl); + return; + end if; + end; + else + -- GHDL: hide directly visible declaration declared in + -- an outer region. + null; + end if; + else + -- LRM 10.4 Use Clauses + -- 1. A potentially visible declaration is not made + -- directly visible if the place considered is within the + -- immediate scope of a homograph of the declaration. + + -- GHDL: hide the potentially visible declaration. + null; + end if; + Maybe_Save_And_Add_New_Interpretation; + + Hide_Homograph; + return; + end if; + end; + end if; + + -- The current interpretation and the new one aren't overloadable, ie + -- they are homograph (well almost). + + if Is_In_Current_Declarative_Region (Current_Inter) then + -- They are perhaps visible in the same declarative region. + if Is_Potentially_Visible (Current_Inter) then + if Potentially then + -- LRM93 10.4 2) / LRM08 12.4 c) Use clauses + -- Potentially visible declarations that have the same + -- designator are not made directly visible unless each of + -- them is either an enumeration literal specification or + -- the declaration of a subprogram. + if Decl = Get_Declaration (Current_Inter) then + -- The rule applies only for distinct declaration. + -- This handles 'use p.all; use P.all;'. + -- FIXME: this should have been handled at the start of + -- this subprogram. + raise Internal_Error; + return; + end if; + + -- LRM08 12.3 Visibility + -- Each of two declarations is said to be a homograph of the + -- other if and only if both declarations have the same + -- designator; and they denote different named entities, [...] + if Flags.Vhdl_Std >= Vhdl_08 then + if Strip_Non_Object_Alias (Decl) + = Strip_Non_Object_Alias (Current_Decl) + then + return; + end if; + end if; + + Save_Current_Interpretation; + Set_Interpretation (Ident, Conflict_Interpretation); + return; + else + -- LRM93 §10.4 item #1 + -- A potentially visible declaration is not made directly + -- visible if the place considered is within the immediate + -- scope of a homograph of the declaration. + -- GHDL: Discard the current potentially visible declaration, + -- only if it is not an entity declaration, since it is used + -- to find default binding. + if Get_Kind (Current_Decl) = Iir_Kind_Design_Unit + and then Get_Kind (Get_Library_Unit (Current_Decl)) + = Iir_Kind_Entity_Declaration + then + Save_Current_Interpretation; + end if; + Current_Inter := No_Name_Interpretation; + Add_New_Interpretation; + return; + end if; + else + -- There is already a declaration in the current scope. + if Potentially then + -- LRM93 §10.4 item #1 + -- Discard the new and potentially visible declaration. + -- However, add the type. + -- FIXME: Add_In_Visible_List (Ident, Decl); + return; + else + -- LRM93 11.2 + -- If two or more logical names having the same + -- identifier appear in library clauses in the same + -- context, the second and subsequent occurences of the + -- logical name have no effect. The same is true of + -- logical names appearing both in the context clause + -- of a primary unit and in the context clause of a + -- corresponding secondary unit. + -- GHDL: we apply this rule with VHDL-87, because of implicits + -- library clauses STD and WORK. + if Get_Kind (Decl) = Iir_Kind_Library_Declaration + and then + Get_Kind (Current_Decl) = Iir_Kind_Library_Declaration + then + return; + end if; + + -- None of the two declarations are potentially visible, ie + -- both are visible. + -- LRM §10.3: + -- Two declarations that occur immediately within the same + -- declarative region must not be homographs, + -- FIXME: unless one of them is the implicit declaration of a + -- predefined operation. + Error_Msg_Sem ("identifier '" & Name_Table.Image (Ident) + & "' already used for a declaration", + Decl); + Error_Msg_Sem + ("previous declaration: " & Disp_Node (Current_Decl), + Current_Decl); + return; + end if; + end if; + end if; + + -- Homograph, not in the same scope. + -- LRM §10.3: + -- A declaration is said to be hidden within (part of) an inner + -- declarative region if the inner region contains an homograph + -- of this declaration; the outer declaration is the hidden + -- within the immediate scope of the inner homograph. + Save_Current_Interpretation; + Current_Inter := No_Name_Interpretation; -- Hid. + Add_New_Interpretation; + end Add_Name; + + procedure Add_Name (Decl: Iir) is + begin + Add_Name (Decl, Get_Identifier (Decl), False); + end Add_Name; + + procedure Replace_Name (Id: Name_Id; Old : Iir; Decl: Iir) + is + Inter : Name_Interpretation_Type; + begin + Inter := Get_Interpretation (Id); + loop + exit when Get_Declaration (Inter) = Old; + Inter := Get_Next_Interpretation (Inter); + if not Valid_Interpretation (Inter) then + raise Internal_Error; + end if; + end loop; + Interpretations.Table (Inter).Decl := Decl; + if Get_Next_Interpretation (Inter) /= No_Name_Interpretation then + raise Internal_Error; + end if; + end Replace_Name; + + procedure Name_Visible (Decl : Iir) is + begin + if Get_Visible_Flag (Decl) then + -- A name can be made visible only once. + raise Internal_Error; + end if; + Set_Visible_Flag (Decl, True); + end Name_Visible; + + procedure Iterator_Decl (Decl : Iir; Arg : Arg_Type) + is + begin + case Get_Kind (Decl) is + when Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Enumeration_Literal -- By use clause + | Iir_Kind_Constant_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement => + Handle_Decl (Decl, Arg); + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + if not Is_Second_Subprogram_Specification (Decl) then + Handle_Decl (Decl, Arg); + end if; + when Iir_Kind_Type_Declaration => + declare + Def : Iir; + List : Iir_List; + El : Iir; + begin + Def := Get_Type_Definition (Decl); + + -- Handle incomplete type declaration. + if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then + return; + end if; + + Handle_Decl (Decl, Arg); + + if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then + List := Get_Enumeration_Literal_List (Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Handle_Decl (El, Arg); + end loop; + end if; + end; + when Iir_Kind_Anonymous_Type_Declaration => + Handle_Decl (Decl, Arg); + + declare + Def : Iir; + El : Iir; + begin + Def := Get_Type_Definition (Decl); + + if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then + El := Get_Unit_Chain (Def); + while El /= Null_Iir loop + Handle_Decl (El, Arg); + El := Get_Chain (El); + end loop; + end if; + end; + when Iir_Kind_Use_Clause => + Handle_Decl (Decl, Arg); + when Iir_Kind_Library_Clause => + Handle_Decl (Decl, Arg); +-- El := Get_Library_Declaration (Decl); +-- if El /= Null_Iir then +-- -- May be empty. +-- Handle_Decl (El, Arg); +-- end if; + + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + null; + + when Iir_Kind_Attribute_Specification + | Iir_Kind_Configuration_Specification + | Iir_Kind_Disconnection_Specification => + null; + when Iir_Kinds_Signal_Attribute => + null; + + when Iir_Kind_Protected_Type_Body => + -- FIXME: allowed only in debugger (if the current scope is + -- within a package body) ? + null; + + when others => + Error_Kind ("iterator_decl", Decl); + end case; + end Iterator_Decl; + + -- Make POTENTIALLY (or not) visible DECL. + procedure Add_Name_Decl (Decl : Iir; Potentially : Boolean) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + if not Potentially then + Add_Use_Clause (Decl); + end if; + when Iir_Kind_Library_Clause => + Add_Name (Get_Library_Declaration (Decl), + Get_Identifier (Decl), Potentially); + when Iir_Kind_Anonymous_Type_Declaration => + null; + when others => + Add_Name (Decl, Get_Identifier (Decl), Potentially); + end case; + end Add_Name_Decl; + + procedure Add_Declaration is + new Iterator_Decl (Arg_Type => Boolean, Handle_Decl => Add_Name_Decl); + + procedure Iterator_Decl_List (Decl_List : Iir_List; Arg : Arg_Type) + is + Decl: Iir; + begin + if Decl_List = Null_Iir_List then + return; + end if; + for I in Natural loop + Decl := Get_Nth_Element (Decl_List, I); + exit when Decl = Null_Iir; + Handle_Decl (Decl, Arg); + end loop; + end Iterator_Decl_List; + + procedure Iterator_Decl_Chain (Chain_First : Iir; Arg : Arg_Type) + is + Decl: Iir; + begin + Decl := Chain_First; + while Decl /= Null_Iir loop + Handle_Decl (Decl, Arg); + Decl := Get_Chain (Decl); + end loop; + end Iterator_Decl_Chain; + + procedure Add_Declarations_1 is new Iterator_Decl_Chain + (Arg_Type => Boolean, Handle_Decl => Add_Declaration); + + procedure Add_Declarations (Chain : Iir; Potentially : Boolean := False) + renames Add_Declarations_1; + + procedure Add_Declarations_List is new Iterator_Decl_List + (Arg_Type => Boolean, Handle_Decl => Add_Declaration); + + procedure Add_Declarations_From_Interface_Chain (Chain : Iir) + is + El: Iir; + begin + El := Chain; + while El /= Null_Iir loop + Add_Name (El, Get_Identifier (El), False); + El := Get_Chain (El); + end loop; + end Add_Declarations_From_Interface_Chain; + + procedure Add_Declarations_Of_Concurrent_Statement (Parent : Iir) + is + El: Iir; + Label: Name_Id; + begin + El := Get_Concurrent_Statement_Chain (Parent); + while El /= Null_Iir loop + Label := Get_Label (El); + if Label /= Null_Identifier then + Add_Name (El, Get_Identifier (El), False); + end if; + El := Get_Chain (El); + end loop; + end Add_Declarations_Of_Concurrent_Statement; + + procedure Add_Context_Clauses (Unit : Iir_Design_Unit) is + begin + Add_Declarations (Get_Context_Items (Unit), False); + end Add_Context_Clauses; + + -- Add declarations from an entity into the current declarative region. + -- This is needed when an architecture is analysed. + procedure Add_Entity_Declarations (Entity : Iir_Entity_Declaration) + is + begin + Add_Declarations_From_Interface_Chain (Get_Generic_Chain (Entity)); + Add_Declarations_From_Interface_Chain (Get_Port_Chain (Entity)); + Add_Declarations (Get_Declaration_Chain (Entity), False); + Add_Declarations_Of_Concurrent_Statement (Entity); + end Add_Entity_Declarations; + + -- Add declarations from a package into the current declarative region. + -- (for a use clause or when a package body is analyzed) + procedure Add_Package_Declarations + (Decl: Iir_Package_Declaration; Potentially : Boolean) + is + Header : constant Iir := Get_Package_Header (Decl); + begin + -- LRM08 12.1 Declarative region + -- d) A package declaration together with the corresponding body + -- + -- GHDL: the formal generic declarations are considered to be in the + -- same declarative region as the package declarations (and therefore + -- in the same scope), even if they don't occur immediately within a + -- package declaration. + if Header /= Null_Iir then + Add_Declarations (Get_Generic_Chain (Header), Potentially); + end if; + + Add_Declarations (Get_Declaration_Chain (Decl), Potentially); + end Add_Package_Declarations; + + procedure Add_Package_Instantiation_Declarations + (Decl: Iir; Potentially : Boolean) is + begin + -- LRM08 4.9 Package instantiation declarations + -- The package instantiation declaration is equivalent to declaration of + -- a generic-mapped package, consisting of a package declaration [...] + Add_Declarations (Get_Generic_Chain (Decl), Potentially); + Add_Declarations (Get_Declaration_Chain (Decl), Potentially); + end Add_Package_Instantiation_Declarations; + + -- Add declarations from a package into the current declarative region. + -- This is needed when a package body is analysed. + procedure Add_Package_Declarations (Decl: Iir_Package_Declaration) is + begin + Add_Package_Declarations (Decl, False); + end Add_Package_Declarations; + + procedure Add_Component_Declarations (Component: Iir_Component_Declaration) + is + begin + Add_Declarations_From_Interface_Chain (Get_Generic_Chain (Component)); + Add_Declarations_From_Interface_Chain (Get_Port_Chain (Component)); + end Add_Component_Declarations; + + procedure Add_Protected_Type_Declarations + (Decl : Iir_Protected_Type_Declaration) is + begin + Add_Declarations (Get_Declaration_Chain (Decl), False); + end Add_Protected_Type_Declarations; + + procedure Extend_Scope_Of_Block_Declarations (Decl : Iir) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Architecture_Body => + Add_Context_Clauses (Get_Design_Unit (Decl)); + when Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + -- FIXME: formal, iterator ? + null; + when others => + Error_Kind ("extend_scope_of_block_declarations", Decl); + end case; + Add_Declarations (Get_Declaration_Chain (Decl), False); + Add_Declarations_Of_Concurrent_Statement (Decl); + end Extend_Scope_Of_Block_Declarations; + + procedure Use_Library_All (Library : Iir_Library_Declaration) + is + Design_File : Iir_Design_File; + Design_Unit : Iir_Design_Unit; + Library_Unit : Iir; + begin + Design_File := Get_Design_File_Chain (Library); + while Design_File /= Null_Iir loop + Design_Unit := Get_First_Design_Unit (Design_File); + while Design_Unit /= Null_Iir loop + Library_Unit := Get_Library_Unit (Design_Unit); + if Get_Kind (Library_Unit) /= Iir_Kind_Package_Body then + Add_Name (Design_Unit, Get_Identifier (Design_Unit), True); + end if; + Design_Unit := Get_Chain (Design_Unit); + end loop; + Design_File := Get_Chain (Design_File); + end loop; + end Use_Library_All; + + procedure Use_Selected_Name (Name : Iir) is + begin + case Get_Kind (Name) is + when Iir_Kind_Overload_List => + Add_Declarations_List (Get_Overload_List (Name), True); + when Iir_Kind_Error => + null; + when others => + Add_Declaration (Name, True); + end case; + end Use_Selected_Name; + + procedure Use_All_Names (Name: Iir) is + begin + case Get_Kind (Name) is + when Iir_Kind_Library_Declaration => + Use_Library_All (Name); + when Iir_Kind_Package_Declaration => + Add_Package_Declarations (Name, True); + when Iir_Kind_Package_Instantiation_Declaration => + Add_Package_Instantiation_Declarations (Name, True); + when Iir_Kind_Interface_Package_Declaration => + -- LRM08 6.5.5 Interface package declarations + -- Within an entity declaration, an architecture body, a + -- component declaration, or an uninstantiated subprogram or + -- package declaration that declares a given interface package, + -- the name of the given interface package denotes an undefined + -- instance of the uninstantiated package. + Add_Package_Instantiation_Declarations (Name, True); + when Iir_Kind_Error => + null; + when others => + raise Internal_Error; + end case; + end Use_All_Names; + + procedure Add_Use_Clause (Clause : Iir_Use_Clause) + is + Name : Iir; + Cl : Iir_Use_Clause; + begin + Cl := Clause; + loop + Name := Get_Selected_Name (Cl); + if Get_Kind (Name) = Iir_Kind_Selected_By_All_Name then + Use_All_Names (Get_Named_Entity (Get_Prefix (Name))); + else + Use_Selected_Name (Get_Named_Entity (Name)); + end if; + Cl := Get_Use_Clause_Chain (Cl); + exit when Cl = Null_Iir; + end loop; + end Add_Use_Clause; + + -- Debugging + procedure Disp_Detailed_Interpretations (Ident : Name_Id) + is + use Ada.Text_IO; + use Name_Table; + + Inter: Name_Interpretation_Type; + Decl : Iir; + begin + Put (Name_Table.Image (Ident)); + Put_Line (":"); + + Inter := Get_Interpretation (Ident); + while Valid_Interpretation (Inter) loop + Put (Name_Interpretation_Type'Image (Inter)); + if Is_Potentially_Visible (Inter) then + Put (" (use)"); + end if; + Put (": "); + Decl := Get_Declaration (Inter); + Put (Iir_Kind'Image (Get_Kind (Decl))); + Put_Line (", loc: " & Get_Location_Str (Get_Location (Decl))); + if Get_Kind (Decl) in Iir_Kinds_Subprogram_Declaration then + Put_Line (" " & Disp_Subprg (Decl)); + end if; + Inter := Get_Next_Interpretation (Inter); + end loop; + end Disp_Detailed_Interpretations; + + procedure Disp_All_Interpretations + (Interpretation: Name_Interpretation_Type) + is + use Ada.Text_IO; + Inter: Name_Interpretation_Type; + begin + Inter := Interpretation; + while Valid_Interpretation (Inter) loop + Put (Name_Interpretation_Type'Image (Inter)); + Put ('.'); + Put (Iir_Kind'Image (Get_Kind (Get_Declaration (Inter)))); + Inter := Get_Next_Interpretation (Inter); + end loop; + New_Line; + end Disp_All_Interpretations; + + procedure Disp_All_Names + is + use Ada.Text_IO; + Inter: Name_Interpretation_Type; + begin + for I in 0 .. Name_Table.Last_Name_Id loop + Inter := Get_Interpretation (I); + if Valid_Interpretation (Inter) then + Put (Name_Table.Image (I)); + Put (Name_Id'Image (I)); + Put (':'); + Disp_All_Interpretations (Inter); + end if; + end loop; + Put_Line ("interprations.last = " + & Name_Interpretation_Type'Image (Interpretations.Last)); + Put_Line ("current_scope_start =" + & Name_Interpretation_Type'Image (Current_Scope_Start)); + end Disp_All_Names; + + procedure Disp_Scopes + is + use Ada.Text_IO; + begin + for I in reverse Scopes.First .. Scopes.Last loop + declare + S : Scope_Cell renames Scopes.Table (I); + begin + case S.Kind is + when Save_Cell => + Put ("save_cell: '"); + Put (Name_Table.Image (S.Id)); + Put ("', old inter:"); + when Hide_Cell => + Put ("hide_cell: to be inserted after "); + when Region_Start => + Put ("region_start at"); + when Barrier_Start => + Put ("barrier_start at"); + when Barrier_End => + Put ("barrier_end at"); + end case; + Put_Line (Name_Interpretation_Type'Image (S.Inter)); + end; + end loop; + end Disp_Scopes; +end Sem_Scopes; diff --git a/src/vhdl/sem_scopes.ads b/src/vhdl/sem_scopes.ads new file mode 100644 index 000000000..76faaf191 --- /dev/null +++ b/src/vhdl/sem_scopes.ads @@ -0,0 +1,217 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; +with Types; use Types; + +package Sem_Scopes is + + -- The purpose of SEM_NAME package is to handle association between + -- identifiers and declarations. + -- Roughly speacking, it implements ch10 of LRM: scope and visibility. + -- + -- Basic elements are: declarations and declarative region. + -- Declaration should be understood in the large meaning: any textual + -- construction declaring an identifier, which can be a label. + -- A declarative region contains declarations and possibly other + -- declarative regions. + -- + -- Rules are scope, visibility and overloading. + -- + + -- Create and close a declarative region. + -- By closing a declarative region, all declarations made in this region + -- are discarded. + procedure Open_Declarative_Region; + procedure Close_Declarative_Region; + + -- Add meaning DECL for its identifier to the current declarative region. + procedure Add_Name (Decl: Iir); + pragma Inline (Add_Name); + + -- Add meaning DECL to the identifier IDENT. + -- POTENTIALLY is true if the identifier comes from a use clause. + procedure Add_Name (Decl: Iir; Ident : Name_Id; Potentially: Boolean); + + -- Set the visible_flag of DECL to true. + procedure Name_Visible (Decl : Iir); + + -- Replace the interpretation OLD of ID by DECL. + -- ID must have a uniq interpretation OLD (ie, it must not be overloaded). + -- The interpretation must have been done in the current scope. + -- + -- This procedure is used when the meaning of a name is changed due to its + -- analysis, eg: when a concurrent_procedure_call_statement becomes + -- a component_instantiation_statement. + procedure Replace_Name (Id: Name_Id; Old : Iir; Decl: Iir); + + -- Interpretation is a simply linked list of what an identifier means. + -- In LRM08 12.3 Visibility, the sentence is 'the declaration defines a + -- possible meaning of this occurrence'. + -- FIXME: replace Interpretation by Meaning. + type Name_Interpretation_Type is private; + + -- Return true if INTER is a valid interpretation, ie has a corresponding + -- declaration. There are only two invalids interpretations, which + -- are declared just below as constants. + function Valid_Interpretation (Inter : Name_Interpretation_Type) + return Boolean; + pragma Inline (Valid_Interpretation); + + -- This pseudo interpretation marks the end of the interpretation chain, + -- and means there is no (more) interpretations for the name. + -- Unless you need to discriminate between an absence of declaration and + -- a conflict between potential declarations, you should use the + -- VALID_INTERPRETATION function. + No_Name_Interpretation : constant Name_Interpretation_Type; + + -- This pseudo interpretation means the name has only conflicting potential + -- declarations, and also terminates the chain of interpretations. + -- Unless you need to discriminate between an absence of declaration and + -- a conflict between potential declarations, you should use the + -- VALID_INTERPRETATION function. + Conflict_Interpretation : constant Name_Interpretation_Type; + + -- Get the first interpretation of identifier ID. + function Get_Interpretation (Id: Name_Id) return Name_Interpretation_Type; + pragma Inline (Get_Interpretation); + + -- Get the next interpretation from an interpretation. + function Get_Next_Interpretation (Ni: Name_Interpretation_Type) + return Name_Interpretation_Type; + pragma Inline (Get_Next_Interpretation); + + -- Get a declaration associated with an interpretation. + function Get_Declaration (Ni: Name_Interpretation_Type) return Iir; + pragma Inline (Get_Declaration); + + -- Same as Get_Declaration, but get the name of non-object alias. + -- (ie, can never returns an object alias). + function Get_Non_Alias_Declaration (Ni: Name_Interpretation_Type) + return Iir; + + -- Get the previous interpretation of identifier ID, ie the interpretation + -- for ID before the current interpretation of ID. + function Get_Under_Interpretation (Id : Name_Id) + return Name_Interpretation_Type; + + -- Return TRUE if INTER was made directly visible via a use clause. + function Is_Potentially_Visible (Inter: Name_Interpretation_Type) + return Boolean; + pragma Inline (Is_Potentially_Visible); + + -- Return TRUE if INTER was made direclty visible in the current + -- declarative region. Note this is different from being declared in the + -- current declarative region because of use clauses. + function Is_In_Current_Declarative_Region (Inter: Name_Interpretation_Type) + return Boolean; + pragma Inline (Is_In_Current_Declarative_Region); + + -- Push and pop all interpretations. + -- This can be used to suspend name interpretation, in case of recursive + -- semantics. + -- After a push, all names have no_name_interpretation. + -- Pop restore the previous state. + procedure Pop_Interpretations; + procedure Push_Interpretations; + + -- Execute a use clause on NAME. + -- Make potentially directly visible declarations of NAMES. + --procedure Use_Selected_Name (Name : Iir); + procedure Use_All_Names (Name: Iir); + + -- Achieves visibility of the selected_name of use clause CLAUSE. + procedure Add_Use_Clause (Clause : Iir_Use_Clause); + + -- Add declarations for a context clause into the current declarative + -- regions. + procedure Add_Context_Clauses (Unit : Iir_Design_Unit); + + -- Add declarations from an entity into the current declarative region. + -- This is needed when an architecture is analysed. + procedure Add_Entity_Declarations (Entity : Iir_Entity_Declaration); + + -- Add declarations from a package into the current declarative region. + -- This is needed when a package body is analysed. + -- FIXME: this must be done as if the declarative region was extended. + procedure Add_Package_Declarations (Decl: Iir_Package_Declaration); + + -- Add interfaces declaration of a component into the current declarative + -- region. + procedure Add_Component_Declarations + (Component : Iir_Component_Declaration); + + -- Add declarations from a protected type declaration into the current + -- declaration region (which is expected to be the region of the protected + -- type body). + procedure Add_Protected_Type_Declarations + (Decl : Iir_Protected_Type_Declaration); + + -- Add declarations of interface chain CHAIN into the current + -- declarative region. + procedure Add_Declarations_From_Interface_Chain (Chain : Iir); + + -- Add all declarations for concurrent statements declared in PARENT. + procedure Add_Declarations_Of_Concurrent_Statement (Parent : Iir); + + -- Add declarations of a declaration chain CHAIN. + procedure Add_Declarations (Chain : Iir; Potentially : Boolean := False); + + -- Scope extension area contains declarations from another declarative + -- region. These area are abstract and only used to be able to add + -- and remove declarations. + procedure Open_Scope_Extension; + procedure Close_Scope_Extension; + + -- Add any declarations that include the end of the declarative part of + -- the given block BLOCK. This follow rules of LRM93 10.2 + -- FIXME: BLOCK must be an architecture at first, then blocks declared + -- inside this architecture, then a block declared inside this block... + -- This procedure must be called after an Open_Scope_Extension and + -- declarations added can be removed with Close_Scope_Extension. + procedure Extend_Scope_Of_Block_Declarations (Decl : Iir); + + -- Call HANDLE_DECL for each declaration found in DECL. + -- This will generally call HANDLE_DECL with DECL. + -- For types, HANDLE_DECL is first called with the type declaration, then + -- with implicit functions, with element literals for enumeration type, + -- and units for physical type. + generic + type Arg_Type is private; + with procedure Handle_Decl (Decl : Iir; Arg : Arg_Type); + procedure Iterator_Decl (Decl : Iir; Arg : Arg_Type); + + -- Call HANDLE_DECL for each declaration found in DECL_LIST. + -- Generally, HANDLE_DECL must be an ITERATOR_DECL; this is not + -- automatically done, since the user might be interested in using the + -- ITERATOR_DECL. + generic + type Arg_Type is private; + with procedure Handle_Decl (Decl : Iir; Arg : Arg_Type); + procedure Iterator_Decl_List (Decl_List : Iir_List; Arg : Arg_Type); + + generic + type Arg_Type is private; + with procedure Handle_Decl (Decl : Iir; Arg : Arg_Type); + procedure Iterator_Decl_Chain (Chain_First : Iir; Arg : Arg_Type); + +private + type Name_Interpretation_Type is new Int32 range 0 .. (2 ** 30) - 1; + No_Name_Interpretation : constant Name_Interpretation_Type := 0; + Conflict_Interpretation : constant Name_Interpretation_Type := 1; + First_Valid_Interpretation : constant Name_Interpretation_Type := 2; +end Sem_Scopes; diff --git a/src/vhdl/sem_specs.adb b/src/vhdl/sem_specs.adb new file mode 100644 index 000000000..ca821b27e --- /dev/null +++ b/src/vhdl/sem_specs.adb @@ -0,0 +1,1731 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Iirs_Utils; use Iirs_Utils; +with Sem_Expr; use Sem_Expr; +with Sem_Names; use Sem_Names; +with Evaluation; use Evaluation; +with Std_Package; use Std_Package; +with Errorout; use Errorout; +with Sem; use Sem; +with Sem_Scopes; use Sem_Scopes; +with Sem_Assocs; use Sem_Assocs; +with Libraries; +with Iir_Chains; use Iir_Chains; +with Flags; use Flags; +with Name_Table; +with Std_Names; +with Sem_Decls; +with Xrefs; use Xrefs; +with Back_End; + +package body Sem_Specs is + function Get_Entity_Class_Kind (Decl : Iir) return Tokens.Token_Type + is + use Tokens; + begin + case Get_Kind (Decl) is + when Iir_Kind_Entity_Declaration => + return Tok_Entity; + when Iir_Kind_Architecture_Body => + return Tok_Architecture; + when Iir_Kind_Configuration_Declaration => + return Tok_Configuration; + when Iir_Kind_Package_Declaration => + return Tok_Package; + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + return Tok_Procedure; + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration => + return Tok_Function; + when Iir_Kind_Type_Declaration => + return Tok_Type; + when Iir_Kind_Subtype_Declaration => + return Tok_Subtype; + when Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration => + return Tok_Constant; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration => + return Tok_Signal; + when Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration => + return Tok_Variable; + when Iir_Kind_Component_Declaration => + return Tok_Component; + when Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_If_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Wait_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_Case_Statement + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Null_Statement => + return Tok_Label; + when Iir_Kind_Enumeration_Literal => + return Tok_Literal; + when Iir_Kind_Unit_Declaration => + return Tok_Units; + when Iir_Kind_Group_Declaration => + return Tok_Group; + when Iir_Kind_File_Declaration + | Iir_Kind_Interface_File_Declaration => + return Tok_File; + when Iir_Kind_Attribute_Declaration => + -- Even if an attribute can't have a attribute... + -- Because an attribute declaration can appear in a declaration + -- region. + return Tok_Attribute; + when others => + Error_Kind ("get_entity_class_kind", Decl); + end case; + return Tok_Invalid; + end Get_Entity_Class_Kind; + + -- Decorate DECL with attribute ATTR. + -- If CHECK_CLASS is true, class of DECL must be class of ATTR, otherwise + -- returns silently. + -- If CHECK_DEFINED is true, DECL must not have been decorated, otherwise + -- returns silently. + procedure Attribute_A_Decl + (Decl : Iir; + Attr : Iir_Attribute_Specification; + Check_Class : Boolean; + Check_Defined : Boolean) + is + use Tokens; + El : Iir_Attribute_Value; + + -- Attribute declaration corresponding to ATTR. + -- Due to possible error, it is not required to be an attribute decl, + -- it may be a simple name. + Attr_Decl : Iir; + begin + -- LRM93 5.1 + -- It is an error if the class of those names is not the same as that + -- denoted by the entity class. + if Get_Entity_Class_Kind (Decl) /= Get_Entity_Class (Attr) then + if Check_Class then + Error_Msg_Sem (Disp_Node (Decl) & " is not of class '" + & Tokens.Image (Get_Entity_Class (Attr)) & ''', + Attr); + if Get_Kind (Decl) = Iir_Kind_Subtype_Declaration + and then Get_Entity_Class (Attr) = Tok_Type + and then Get_Type (Decl) /= Null_Iir + and then Get_Base_Type (Get_Type (Decl)) /= Null_Iir + and then Get_Kind + (Get_Type_Declarator (Get_Base_Type (Get_Type (Decl)))) + = Iir_Kind_Anonymous_Type_Declaration + then + -- The type declaration declares an anonymous type + -- and a named subtype. + Error_Msg_Sem + ("'" & Image_Identifier (Decl) + & "' declares both an anonymous type and a named subtype", + Decl); + end if; + end if; + return; + end if; + + -- LRM93 §5.1 + -- An attribute specification for an attribute of a design unit + -- (ie an entity declaration, an architecture, a configuration, or a + -- package) must appear immediately within the declarative part of + -- that design unit. + case Get_Entity_Class (Attr) is + when Tok_Entity + | Tok_Architecture + | Tok_Configuration + | Tok_Package => + if Get_Design_Unit (Decl) /= Get_Current_Design_Unit then + Error_Msg_Sem (Disp_Node (Attr) & " must appear immediatly " + & "within " & Disp_Node (Decl), Attr); + return; + end if; + when others => + null; + end case; + + Attr_Decl := Get_Named_Entity (Get_Attribute_Designator (Attr)); + + -- LRM93 5.1 + -- It is an error if a given attribute is associated more than once with + -- a given named entity. + -- LRM 5.1 + -- Similarly, it is an error if two different attributes with the + -- same simple name (wether predefined or user-defined) are both + -- associated with a given named entity. + El := Get_Attribute_Value_Chain (Decl); + while El /= Null_Iir loop + declare + El_Attr : constant Iir_Attribute_Declaration := + Get_Named_Entity (Get_Attribute_Designator + (Get_Attribute_Specification (El))); + begin + if El_Attr = Attr_Decl then + if Get_Attribute_Specification (El) = Attr then + -- Was already specified with the same attribute value. + -- This is possible only in one case: + -- + -- signal S1 : real; + -- alias S1_too : real is S1; + -- attribute ATTR : T1; + -- attribute ATTR of ALL : signal is '1'; + return; + end if; + if Check_Defined then + Error_Msg_Sem + (Disp_Node (Decl) & " has already " & Disp_Node (Attr), + Attr); + Error_Msg_Sem ("previous attribute specification at " + & Disp_Location (El), Attr); + end if; + return; + elsif Get_Identifier (El_Attr) = Get_Identifier (Attr_Decl) then + Error_Msg_Sem + (Disp_Node (Decl) & " is already decorated with an " + & Disp_Node (El_Attr), Attr); + Error_Msg_Sem + ("(previous attribute specification was here)", El); + return; + end if; + end; + El := Get_Chain (El); + end loop; + + El := Create_Iir (Iir_Kind_Attribute_Value); + Location_Copy (El, Attr); + Set_Name_Staticness (El, None); + Set_Attribute_Specification (El, Attr); + -- FIXME: create an expr_error node? + declare + Expr : Iir; + begin + Expr := Get_Expression (Attr); + if Expr = Error_Mark then + Set_Expr_Staticness (El, Locally); + else + Set_Expr_Staticness (El, Get_Expr_Staticness (Expr)); + end if; + end; + Set_Designated_Entity (El, Decl); + Set_Type (El, Get_Type (Attr_Decl)); + Set_Base_Name (El, El); + Set_Chain (El, Get_Attribute_Value_Chain (Decl)); + Set_Attribute_Value_Chain (Decl, El); + Set_Spec_Chain (El, Get_Attribute_Value_Spec_Chain (Attr)); + Set_Attribute_Value_Spec_Chain (Attr, El); + + if (Flags.Vhdl_Std >= Vhdl_93c + and then Attr_Decl = Foreign_Attribute) + or else + (Flags.Vhdl_Std <= Vhdl_93c + and then Get_Identifier (Attr_Decl) = Std_Names.Name_Foreign) + then + -- LRM93 12.4 + -- The 'FOREIGN attribute may be associated only with + -- architectures or with subprograms. + case Get_Entity_Class (Attr) is + when Tok_Architecture => + null; + + when Tok_Function + | Tok_Procedure => + -- LRM93 12.4 + -- In the latter case, the attribute specification must + -- appear in the declarative part in which the subprogram + -- is declared. + -- GHDL: huh, this is the case for any attributes. + null; + + when others => + Error_Msg_Sem + ("'FOREIGN allowed only for architectures and subprograms", + Attr); + return; + end case; + + Set_Foreign_Flag (Decl, True); + + declare + use Back_End; + begin + if Sem_Foreign /= null then + Sem_Foreign.all (Decl); + end if; + end; + end if; + end Attribute_A_Decl; + + -- IS_DESIGNATORS if true if the entity name list is a list of designators. + -- Return TRUE if an entity was attributed. + function Sem_Named_Entities + (Scope : Iir; + Name : Iir; + Attr : Iir_Attribute_Specification; + Is_Designators : Boolean; + Check_Defined : Boolean) + return Boolean + is + Res : Boolean; + + -- If declaration DECL matches then named entity ENT, apply attribute + -- specification and returns TRUE. Otherwise, return FALSE. + -- Note: ENT and DECL are different for aliases. + function Sem_Named_Entity1 (Ent : Iir; Decl : Iir) return Boolean + is + Ent_Id : constant Name_Id := Get_Identifier (Ent); + begin + if (Name = Null_Iir or else Ent_Id = Get_Identifier (Name)) + and then Ent_Id /= Null_Identifier + then + if Is_Designators then + Xref_Ref (Name, Ent); + end if; + if Get_Visible_Flag (Ent) = False then + Error_Msg_Sem + (Disp_Node (Ent) & " is not yet visible", Attr); + else + Attribute_A_Decl (Decl, Attr, Is_Designators, Check_Defined); + return True; + end if; + end if; + return False; + end Sem_Named_Entity1; + + procedure Sem_Named_Entity (Ent : Iir) is + begin + case Get_Kind (Ent) is + when Iir_Kinds_Library_Unit_Declaration + | Iir_Kinds_Concurrent_Statement + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kinds_Sequential_Statement + | Iir_Kinds_Non_Alias_Object_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + Res := Res or Sem_Named_Entity1 (Ent, Ent); + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if not Is_Second_Subprogram_Specification (Ent) then + Res := Res or Sem_Named_Entity1 (Ent, Ent); + end if; + when Iir_Kind_Object_Alias_Declaration => + -- LRM93 5.1 + -- An entity designator that denotes an alias of an object is + -- required to denote the entire object, and not a subelement + -- or slice thereof. + declare + Decl : constant Iir := Get_Name (Ent); + Base : constant Iir := Get_Object_Prefix (Decl, False); + Applied : Boolean; + begin + Applied := Sem_Named_Entity1 (Ent, Base); + -- FIXME: check the alias denotes a local entity... + if Applied + and then Base /= Strip_Denoting_Name (Decl) + then + Error_Msg_Sem + (Disp_Node (Ent) & " does not denote the entire object", + Attr); + end if; + Res := Res or Applied; + end; + when Iir_Kind_Non_Object_Alias_Declaration => + Res := Res + or Sem_Named_Entity1 (Ent, Get_Named_Entity (Get_Name (Ent))); + when Iir_Kind_Attribute_Declaration + | Iir_Kind_Attribute_Specification + | Iir_Kind_Configuration_Specification + | Iir_Kind_Use_Clause => + null; + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + null; + when Iir_Kind_Anonymous_Type_Declaration => + null; + when others => + Error_Kind ("sem_named_entity", Ent); + end case; + end Sem_Named_Entity; + + procedure Sem_Named_Entity_Chain (Chain_First : Iir) + is + El : Iir; + Def : Iir; + begin + El := Chain_First; + while El /= Null_Iir loop + exit when El = Attr; + Sem_Named_Entity (El); + case Get_Kind (El) is + when Iir_Kind_Type_Declaration => + Def := Get_Type_Definition (El); + if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then + declare + List : Iir_List; + El1 : Iir; + begin + List := Get_Enumeration_Literal_List (Def); + for I in Natural loop + El1 := Get_Nth_Element (List, I); + exit when El1 = Null_Iir; + Sem_Named_Entity (El1); + end loop; + end; + end if; + when Iir_Kind_Anonymous_Type_Declaration => + Def := Get_Type_Definition (El); + if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then + declare + El1 : Iir; + begin + El1 := Get_Unit_Chain (Def); + while El1 /= Null_Iir loop + Sem_Named_Entity (El1); + El1 := Get_Chain (El1); + end loop; + end; + end if; + when Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement => + Sem_Named_Entity_Chain (Get_Sequential_Statement_Chain (El)); + when Iir_Kind_If_Statement => + declare + Clause : Iir; + begin + Clause := El; + while Clause /= Null_Iir loop + Sem_Named_Entity_Chain + (Get_Sequential_Statement_Chain (Clause)); + Clause := Get_Else_Clause (Clause); + end loop; + end; + when Iir_Kind_Case_Statement => + declare + El1 : Iir; + begin + El1 := Get_Case_Statement_Alternative_Chain (El); + while El1 /= Null_Iir loop + Sem_Named_Entity_Chain (Get_Associated_Chain (El1)); + El1 := Get_Chain (El1); + end loop; + end; + + when Iir_Kind_Generate_Statement => + -- INT-1991/issue 27 + -- Generate statements represent declarative region and + -- have implicit declarative parts. + -- Was: There is no declarative part in generate statement + -- for VHDL 87. + if False and then Flags.Vhdl_Std = Vhdl_87 then + Sem_Named_Entity_Chain + (Get_Concurrent_Statement_Chain (El)); + end if; + + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end Sem_Named_Entity_Chain; + begin + Res := False; + + -- LRM 5.1 Attribute specification + -- o If a list of entity designators is supplied, then the + -- attribute specification applies to the named entities denoted + -- by those designators. + -- + -- o If the reserved word OTHERS is supplied, then the attribute + -- specification applies to named entities of the specified class + -- that are declared in the immediately enclosing declarative + -- part [...] + -- + -- o If the reserved word ALL is supplied, then the attribute + -- specification applies to all named entities of the specified + -- class that are declared in the immediatly enclosing + -- declarative part. + + -- NOTE: therefore, ALL/OTHERS do not apply to named entities declared + -- beyond the immediate declarative part, such as design unit or + -- interfaces. + if Is_Designators then + -- LRM 5.1 Attribute specification + -- An attribute specification for an attribute of a design unit + -- (i.e. an entity declaration, an architecture, a configuration + -- or a package) must appear immediatly within the declarative part + -- of that design unit. + case Get_Kind (Scope) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Package_Declaration => + Sem_Named_Entity (Scope); + when others => + null; + end case; + + -- LRM 5.1 Attribute specification + -- Similarly, an attribute specification for an attribute of an + -- interface object of a design unit, subprogram or block statement + -- must appear immediatly within the declarative part of that design + -- unit, subprogram, or block statement. + case Get_Kind (Scope) is + when Iir_Kind_Entity_Declaration => + Sem_Named_Entity_Chain (Get_Generic_Chain (Scope)); + Sem_Named_Entity_Chain (Get_Port_Chain (Scope)); + when Iir_Kind_Block_Statement => + declare + Header : constant Iir := Get_Block_Header (Scope); + begin + if Header /= Null_Iir then + Sem_Named_Entity_Chain (Get_Generic_Chain (Header)); + Sem_Named_Entity_Chain (Get_Port_Chain (Header)); + end if; + end; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + declare + Spec : Iir; + begin + Spec := Get_Subprogram_Specification (Scope); + Sem_Named_Entity_Chain + (Get_Interface_Declaration_Chain (Spec)); + end; + when others => + null; + end case; + end if; + + case Get_Kind (Scope) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Generate_Statement => + Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); + Sem_Named_Entity_Chain (Get_Concurrent_Statement_Chain (Scope)); + when Iir_Kind_Block_Statement => + declare + Guard : constant Iir := Get_Guard_Decl (Scope); + begin + if Guard /= Null_Iir then + Sem_Named_Entity (Guard); + end if; + end; + Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); + Sem_Named_Entity_Chain (Get_Concurrent_Statement_Chain (Scope)); + when Iir_Kind_Configuration_Declaration => + null; + when Iir_Kind_Package_Declaration => + Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); + when Iir_Kinds_Process_Statement => + Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); + Sem_Named_Entity_Chain (Get_Sequential_Statement_Chain (Scope)); + when Iir_Kind_Package_Body => + Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); + Sem_Named_Entity_Chain (Get_Sequential_Statement_Chain (Scope)); + when others => + Error_Kind ("sem_named_entities", Scope); + end case; + return Res; + end Sem_Named_Entities; + + procedure Sem_Signature_Entity_Designator + (Sig : Iir_Signature; Attr : Iir_Attribute_Specification) + is + Prefix : Iir; + Inter : Name_Interpretation_Type; + List : Iir_List; + Name : Iir; + begin + List := Create_Iir_List; + + -- Sem_Name cannot be used here (at least not directly) because only + -- the declarations of the current scope are considered. + Prefix := Get_Signature_Prefix (Sig); + Inter := Get_Interpretation (Get_Identifier (Prefix)); + while Valid_Interpretation (Inter) loop + exit when not Is_In_Current_Declarative_Region (Inter); + if not Is_Potentially_Visible (Inter) then + Name := Get_Declaration (Inter); + -- LRM 5.1 Attribute Specification + -- The entity tag of an entity designator containing a signature + -- must denote the name of one or more subprograms or enumeration + -- literals. + case Get_Kind (Name) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Enumeration_Literal => + Append_Element (List, Name); + when others => + Error_Msg_Sem + ("entity tag must denote a subprogram or a literal", Sig); + end case; + end if; + Inter := Get_Next_Interpretation (Inter); + end loop; + + Name := Sem_Decls.Sem_Signature (Create_Overload_List (List), Sig); + if Name = Null_Iir then + return; + end if; + + Set_Named_Entity (Prefix, Name); + Prefix := Finish_Sem_Name (Prefix); + Set_Signature_Prefix (Sig, Prefix); + + Attribute_A_Decl (Name, Attr, True, True); + end Sem_Signature_Entity_Designator; + + procedure Sem_Attribute_Specification + (Spec : Iir_Attribute_Specification; + Scope : Iir) + is + use Tokens; + + Name : Iir; + Attr : Iir_Attribute_Declaration; + List : Iir_List; + Expr : Iir; + Res : Boolean; + begin + -- LRM93 5.1 + -- The attribute designator must denote an attribute. + Name := Sem_Denoting_Name (Get_Attribute_Designator (Spec)); + Set_Attribute_Designator (Spec, Name); + + Attr := Get_Named_Entity (Name); + if Get_Kind (Attr) /= Iir_Kind_Attribute_Declaration then + Error_Class_Match (Name, "attribute"); + return; + end if; + + -- LRM 5.1 + -- The type of the expression in the attribute specification must be + -- the same as (or implicitly convertible to) the type mark in the + -- corresponding attribute declaration. + Expr := Sem_Expression (Get_Expression (Spec), Get_Type (Attr)); + if Expr /= Null_Iir then + Check_Read (Expr); + Set_Expression (Spec, Eval_Expr_If_Static (Expr)); + + -- LRM 5.1 + -- If the entity name list denotes an entity declaration, + -- architecture body or configuration declaration, then the + -- expression is required to be locally static. + -- GHDL: test based on the entity_class. + case Get_Entity_Class (Spec) is + when Tok_Entity + | Tok_Architecture + | Tok_Configuration => + if Get_Expr_Staticness (Expr) /= Locally then + Error_Msg_Sem + ("attribute expression for " + & Image (Get_Entity_Class (Spec)) + & " must be locally static", Spec); + end if; + when others => + null; + end case; + else + Set_Expression (Spec, Error_Mark); + end if; + + -- LRM 5.1 + -- The entity name list identifies those named entities, both + -- implicitly and explicitly defined, that inherit the attribute, as + -- defined below: + List := Get_Entity_Name_List (Spec); + if List = Iir_List_All then + -- o If the reserved word ALL is supplied, then the attribute + -- specification applies to all named entities of the specified + -- class that are declared in the immediatly enclosing + -- declarative part. + Res := Sem_Named_Entities (Scope, Null_Iir, Spec, False, True); + if Res = False and then Flags.Warn_Specs then + Warning_Msg_Sem + ("attribute specification apply to no named entity", Spec); + end if; + elsif List = Iir_List_Others then + -- o If the reserved word OTHERS is supplied, then the attribute + -- specification applies to named entities of the specified class + -- that are declared in the immediately enclosing declarative + -- part, provided that each such entity is not explicitly named + -- in the entity name list of a previous attribute specification + -- for the given attribute. + Res := Sem_Named_Entities (Scope, Null_Iir, Spec, False, False); + if Res = False and then Flags.Warn_Specs then + Warning_Msg_Sem + ("attribute specification apply to no named entity", Spec); + end if; + else + -- o If a list of entity designators is supplied, then the + -- attribute specification applies to the named entities denoted + -- by those designators. + declare + El : Iir; + begin + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if Get_Kind (El) = Iir_Kind_Signature then + Sem_Signature_Entity_Designator (El, Spec); + else + -- LRM 5.1 + -- It is an error if the class of those names is not the + -- same as that denoted by entity class. + if not Sem_Named_Entities (Scope, El, Spec, True, True) then + Error_Msg_Sem + ("no named entities '" & Image_Identifier (El) + & "' in declarative part", El); + end if; + end if; + end loop; + end; + end if; + end Sem_Attribute_Specification; + + procedure Check_Post_Attribute_Specification + (Attr_Spec_Chain : Iir; Decl : Iir) + is + use Tokens; + + Has_Error : Boolean; + Spec : Iir; + Decl_Class : Token_Type; + Decl_Class2 : Token_Type; + Ent_Class : Token_Type; + begin + -- Some declaration items can never be attributed. + Decl_Class2 := Tok_Eof; + case Get_Kind (Decl) is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Use_Clause + | Iir_Kind_Attribute_Declaration + | Iir_Kinds_Signal_Attribute + | Iir_Kind_Disconnection_Specification => + return; + when Iir_Kind_Anonymous_Type_Declaration => + -- A physical type definition declares units. + if Get_Kind (Get_Type_Definition (Decl)) + = Iir_Kind_Physical_Type_Definition + then + Decl_Class := Tok_Units; + else + return; + end if; + when Iir_Kind_Attribute_Specification => + Decl_Class := Get_Entity_Class (Decl); + when Iir_Kind_Type_Declaration => + Decl_Class := Tok_Type; + -- An enumeration type declares literals. + if Get_Kind (Get_Type_Definition (Decl)) + = Iir_Kind_Enumeration_Type_Definition + then + Decl_Class2 := Tok_Literal; + end if; + when Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Object_Alias_Declaration => + Decl_Class := Get_Entity_Class_Kind (Get_Name (Decl)); + -- NOTE: for non-object alias that declares an enumeration type + -- or a physical type, no need to set decl_class2, since + -- all implicit aliases are checked. + when others => + Decl_Class := Get_Entity_Class_Kind (Decl); + end case; + + Spec := Attr_Spec_Chain; + -- Skip itself (newly added, therefore first of the chain). + if Spec = Decl then + Spec := Get_Attribute_Specification_Chain (Spec); + end if; + while Spec /= Null_Iir loop + pragma Assert (Get_Entity_Name_List (Spec) in Iir_Lists_All_Others); + Ent_Class := Get_Entity_Class (Spec); + if Ent_Class = Decl_Class or Ent_Class = Decl_Class2 then + Has_Error := False; + + if Get_Kind (Decl) = Iir_Kind_Attribute_Specification then + -- LRM 5.1 Attribute specifications + -- An attribute specification with the entity name list OTHERS + -- or ALL for a given entity class that appears in a + -- declarative part must be the last such specification for the + -- given attribute for the given entity class in that + -- declarative part. + if Get_Identifier (Get_Attribute_Designator (Decl)) + = Get_Identifier (Get_Attribute_Designator (Spec)) + then + Error_Msg_Sem + ("no attribute specification may follow an " + & "all/others spec", Decl); + Has_Error := True; + end if; + else + -- LRM 5.1 Attribute specifications + -- It is an error if a named entity in the specificied entity + -- class is declared in a given declarative part following such + -- an attribute specification. + Error_Msg_Sem + ("no named entity may follow an all/others attribute " + & "specification", Decl); + Has_Error := True; + end if; + if Has_Error then + Error_Msg_Sem + ("(previous all/others specification for the given " + &"entity class)", Spec); + end if; + end if; + Spec := Get_Attribute_Specification_Chain (Spec); + end loop; + end Check_Post_Attribute_Specification; + + -- Compare ATYPE and TYPE_MARK. + -- ATYPE is a type definition, which can be anonymous. + -- TYPE_MARK is a subtype definition, established from a type mark. + -- Therefore, it is the name of a type or a subtype. + -- Return TRUE iff the type mark of ATYPE is TYPE_MARK. + function Is_Same_Type_Mark (Atype : Iir; Type_Mark : Iir) + return Boolean is + begin + if Get_Kind (Atype) in Iir_Kinds_Subtype_Definition + and then Is_Anonymous_Type_Definition (Atype) + then + -- FIXME: to be removed; used to catch uninitialized type_mark. + if Get_Subtype_Type_Mark (Atype) = Null_Iir then + raise Internal_Error; + end if; + return Get_Type (Get_Subtype_Type_Mark (Atype)) = Type_Mark; + else + return Atype = Type_Mark; + end if; + end Is_Same_Type_Mark; + + procedure Sem_Disconnection_Specification + (Dis : Iir_Disconnection_Specification) + is + Type_Mark : Iir; + Atype : Iir; + Time_Expr : Iir; + List : Iir_List; + El : Iir; + Sig : Iir; + Prefix : Iir; + begin + -- Sem type mark. + Type_Mark := Get_Type_Mark (Dis); + Type_Mark := Sem_Type_Mark (Type_Mark); + Set_Type_Mark (Dis, Type_Mark); + Atype := Get_Type (Type_Mark); + + -- LRM93 5.3 + -- The time expression in a disconnection specification must be static + -- and must evaluate to a non-negative value. + Time_Expr := Sem_Expression + (Get_Expression (Dis), Time_Subtype_Definition); + if Time_Expr /= Null_Iir then + Check_Read (Time_Expr); + Set_Expression (Dis, Time_Expr); + if Get_Expr_Staticness (Time_Expr) < Globally then + Error_Msg_Sem ("time expression must be static", Time_Expr); + end if; + end if; + + List := Get_Signal_List (Dis); + if List = Iir_List_All or List = Iir_List_Others then + -- FIXME: checks todo + null; + else + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + + Sem_Name (El); + El := Finish_Sem_Name (El); + Replace_Nth_Element (List, I, El); + + Sig := Get_Named_Entity (El); + Sig := Name_To_Object (Sig); + if Sig /= Null_Iir then + Set_Type (El, Get_Type (Sig)); + Prefix := Get_Object_Prefix (Sig); + -- LRM93 5.3 + -- Each signal name in a signal list in a guarded signal + -- specification must be a locally static name that + -- denotes a guarded signal. + case Get_Kind (Prefix) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + null; + when others => + Error_Msg_Sem ("object must be a signal", El); + return; + end case; + if Get_Name_Staticness (Sig) /= Locally then + Error_Msg_Sem ("signal name must be locally static", El); + end if; + if Get_Signal_Kind (Prefix) = Iir_No_Signal_Kind then + Error_Msg_Sem ("signal must be a guarded signal", El); + end if; + Set_Has_Disconnect_Flag (Prefix, True); + + -- LRM93 5.3 + -- If the guarded signal is a declared signal or a slice of + -- thereof, the type mark must be the same as the type mark + -- indicated in the guarded signal specification. + -- If the guarded signal is an array element of an explicitly + -- declared signal, the type mark must be the same as the + -- element subtype indication in the (explicit or implicit) + -- array type declaration that declares the base type of the + -- explicitly declared signal. + -- If the guarded signal is a record element of an explicitly + -- declared signal, then the type mark must be the same as + -- the type mark in the element subtype definition of the + -- record type declaration that declares the type of the + -- explicitly declared signal. + -- FIXME: to be checked: the expression type (as set by + -- sem_expression) may be a base type instead of a type mark. + if not Is_Same_Type_Mark (Get_Type (Sig), Atype) then + Error_Msg_Sem ("type mark and signal type mismatch", El); + end if; + + -- LRM93 5.3 + -- Each signal must be declared in the declarative part + -- enclosing the disconnection specification. + -- FIXME: todo. + elsif Get_Designated_Entity (El) /= Error_Mark then + Error_Msg_Sem ("name must designate a signal", El); + end if; + end loop; + end if; + end Sem_Disconnection_Specification; + + -- Semantize entity aspect ASPECT and return the entity declaration. + -- Return NULL_IIR if not found. + function Sem_Entity_Aspect (Aspect : Iir) return Iir is + begin + case Get_Kind (Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + declare + Entity_Name : Iir; + Entity : Iir; + Arch_Name : Iir; + Arch_Unit : Iir; + begin + Entity_Name := Sem_Denoting_Name (Get_Entity_Name (Aspect)); + Set_Entity_Name (Aspect, Entity_Name); + Entity := Get_Named_Entity (Entity_Name); + if Get_Kind (Entity) /= Iir_Kind_Entity_Declaration then + Error_Class_Match (Entity_Name, "entity"); + return Null_Iir; + end if; + -- Note: dependency is added by Sem_Denoting_Name. + + -- Check architecture. + Arch_Name := Get_Architecture (Aspect); + if Arch_Name /= Null_Iir then + Arch_Unit := Libraries.Find_Secondary_Unit + (Get_Design_Unit (Entity), Get_Identifier (Arch_Name)); + Set_Named_Entity (Arch_Name, Arch_Unit); + if Arch_Unit /= Null_Iir then + Xref_Ref (Arch_Name, Arch_Unit); + end if; + + -- FIXME: may emit a warning if the architecture does not + -- exist. + -- Note: the design needs the architecture. + Add_Dependence (Aspect); + end if; + return Entity; + end; + + when Iir_Kind_Entity_Aspect_Configuration => + declare + Conf_Name : Iir; + Conf : Iir; + begin + Conf_Name := + Sem_Denoting_Name (Get_Configuration_Name (Aspect)); + Set_Configuration_Name (Aspect, Conf_Name); + Conf := Get_Named_Entity (Conf_Name); + if Get_Kind (Conf) /= Iir_Kind_Configuration_Declaration then + Error_Class_Match (Conf, "configuration"); + return Null_Iir; + end if; + + return Get_Entity (Conf); + end; + + when Iir_Kind_Entity_Aspect_Open => + return Null_Iir; + + when others => + Error_Kind ("sem_entity_aspect", Aspect); + end case; + end Sem_Entity_Aspect; + + procedure Sem_Binding_Indication (Bind : Iir_Binding_Indication; + Comp : Iir_Component_Declaration; + Parent : Iir; + Primary_Entity_Aspect : Iir) + is + Entity_Aspect : Iir; + Entity : Iir_Entity_Declaration; + begin + if Bind = Null_Iir then + raise Internal_Error; + end if; + + Entity_Aspect := Get_Entity_Aspect (Bind); + if Entity_Aspect /= Null_Iir then + Entity := Sem_Entity_Aspect (Entity_Aspect); + + -- LRM93 5.2.1 Binding Indication + -- An incremental binding indication must not have an entity aspect. + if Primary_Entity_Aspect /= Null_Iir then + Error_Msg_Sem + ("entity aspect not allowed for incremental binding", Bind); + end if; + + -- Return now in case of error. + if Entity = Null_Iir then + return; + end if; + else + -- LRM93 5.2.1 + -- When a binding indication is used in an explicit configuration + -- specification, it is an error if the entity aspect is absent. + case Get_Kind (Parent) is + when Iir_Kind_Component_Configuration => + if Primary_Entity_Aspect = Null_Iir then + Entity := Null_Iir; + else + case Get_Kind (Primary_Entity_Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + Entity := Get_Entity (Primary_Entity_Aspect); + when others => + Error_Kind + ("sem_binding_indication", Primary_Entity_Aspect); + end case; + end if; + when Iir_Kind_Configuration_Specification => + Error_Msg_Sem + ("entity aspect required in a configuration specification", + Bind); + return; + when others => + raise Internal_Error; + end case; + end if; + if Entity = Null_Iir + or else Get_Kind (Entity) = Iir_Kind_Entity_Aspect_Open + then + -- LRM 5.2.1.1 Entity aspect + -- The third form of entity aspect is used to specify that the + -- indiciation of the design entity is to be defined. In this case, + -- the immediatly enclosing binding indication is said to not + -- imply any design entity. Furthermore, the immediatly enclosing + -- binding indication must not include a generic map aspect or a + -- port map aspect. + if Get_Generic_Map_Aspect_Chain (Bind) /= Null_Iir + or else Get_Port_Map_Aspect_Chain (Bind) /= Null_Iir + then + Error_Msg_Sem + ("map aspect not allowed for open entity aspect", Bind); + return; + end if; + else + Sem_Generic_Port_Association_Chain (Entity, Bind); + + -- LRM 5.2.1 Binding Indication + -- If the generic map aspect or port map aspect of a binding + -- indication is not present, then the default rules as described + -- in 5.2.2 apply. + if Get_Generic_Map_Aspect_Chain (Bind) = Null_Iir + and then Primary_Entity_Aspect = Null_Iir + then + Set_Default_Generic_Map_Aspect_Chain + (Bind, + Create_Default_Map_Aspect (Comp, Entity, Map_Generic, Parent)); + end if; + if Get_Port_Map_Aspect_Chain (Bind) = Null_Iir + and then Primary_Entity_Aspect = Null_Iir + then + Set_Default_Port_Map_Aspect_Chain + (Bind, + Create_Default_Map_Aspect (Comp, Entity, Map_Port, Parent)); + end if; + end if; + end Sem_Binding_Indication; + + -- Set configuration_specification or component_configuration SPEC to + -- component instantiation COMP. + procedure Apply_Configuration_Specification + (Comp : Iir_Component_Instantiation_Statement; + Spec : Iir; + Primary_Entity_Aspect : in out Iir) + is + Prev_Spec : Iir; + Prev_Conf : Iir; + + procedure Prev_Spec_Error is + begin + Error_Msg_Sem + (Disp_Node (Comp) + & " is alreay bound by a configuration specification", Spec); + Error_Msg_Sem + ("(previous is " & Disp_Node (Prev_Spec) & ")", Prev_Spec); + end Prev_Spec_Error; + + Prev_Binding : Iir_Binding_Indication; + Prev_Entity_Aspect : Iir; + begin + Prev_Spec := Get_Configuration_Specification (Comp); + if Prev_Spec /= Null_Iir then + case Get_Kind (Spec) is + when Iir_Kind_Configuration_Specification => + Prev_Spec_Error; + return; + when Iir_Kind_Component_Configuration => + if Flags.Vhdl_Std = Vhdl_87 then + Prev_Spec_Error; + Error_Msg_Sem + ("(incremental binding is not allowed in vhdl87)", Spec); + return; + end if; + -- Incremental binding. + Prev_Binding := Get_Binding_Indication (Prev_Spec); + if Prev_Binding /= Null_Iir then + Prev_Entity_Aspect := Get_Entity_Aspect (Prev_Binding); + if Primary_Entity_Aspect = Null_Iir then + Primary_Entity_Aspect := Prev_Entity_Aspect; + else + -- FIXME: checks to do ? + null; + end if; + end if; + when others => + Error_Kind ("apply_configuration_specification", Spec); + end case; + end if; + Prev_Conf := Get_Component_Configuration (Comp); + if Prev_Conf /= Null_Iir then + case Get_Kind (Spec) is + when Iir_Kind_Configuration_Specification => + -- How can this happen ? + raise Internal_Error; + when Iir_Kind_Component_Configuration => + Error_Msg_Sem + (Disp_Node (Comp) + & " is already bound by a component configuration", + Spec); + Error_Msg_Sem + ("(previous is " & Disp_Node (Prev_Conf) & ")", Prev_Conf); + return; + when others => + Error_Kind ("apply_configuration_specification(2)", Spec); + end case; + end if; + if Get_Kind (Spec) = Iir_Kind_Configuration_Specification then + Set_Configuration_Specification (Comp, Spec); + end if; + Set_Component_Configuration (Comp, Spec); + end Apply_Configuration_Specification; + + -- Semantize component_configuration or configuration_specification SPEC. + -- STMTS is the concurrent statement list related to SPEC. + procedure Sem_Component_Specification + (Parent_Stmts : Iir; Spec : Iir; Primary_Entity_Aspect : out Iir) + is + function Apply_Component_Specification + (Chain : Iir; Check_Applied : Boolean) + return Boolean + is + Comp : constant Iir := Get_Named_Entity (Get_Component_Name (Spec)); + El : Iir; + Res : Boolean; + begin + El := Get_Concurrent_Statement_Chain (Chain); + Res := False; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Instantiation_Statement => + if Is_Component_Instantiation (El) + and then + Get_Named_Entity (Get_Instantiated_Unit (El)) = Comp + and then + (not Check_Applied + or else Get_Component_Configuration (El) = Null_Iir) + then + Apply_Configuration_Specification + (El, Spec, Primary_Entity_Aspect); + Res := True; + end if; + when Iir_Kind_Generate_Statement => + if False and then Flags.Vhdl_Std = Vhdl_87 then + Res := Res + or Apply_Component_Specification (El, Check_Applied); + end if; + when others => + null; + end case; + El := Get_Chain (El); + end loop; + return Res; + end Apply_Component_Specification; + + List : Iir_List; + El : Iir; + Inter : Sem_Scopes.Name_Interpretation_Type; + Comp : Iir; + Comp_Name : Iir; + Inst : Iir; + Inst_Unit : Iir; + begin + Primary_Entity_Aspect := Null_Iir; + Comp_Name := Sem_Denoting_Name (Get_Component_Name (Spec)); + Set_Component_Name (Spec, Comp_Name); + Comp := Get_Named_Entity (Comp_Name); + if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then + Error_Class_Match (Comp_Name, "component"); + return; + end if; + + List := Get_Instantiation_List (Spec); + if List = Iir_List_All then + -- LRM93 5.2 + -- * If the reserved word ALL is supplied, then the configuration + -- specification applies to all instances of the specified + -- component declaration whose labels are (implicitly) declared + -- in the immediately enclosing declarative region part. + -- This rule applies only to those component instantiation + -- statements whose corresponding instantiated units name + -- component. + if not Apply_Component_Specification (Parent_Stmts, False) + and then Flags.Warn_Specs + then + Warning_Msg_Sem + ("component specification applies to no instance", Spec); + end if; + elsif List = Iir_List_Others then + -- LRM93 5.2 + -- * If the reserved word OTHERS is supplied, then the + -- configuration specification applies to instances of the + -- specified component declaration whoce labels are (implicitly) + -- declared in the immediatly enclosing declarative part, + -- provided that each such component instance is not explicitly + -- names in the instantiation list of a previous configuration + -- specification. + -- This rule applies only to those component instantiation + -- statements whose corresponding instantiated units name + -- components. + if not Apply_Component_Specification (Parent_Stmts, True) + and then Flags.Warn_Specs + then + Warning_Msg_Sem + ("component specification applies to no instance", Spec); + end if; + else + -- LRM93 5.2 + -- * If a list of instantiation labels is supplied, then the + -- configuration specification applies to the corresponding + -- component instances. + -- Such labels must be (implicitly) declared within the + -- immediatly enclosing declarative part. + -- It is an error if these component instances are not instances + -- of the component declaration named in the component + -- specification. + -- It is also an error if any of the labels denote a component + -- instantiation statement whose corresponding instantiated unit + -- does not name a component. + -- FIXME: error message are *really* cryptic. + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Inter := Sem_Scopes.Get_Interpretation (Get_Identifier (El)); + if not Valid_Interpretation (Inter) then + Error_Msg_Sem ("no component instantation with label '" + & Image_Identifier (El) & ''', El); + elsif not Is_In_Current_Declarative_Region (Inter) then + -- FIXME. + Error_Msg_Sem ("label not in block declarative part", El); + else + Inst := Get_Declaration (Inter); + if Get_Kind (Inst) /= Iir_Kind_Component_Instantiation_Statement + then + Error_Msg_Sem ("label does not denote an instantiation", El); + else + Inst_Unit := Get_Instantiated_Unit (Inst); + if Is_Entity_Instantiation (Inst) + or else (Get_Kind (Get_Named_Entity (Inst_Unit)) + /= Iir_Kind_Component_Declaration) + then + Error_Msg_Sem + ("specification does not apply to direct instantiation", + El); + elsif Get_Named_Entity (Inst_Unit) /= Comp then + Error_Msg_Sem ("component names mismatch", El); + else + Apply_Configuration_Specification + (Inst, Spec, Primary_Entity_Aspect); + Xref_Ref (El, Inst); + Set_Named_Entity (El, Inst); + end if; + end if; + end if; + end loop; + end if; + end Sem_Component_Specification; + + procedure Sem_Configuration_Specification + (Parent_Stmts : Iir; Conf : Iir_Configuration_Specification) + is + Primary_Entity_Aspect : Iir; + Component : Iir; + begin + Sem_Component_Specification (Parent_Stmts, Conf, Primary_Entity_Aspect); + Component := Get_Named_Entity (Get_Component_Name (Conf)); + + -- Return now in case of error. + if Get_Kind (Component) /= Iir_Kind_Component_Declaration then + return; + end if; + -- Extend scope of component interface declaration. + Sem_Scopes.Open_Scope_Extension; + Sem_Scopes.Add_Component_Declarations (Component); + Sem_Binding_Indication (Get_Binding_Indication (Conf), + Component, Conf, Primary_Entity_Aspect); + -- FIXME: check default port and generic association. + Sem_Scopes.Close_Scope_Extension; + end Sem_Configuration_Specification; + + function Sem_Create_Default_Binding_Indication + (Comp : Iir_Component_Declaration; + Entity_Unit : Iir_Design_Unit; + Parent : Iir; + Force : Boolean) + return Iir_Binding_Indication + is + Entity : Iir_Entity_Declaration; + Entity_Name : Iir; + Aspect : Iir; + Res : Iir; + Design_Unit : Iir_Design_Unit; + begin + -- LRM 5.2.2 + -- The default binding indication consists of a default entity aspect, + -- together with a default generic map aspect and a default port map + -- aspect, as appropriate. + + if Entity_Unit = Null_Iir then + if not Force then + return Null_Iir; + end if; + + -- LRM 5.2.2 + -- If no visible entity declaration has the same simple name as that + -- of the instantiated component, then the default entity aspect is + -- OPEN. + Aspect := Create_Iir (Iir_Kind_Entity_Aspect_Open); + Location_Copy (Aspect, Comp); + Res := Create_Iir (Iir_Kind_Binding_Indication); + Set_Entity_Aspect (Res, Aspect); + return Res; + else + -- LRM 5.2.2 + -- Otherwise, the default entity aspect is of the form: + -- ENTITY entity_name ( architecture_identifier) + -- where the entity name is the simple name of the instantiated + -- component and the architecture identifier is the same as the + -- simple name of the most recently analyzed architecture body + -- associated with the entity declaration. + -- + -- If this rule is applied either to a binding indication contained + -- within a configuration specification or to a component + -- configuration that does not contain an explicit inner block + -- configuration, then the architecture identifier is determined + -- during elaboration of the design hierarchy containing the binding + -- indication. + -- + -- Likewise, if a component instantiation statement contains an + -- instantiated unit containing the reserved word ENTITY, but does + -- not contain an explicitly specified architecture identifier, this + -- rule is applied during the elaboration of the design hierarchy + -- containing a component instantiation statement. + -- + -- In all other cases, this rule is applied during analysis of the + -- binding indication. + -- + -- It is an error if there is no architecture body associated with + -- the entity declaration denoted by an entity name that is the + -- simple name of the instantiated component. + null; + end if; + + Design_Unit := Libraries.Load_Primary_Unit + (Get_Library (Get_Design_File (Entity_Unit)), + Get_Identifier (Get_Library_Unit (Entity_Unit)), + Parent); + if Design_Unit = Null_Iir then + -- Found an entity which is not in the library. + raise Internal_Error; + end if; + + Entity := Get_Library_Unit (Design_Unit); + + Res := Create_Iir (Iir_Kind_Binding_Indication); + Aspect := Create_Iir (Iir_Kind_Entity_Aspect_Entity); + Location_Copy (Aspect, Parent); + + Entity_Name := Create_Iir (Iir_Kind_Simple_Name); + Location_Copy (Entity_Name, Parent); + Set_Named_Entity (Entity_Name, Entity); + + Set_Entity_Name (Aspect, Entity_Name); + Set_Entity_Aspect (Res, Aspect); + + -- LRM 5.2.2 + -- The default binding indication includes a default generic map aspect + -- if the design entity implied by the entity aspect contains formal + -- generics. + Set_Generic_Map_Aspect_Chain + (Res, Create_Default_Map_Aspect (Comp, Entity, Map_Generic, Parent)); + + -- LRM 5.2.2 + -- The default binding indication includes a default port map aspect + -- if the design entity implied by the entity aspect contains formal + -- ports. + Set_Port_Map_Aspect_Chain + (Res, Create_Default_Map_Aspect (Comp, Entity, Map_Port, Parent)); + + return Res; + end Sem_Create_Default_Binding_Indication; + + -- LRM 5.2.2 + -- The default binding indication includes a default generic map aspect + -- if the design entity implied by the entity aspect contains formal + -- generics. + -- + -- The default generic map aspect associates each local generic in + -- the corresponding component instantiation (if any) with a formal + -- of the same simple name. + -- It is an error if such a formal does not exist, or if its mode and + -- type are not appropriate for such an association. + -- Any remaining unassociated formals are associated with the actual + -- designator OPEN. + + -- LRM 5.2.2 + -- The default binding indication includes a default port map aspect + -- if the design entity implied by the entity aspect contains formal + -- ports. + -- + -- The default port map aspect associates each local port in the + -- corresponding component instantiation (if any) with a formal of + -- the same simple name. + -- It is an error if such a formal does not exist, or if its mode + -- and type are not appropriate for such an association. + -- Any remaining unassociated formals are associated with the actual + -- designator OPEN. + function Create_Default_Map_Aspect + (Comp : Iir; Entity : Iir; Kind : Map_Kind_Type; Parent : Iir) + return Iir + is + Res, Last : Iir; + Comp_El, Ent_El : Iir; + Assoc : Iir; + Found : Natural; + Comp_Chain : Iir; + Ent_Chain : Iir; + Error : Boolean; + begin + case Kind is + when Map_Generic => + Ent_Chain := Get_Generic_Chain (Entity); + Comp_Chain := Get_Generic_Chain (Comp); + when Map_Port => + Ent_Chain := Get_Port_Chain (Entity); + Comp_Chain := Get_Port_Chain (Comp); + end case; + + -- If no formal, then there is no association list. + if Ent_Chain = Null_Iir then + return Null_Iir; + end if; + + -- No error found yet. + Error := False; + + Sub_Chain_Init (Res, Last); + Found := 0; + Ent_El := Ent_Chain; + while Ent_El /= Null_Iir loop + -- Find the component generic/port with the same name. + Comp_El := Find_Name_In_Chain (Comp_Chain, Get_Identifier (Ent_El)); + if Comp_El = Null_Iir then + Assoc := Create_Iir (Iir_Kind_Association_Element_Open); + Location_Copy (Assoc, Parent); + else + if not Are_Nodes_Compatible (Comp_El, Ent_El) then + if not Error then + Error_Msg_Sem + ("for default port binding of " & Disp_Node (Parent) + & ":", Parent); + end if; + Error_Msg_Sem + ("type of " & Disp_Node (Comp_El) + & " declarared at " & Disp_Location (Comp_El), Parent); + Error_Msg_Sem + ("not compatible with type of " & Disp_Node (Ent_El) + & " declarared at " & Disp_Location (Ent_El), Parent); + Error := True; + elsif Kind = Map_Port + and then not Check_Port_Association_Restriction + (Ent_El, Comp_El, Null_Iir) + then + if not Error then + Error_Msg_Sem + ("for default port binding of " & Disp_Node (Parent) + & ":", Parent); + end if; + Error_Msg_Sem + ("cannot associate " + & Get_Mode_Name (Get_Mode (Ent_El)) + & " " & Disp_Node (Ent_El) + & " declarared at " & Disp_Location (Ent_El), Parent); + Error_Msg_Sem + ("with actual port of mode " + & Get_Mode_Name (Get_Mode (Comp_El)) + & " declared at " & Disp_Location (Comp_El), Parent); + Error := True; + end if; + Assoc := Create_Iir (Iir_Kind_Association_Element_By_Expression); + Location_Copy (Assoc, Parent); + Set_Actual (Assoc, Comp_El); + Found := Found + 1; + end if; + Set_Whole_Association_Flag (Assoc, True); + Set_Formal (Assoc, Ent_El); + if Kind = Map_Port + and then not Error + and then Comp_El /= Null_Iir + then + Set_Collapse_Signal_Flag + (Assoc, Can_Collapse_Signals (Assoc, Ent_El)); + end if; + Sub_Chain_Append (Res, Last, Assoc); + Ent_El := Get_Chain (Ent_El); + end loop; + if Iir_Chains.Get_Chain_Length (Comp_Chain) /= Found then + -- At least one component generic/port cannot be associated with + -- the entity one. + Error := True; + -- Disp unassociated interfaces. + Comp_El := Comp_Chain; + while Comp_El /= Null_Iir loop + Ent_El := Find_Name_In_Chain (Ent_Chain, Get_Identifier (Comp_El)); + if Ent_El = Null_Iir then + Error_Msg_Sem (Disp_Node (Comp_El) & " has no association in " + & Disp_Node (Entity), Parent); + end if; + Comp_El := Get_Chain (Comp_El); + end loop; + end if; + if Error then + return Null_Iir; + else + return Res; + end if; + end Create_Default_Map_Aspect; + + -- LRM93 §5.2.2 + function Get_Visible_Entity_Declaration (Comp: Iir_Component_Declaration) + return Iir_Design_Unit + is + function Is_Entity_Declaration (Decl : Iir) return Boolean is + begin + return Get_Kind (Decl) = Iir_Kind_Design_Unit and then + Get_Kind (Get_Library_Unit (Decl)) = Iir_Kind_Entity_Declaration; + end Is_Entity_Declaration; + + Inter : Name_Interpretation_Type; + Name : Name_Id; + Decl : Iir; + Target_Lib : Iir; + begin + Name := Get_Identifier (Comp); + Inter := Get_Interpretation (Name); + + if Valid_Interpretation (Inter) then + -- A visible entity declaration is either: + -- + -- a) An entity declaration that has the same simple name as that of + -- the instantiated component and that is directly visible + -- (see 10.3), + Decl := Get_Declaration (Inter); + if Is_Entity_Declaration (Decl) then + return Decl; + end if; + + -- b) An entity declaration that has the same simple name that of + -- the instantiated component and that would be directly + -- visible in the absence of a directly visible (see 10.3) + -- component declaration with the same simple name as that + -- of the entity declaration, or + if Get_Kind (Decl) = Iir_Kind_Component_Declaration then + Inter := Get_Under_Interpretation (Name); + if Valid_Interpretation (Inter) then + Decl := Get_Declaration (Inter); + if Is_Entity_Declaration (Decl) then + return Decl; + end if; + end if; + end if; + end if; + + -- VHDL02: + -- c) An entity declaration denoted by "L.C", where L is the target + -- library and C is the simple name of the instantiated component. + -- The target library is the library logical name of the library + -- containing the design unit in which the component C is + -- declared. + if Flags.Flag_Syn_Binding + or Flags.Vhdl_Std >= Vhdl_02 + or Flags.Vhdl_Std = Vhdl_93c + then + -- Find target library. + Target_Lib := Comp; + while Get_Kind (Target_Lib) /= Iir_Kind_Library_Declaration loop + Target_Lib := Get_Parent (Target_Lib); + end loop; + + Decl := Libraries.Find_Primary_Unit (Target_Lib, Name); + if Decl /= Null_Iir and then Is_Entity_Declaration (Decl) then + return Decl; + end if; + end if; + + -- --syn-binding + -- Search for any entity. + if Flags.Flag_Syn_Binding then + Decl := Libraries.Find_Entity_For_Component (Name); + if Decl /= Null_Iir then + return Decl; + end if; + end if; + + return Null_Iir; + end Get_Visible_Entity_Declaration; + + -- Explain why there is no default binding for COMP. + procedure Explain_No_Visible_Entity (Comp: Iir_Component_Declaration) + is + Inter : Name_Interpretation_Type; + Name : Name_Id; + Decl : Iir; + begin + Name := Get_Identifier (Comp); + Inter := Get_Interpretation (Name); + + if Valid_Interpretation (Inter) then + -- A visible entity declaration is either: + -- + -- a) An entity declaration that has the same simple name as that of + -- the instantiated component and that is directly visible + -- (see 10.3), + Decl := Get_Declaration (Inter); + Warning_Msg_Elab ("visible declaration for " & Name_Table.Image (Name) + & " is " & Disp_Node (Decl), Decl); + + -- b) An entity declaration that has the same simple name that of + -- the instantiated component and that would be directly + -- visible in the absence of a directly visible (see 10.3) + -- component declaration with the same simple name as that + -- of the entity declaration, or + if Get_Kind (Decl) = Iir_Kind_Component_Declaration then + Inter := Get_Under_Interpretation (Name); + if Valid_Interpretation (Inter) then + Decl := Get_Declaration (Inter); + Warning_Msg_Elab ("interpretation behind the component is " + & Disp_Node (Decl), Comp); + end if; + end if; + end if; + + -- VHDL02: + -- c) An entity declaration denoted by "L.C", where L is the target + -- library and C is the simple name of the instantiated component. + -- The target library is the library logical name of the library + -- containing the design unit in which the component C is + -- declared. + if Flags.Vhdl_Std >= Vhdl_02 + or else Flags.Vhdl_Std = Vhdl_93c + then + Decl := Comp; + while Get_Kind (Decl) /= Iir_Kind_Library_Declaration loop + Decl := Get_Parent (Decl); + end loop; + + Warning_Msg_Elab ("no entity """ & Name_Table.Image (Name) & """ in " + & Disp_Node (Decl), Comp); + end if; + end Explain_No_Visible_Entity; + + procedure Sem_Specification_Chain (Decls_Parent : Iir; Parent_Stmts: Iir) + is + Decl: Iir; + begin + Decl := Get_Declaration_Chain (Decls_Parent); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Configuration_Specification => + Sem_Configuration_Specification (Parent_Stmts, Decl); + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + end Sem_Specification_Chain; +end Sem_Specs; diff --git a/src/vhdl/sem_specs.ads b/src/vhdl/sem_specs.ads new file mode 100644 index 000000000..c27207b01 --- /dev/null +++ b/src/vhdl/sem_specs.ads @@ -0,0 +1,88 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; +with Tokens; + +package Sem_Specs is + function Get_Entity_Class_Kind (Decl : Iir) return Tokens.Token_Type; + + procedure Sem_Attribute_Specification + (Spec : Iir_Attribute_Specification; Scope : Iir); + + -- Check declarations following an ALL/OTHERS attribute specification. + -- ATTR_SPEC_CHAIN is the linked list of all attribute specifications whith + -- the entity name list ALL or OTHERS until the current declaration DECL. + -- So no specification in the chain must match the declaration. + procedure Check_Post_Attribute_Specification + (Attr_Spec_Chain : Iir; Decl : Iir); + + procedure Sem_Disconnection_Specification + (Dis : Iir_Disconnection_Specification); + + procedure Sem_Configuration_Specification + (Parent_Stmts : Iir; Conf : Iir_Configuration_Specification); + + -- Analyze binding indication BIND of configuration specification or + -- component configuration PARENT. + -- PRIMARY_ENTITY_ASPECT is not Null_Iir for an incremental binding. + procedure Sem_Binding_Indication (Bind : Iir_Binding_Indication; + Comp : Iir_Component_Declaration; + Parent : Iir; + Primary_Entity_Aspect : Iir); + + -- Semantize entity aspect ASPECT and return the entity declaration. + -- Return NULL_IIR if not found. + function Sem_Entity_Aspect (Aspect : Iir) return Iir; + + -- Semantize component_configuration or configuration_specification SPEC. + -- STMTS is the concurrent statement list related to SPEC. + procedure Sem_Component_Specification + (Parent_Stmts : Iir; Spec : Iir; Primary_Entity_Aspect : out Iir); + + -- Create a default binding indication for component COMP which will be + -- bound with entity ENTITY_UNIT. + -- If ENTITY_UNIT is NULL_IIR, the component is not bound. + -- If FORCE is True, a binding indication will be created even if the + -- component is not bound (this is an open binding indication). + -- PARENT is used to report error. + function Sem_Create_Default_Binding_Indication + (Comp : Iir_Component_Declaration; + Entity_Unit : Iir_Design_Unit; + Parent : Iir; + Force : Boolean) + return Iir_Binding_Indication; + + -- Create a default generic or port map aspect that associates all elements + -- of ENTITY (if any) to elements of COMP with the same name or to + -- an open association. + -- If KIND is GENERIC_MAP, apply this on generics, if KIND is PORT_MAP, + -- apply this on ports. + -- PARENT is used to report errors. + type Map_Kind_Type is (Map_Generic, Map_Port); + function Create_Default_Map_Aspect + (Comp : Iir; Entity : Iir; Kind : Map_Kind_Type; Parent : Iir) + return Iir; + + -- Explain why there is no default binding for COMP. + procedure Explain_No_Visible_Entity (Comp: Iir_Component_Declaration); + + function Get_Visible_Entity_Declaration (Comp: Iir_Component_Declaration) + return Iir_Design_Unit; + + procedure Sem_Specification_Chain (Decls_Parent : Iir; Parent_Stmts: Iir); +end Sem_Specs; diff --git a/src/vhdl/sem_stmts.adb b/src/vhdl/sem_stmts.adb new file mode 100644 index 000000000..b5912fbc6 --- /dev/null +++ b/src/vhdl/sem_stmts.adb @@ -0,0 +1,2007 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Errorout; use Errorout; +with Types; use Types; +with Flags; use Flags; +with Sem_Specs; use Sem_Specs; +with Std_Package; use Std_Package; +with Sem; use Sem; +with Sem_Decls; use Sem_Decls; +with Sem_Expr; use Sem_Expr; +with Sem_Names; use Sem_Names; +with Sem_Scopes; use Sem_Scopes; +with Sem_Types; +with Sem_Psl; +with Std_Names; +with Evaluation; use Evaluation; +with Iirs_Utils; use Iirs_Utils; +with Xrefs; use Xrefs; + +package body Sem_Stmts is + -- Process is the scope, this is also the process for which drivers can + -- be created. + -- Note: FIRST_STMT is the first statement, which can be get by: + -- get_sequential_statement_chain (usual) + -- get_associated_chain (for case statement). + procedure Sem_Sequential_Statements_Internal (First_Stmt : Iir); + + -- Access to the current subprogram or process. + Current_Subprogram: Iir := Null_Iir; + + function Get_Current_Subprogram return Iir is + begin + return Current_Subprogram; + end Get_Current_Subprogram; + + -- Access to the current concurrent statement. + -- Null_iir if no one. + Current_Concurrent_Statement : Iir := Null_Iir; + + function Get_Current_Concurrent_Statement return Iir is + begin + return Current_Concurrent_Statement; + end Get_Current_Concurrent_Statement; + + Current_Declarative_Region_With_Signals : + Implicit_Signal_Declaration_Type := (Null_Iir, Null_Iir); + + procedure Push_Signals_Declarative_Part + (Cell: out Implicit_Signal_Declaration_Type; Decls_Parent : Iir) is + begin + Cell := Current_Declarative_Region_With_Signals; + Current_Declarative_Region_With_Signals := (Decls_Parent, Null_Iir); + end Push_Signals_Declarative_Part; + + procedure Pop_Signals_Declarative_Part + (Cell: in Implicit_Signal_Declaration_Type) is + begin + Current_Declarative_Region_With_Signals := Cell; + end Pop_Signals_Declarative_Part; + + procedure Add_Declaration_For_Implicit_Signal (Sig : Iir) + is + Last : Iir renames + Current_Declarative_Region_With_Signals.Last_Decl; + begin + if Current_Declarative_Region_With_Signals.Decls_Parent = Null_Iir then + raise Internal_Error; + end if; + if Last = Null_Iir then + Last := Get_Declaration_Chain + (Current_Declarative_Region_With_Signals.Decls_Parent); + end if; + if Last = Null_Iir then + Set_Declaration_Chain + (Current_Declarative_Region_With_Signals.Decls_Parent, Sig); + else + while Get_Chain (Last) /= Null_Iir loop + Last := Get_Chain (Last); + end loop; + Set_Chain (Last, Sig); + end if; + Last := Sig; + end Add_Declaration_For_Implicit_Signal; + + -- LRM 8 Sequential statements. + -- All statements may be labeled. + -- Such labels are implicitly declared at the beginning of the declarative + -- part of the innermost enclosing process statement of subprogram body. + procedure Sem_Sequential_Labels (First_Stmt : Iir) + is + Stmt: Iir; + Label: Name_Id; + begin + Stmt := First_Stmt; + while Stmt /= Null_Iir loop + Label := Get_Label (Stmt); + if Label /= Null_Identifier then + Sem_Scopes.Add_Name (Stmt); + Name_Visible (Stmt); + Xref_Decl (Stmt); + end if; + + -- Some statements have sub-lists of statements. + case Get_Kind (Stmt) is + when Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement => + Sem_Sequential_Labels (Get_Sequential_Statement_Chain (Stmt)); + when Iir_Kind_If_Statement => + declare + Clause : Iir; + begin + Clause := Stmt; + while Clause /= Null_Iir loop + Sem_Sequential_Labels + (Get_Sequential_Statement_Chain (Clause)); + Clause := Get_Else_Clause (Clause); + end loop; + end; + when Iir_Kind_Case_Statement => + declare + El : Iir; + begin + El := Get_Case_Statement_Alternative_Chain (Stmt); + while El /= Null_Iir loop + Sem_Sequential_Labels (Get_Associated_Chain (El)); + El := Get_Chain (El); + end loop; + end; + when others => + null; + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Sem_Sequential_Labels; + + procedure Fill_Array_From_Aggregate_Associated + (Chain : Iir; Nbr : in out Natural; Arr : Iir_Array_Acc) + is + El : Iir; + Ass : Iir; + begin + El := Chain; + while El /= Null_Iir loop + Ass := Get_Associated_Expr (El); + if Get_Kind (Ass) = Iir_Kind_Aggregate then + Fill_Array_From_Aggregate_Associated + (Get_Association_Choices_Chain (Ass), Nbr, Arr); + else + if Arr /= null then + Arr (Nbr) := Ass; + end if; + Nbr := Nbr + 1; + end if; + El := Get_Chain (El); + end loop; + end Fill_Array_From_Aggregate_Associated; + + -- Return TRUE iff there is no common elements designed by N1 and N2. + -- N1 and N2 are static names. + -- FIXME: The current implementation is completly wrong; should check from + -- prefix to suffix. + function Is_Disjoint (N1, N2: Iir) return Boolean + is + List1, List2 : Iir_List; + El1, El2 : Iir; + begin + if N1 = N2 then + return False; + end if; + if Get_Kind (N1) = Iir_Kind_Indexed_Name + and then Get_Kind (N2) = Iir_Kind_Indexed_Name + then + if Is_Disjoint (Get_Prefix (N1), Get_Prefix (N2)) then + return True; + end if; + -- Check indexes. + List1 := Get_Index_List (N1); + List2 := Get_Index_List (N2); + for I in Natural loop + El1 := Get_Nth_Element (List1, I); + El2 := Get_Nth_Element (List2, I); + exit when El1 = Null_Iir; + El1 := Eval_Expr (El1); + Replace_Nth_Element (List1, I, El1); + El2 := Eval_Expr (El2); + Replace_Nth_Element (List2, I, El2); + -- EL are of discrete type. + if Get_Value (El1) /= Get_Value (El2) then + return True; + end if; + end loop; + return False; + elsif Get_Kind (N1) in Iir_Kinds_Denoting_Name + and then Get_Kind (N2) in Iir_Kinds_Denoting_Name + then + return Get_Named_Entity (N1) /= Get_Named_Entity (N2); + else + return True; + end if; + end Is_Disjoint; + + procedure Check_Uniq_Aggregate_Associated + (Aggr : Iir_Aggregate; Nbr : Natural) + is + Index : Natural; + Arr : Iir_Array_Acc; + Chain : Iir; + V_I, V_J : Iir; + begin + Chain := Get_Association_Choices_Chain (Aggr); + -- Count number of associated values, and create the array. + -- Already done: use nbr. + -- Fill_Array_From_Aggregate_Associated (List, Nbr, null); + Arr := new Iir_Array (0 .. Nbr - 1); + -- Fill the array. + Index := 0; + Fill_Array_From_Aggregate_Associated (Chain, Index, Arr); + if Index /= Nbr then + -- Should be the same. + raise Internal_Error; + end if; + -- Check each element is uniq. + for I in Arr.all'Range loop + V_I := Name_To_Object (Arr (I)); + if Get_Name_Staticness (V_I) = Locally then + for J in 0 .. I - 1 loop + V_J := Name_To_Object (Arr (J)); + if Get_Name_Staticness (V_J) = Locally + and then not Is_Disjoint (V_I, V_J) + then + Error_Msg_Sem ("target is assigned more than once", Arr (I)); + Error_Msg_Sem (" (previous assignment is here)", Arr (J)); + Free (Arr); + return; + end if; + end loop; + end if; + end loop; + Free (Arr); + return; + end Check_Uniq_Aggregate_Associated; + + -- Do checks for the target of an assignment. + procedure Check_Simple_Signal_Target + (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness); + -- STMT is used to localize the error (if any). + procedure Check_Simple_Variable_Target + (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness); + + -- Semantic associed with signal mode. + -- See §4.3.3 + type Boolean_Array_Of_Iir_Mode is array (Iir_Mode) of Boolean; + Iir_Mode_Readable : constant Boolean_Array_Of_Iir_Mode := + (Iir_Unknown_Mode => False, + Iir_In_Mode => True, + Iir_Out_Mode => False, + Iir_Inout_Mode => True, + Iir_Buffer_Mode => True, + Iir_Linkage_Mode => False); + Iir_Mode_Writable : constant Boolean_Array_Of_Iir_Mode := + (Iir_Unknown_Mode => False, + Iir_In_Mode => False, + Iir_Out_Mode => True, + Iir_Inout_Mode => True, + Iir_Buffer_Mode => True, + Iir_Linkage_Mode => False); + + procedure Check_Aggregate_Target + (Stmt : Iir; Target : Iir; Nbr : in out Natural) + is + Choice : Iir; + Ass : Iir; + begin + Choice := Get_Association_Choices_Chain (Target); + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Range => + -- LRM93 8.4 + -- It is an error if an element association in such an + -- aggregate contains an OTHERS choice or a choice that is + -- a discrete range. + Error_Msg_Sem ("discrete range choice not allowed for target", + Choice); + when Iir_Kind_Choice_By_Others => + -- LRM93 8.4 + -- It is an error if an element association in such an + -- aggregate contains an OTHERS choice or a choice that is + -- a discrete range. + Error_Msg_Sem ("others choice not allowed for target", Choice); + when Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Name + | Iir_Kind_Choice_By_None => + -- LRM93 9.4 + -- Such a target may not only contain locally static signal + -- names [...] + Ass := Get_Associated_Expr (Choice); + if Get_Kind (Ass) = Iir_Kind_Aggregate then + Check_Aggregate_Target (Stmt, Ass, Nbr); + else + if Get_Kind (Stmt) = Iir_Kind_Variable_Assignment_Statement + then + Check_Simple_Variable_Target (Stmt, Ass, Locally); + else + Check_Simple_Signal_Target (Stmt, Ass, Locally); + end if; + Nbr := Nbr + 1; + end if; + when others => + Error_Kind ("check_aggregate_target", Choice); + end case; + Choice := Get_Chain (Choice); + end loop; + end Check_Aggregate_Target; + + procedure Check_Simple_Signal_Target + (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness) + is + Target_Object : Iir; + Target_Prefix : Iir; + Guarded_Target : Tri_State_Type; + Targ_Obj_Kind : Iir_Kind; + begin + Target_Object := Name_To_Object (Target); + if Target_Object = Null_Iir then + Error_Msg_Sem ("target is not a signal name", Target); + return; + end if; + + Target_Prefix := Get_Object_Prefix (Target_Object); + Targ_Obj_Kind := Get_Kind (Target_Prefix); + case Targ_Obj_Kind is + when Iir_Kind_Interface_Signal_Declaration => + if not Iir_Mode_Writable (Get_Mode (Target_Prefix)) then + Error_Msg_Sem + (Disp_Node (Target_Prefix) & " can't be assigned", Target); + else + Sem_Add_Driver (Target_Object, Stmt); + end if; + when Iir_Kind_Signal_Declaration => + Sem_Add_Driver (Target_Object, Stmt); + when Iir_Kind_Guard_Signal_Declaration => + Error_Msg_Sem ("implicit GUARD signal cannot be assigned", Stmt); + return; + when others => + Error_Msg_Sem ("target (" & Disp_Node (Get_Base_Name (Target)) + & ") is not a signal", Stmt); + return; + end case; + if Get_Name_Staticness (Target_Object) < Staticness then + Error_Msg_Sem ("signal name must be static", Stmt); + end if; + + -- LRM93 2.1.1.2 + -- A formal signal parameter is a guarded signal if and only if + -- it is associated with an actual signal that is a guarded + -- signal. + -- GHDL: a formal signal interface of a subprogram has no static + -- kind. This is determined at run-time, according to the actual + -- associated with the formal. + -- GHDL: parent of target cannot be a function. + if Targ_Obj_Kind = Iir_Kind_Interface_Signal_Declaration + and then + Get_Kind (Get_Parent (Target_Prefix)) = Iir_Kind_Procedure_Declaration + then + Guarded_Target := Unknown; + else + if Get_Signal_Kind (Target_Prefix) /= Iir_No_Signal_Kind then + Guarded_Target := True; + else + Guarded_Target := False; + end if; + end if; + + case Get_Guarded_Target_State (Stmt) is + when Unknown => + Set_Guarded_Target_State (Stmt, Guarded_Target); + when True + | False => + if Get_Guarded_Target_State (Stmt) /= Guarded_Target then + -- LRM93 9.5 + -- It is an error if the target of a concurrent signal + -- assignment is neither a guarded target nor an + -- unguarded target. + Error_Msg_Sem ("guarded and unguarded target", Target); + end if; + end case; + end Check_Simple_Signal_Target; + + procedure Check_Simple_Variable_Target + (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness) + is + Target_Object : Iir; + Target_Prefix : Iir; + begin + Target_Object := Name_To_Object (Target); + if Target_Object = Null_Iir then + Error_Msg_Sem ("target is not a variable name", Stmt); + return; + end if; + Target_Prefix := Get_Object_Prefix (Target_Object); + case Get_Kind (Target_Prefix) is + when Iir_Kind_Interface_Variable_Declaration => + if not Iir_Mode_Writable (Get_Mode (Target_Prefix)) then + Error_Msg_Sem (Disp_Node (Target_Prefix) + & " cannot be written (bad mode)", Target); + return; + end if; + when Iir_Kind_Variable_Declaration => + null; + when Iir_Kind_Implicit_Dereference + | Iir_Kind_Dereference => + -- LRM 3.3 + -- An object designated by an access type is always an object of + -- class variable. + null; + when others => + Error_Msg_Sem (Disp_Node (Target_Prefix) + & " is not a variable to be assigned", Stmt); + return; + end case; + if Get_Name_Staticness (Target_Object) < Staticness then + Error_Msg_Sem + ("element of aggregate of variables must be a static name", Target); + end if; + end Check_Simple_Variable_Target; + + procedure Check_Target (Stmt : Iir; Target : Iir) + is + Nbr : Natural; + begin + if Get_Kind (Target) = Iir_Kind_Aggregate then + Nbr := 0; + Check_Aggregate_Target (Stmt, Target, Nbr); + Check_Uniq_Aggregate_Associated (Target, Nbr); + else + if Get_Kind (Stmt) = Iir_Kind_Variable_Assignment_Statement then + Check_Simple_Variable_Target (Stmt, Target, None); + else + Check_Simple_Signal_Target (Stmt, Target, None); + end if; + end if; + end Check_Target; + + -- Return FALSE in case of error. + function Sem_Signal_Assignment_Target_And_Option (Stmt: Iir; Sig_Type : Iir) + return Boolean + is + -- The target of the assignment. + Target: Iir; + -- The value that will be assigned. + Expr: Iir; + Ok : Boolean; + begin + Ok := True; + -- Find the signal. + Target := Get_Target (Stmt); + + if Sig_Type = Null_Iir + and then Get_Kind (Target) = Iir_Kind_Aggregate + then + -- Do not try to analyze an aggregate if its type is unknown. + -- A target cannot be a qualified type and its type should be + -- determine by the context (LRM93 7.3.2 Aggregates). + Ok := False; + else + -- Analyze the target + Target := Sem_Expression (Target, Sig_Type); + if Target /= Null_Iir then + Set_Target (Stmt, Target); + Check_Target (Stmt, Target); + Sem_Types.Set_Type_Has_Signal (Get_Type (Target)); + else + Ok := False; + end if; + end if; + + Expr := Get_Reject_Time_Expression (Stmt); + if Expr /= Null_Iir then + Expr := Sem_Expression (Expr, Time_Type_Definition); + if Expr /= Null_Iir then + Check_Read (Expr); + Set_Reject_Time_Expression (Stmt, Expr); + else + Ok := False; + end if; + end if; + return Ok; + end Sem_Signal_Assignment_Target_And_Option; + + -- Semantize a waveform_list WAVEFORM_LIST that is assigned via statement + -- ASSIGN_STMT to a subelement or a slice of a signal SIGNAL_DECL. + procedure Sem_Waveform_Chain + (Assign_Stmt: Iir; + Waveform_Chain : Iir_Waveform_Element; + Waveform_Type : in out Iir) + is + pragma Unreferenced (Assign_Stmt); + Expr: Iir; + We: Iir_Waveform_Element; + Time, Last_Time : Iir_Int64; + begin + if Waveform_Chain = Null_Iir then + -- Unaffected. + return; + end if; + + -- Start with -1 to allow after 0 ns. + Last_Time := -1; + We := Waveform_Chain; + while We /= Null_Iir loop + Expr := Get_We_Value (We); + if Get_Kind (Expr) = Iir_Kind_Null_Literal then + -- GHDL: allowed only if target is guarded; this is checked by + -- sem_check_waveform_list. + null; + else + if Get_Kind (Expr) = Iir_Kind_Aggregate + and then Waveform_Type = Null_Iir + then + Error_Msg_Sem + ("type of waveform is unknown, use qualified type", Expr); + else + Expr := Sem_Expression (Expr, Waveform_Type); + if Expr /= Null_Iir then + Check_Read (Expr); + Set_We_Value (We, Eval_Expr_If_Static (Expr)); + if Waveform_Type = Null_Iir then + Waveform_Type := Get_Type (Expr); + end if; + end if; + end if; + end if; + + if Get_Time (We) /= Null_Iir then + Expr := Sem_Expression (Get_Time (We), Time_Type_Definition); + if Expr /= Null_Iir then + Set_Time (We, Expr); + Check_Read (Expr); + + if Get_Expr_Staticness (Expr) = Locally + or else (Get_Kind (Expr) = Iir_Kind_Physical_Int_Literal + and then Flags.Flag_Time_64) + then + -- LRM 8.4 + -- It is an error if the time expression in a waveform + -- element evaluates to a negative value. + -- + -- LRM 8.4.1 + -- It is an error if the sequence of new transactions is not + -- in ascending order with repect to time. + -- GHDL: this must be checked at run-time, but this is also + -- checked now for static expressions. + if Get_Expr_Staticness (Expr) = Locally then + -- The expression is static, and therefore may be + -- evaluated. + Expr := Eval_Expr (Expr); + Set_Time (We, Expr); + Time := Get_Value (Expr); + else + -- The expression is a physical literal (common case). + -- Extract its value. + Time := Get_Physical_Value (Expr); + end if; + if Time < 0 then + Error_Msg_Sem + ("waveform time expression must be >= 0", Expr); + elsif Time <= Last_Time then + Error_Msg_Sem + ("time must be greather than previous transaction", + Expr); + else + Last_Time := Time; + end if; + end if; + end if; + else + if We /= Waveform_Chain then + -- Time expression must be in ascending order. + Error_Msg_Sem ("time expression required here", We); + end if; + + -- LRM93 12.6.4 + -- It is an error if the execution of any postponed process causes + -- a delta cycle to occur immediatly after the current simulation + -- cycle. + -- GHDL: try to warn for such an error; note the context may be + -- a procedure body. + if Current_Concurrent_Statement /= Null_Iir then + case Get_Kind (Current_Concurrent_Statement) is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment => + if Get_Postponed_Flag (Current_Concurrent_Statement) then + Warning_Msg_Sem + ("waveform may cause a delta cycle in a " & + "postponed process", We); + end if; + when others => + -- Context is a subprogram. + null; + end case; + end if; + + Last_Time := 0; + end if; + We := Get_Chain (We); + end loop; + return; + end Sem_Waveform_Chain; + + -- Semantize a waveform chain WAVEFORM_CHAIN that is assigned via statement + -- ASSIGN_STMT to a subelement or a slice of a signal SIGNAL_DECL. + procedure Sem_Check_Waveform_Chain + (Assign_Stmt: Iir; Waveform_Chain: Iir_Waveform_Element) + is + We: Iir_Waveform_Element; + Expr : Iir; + Targ_Type : Iir; + begin + if Waveform_Chain = Null_Iir then + return; + end if; + + Targ_Type := Get_Type (Get_Target (Assign_Stmt)); + + We := Waveform_Chain; + while We /= Null_Iir loop + Expr := Get_We_Value (We); + if Get_Kind (Expr) = Iir_Kind_Null_Literal then + -- This is a null waveform element. + -- LRM93 8.4.1 + -- It is an error if the target of a signal assignment statement + -- containing a null waveform is not a guarded signal or an + -- aggregate of guarded signals. + if Get_Guarded_Target_State (Assign_Stmt) = False then + Error_Msg_Sem + ("null transactions can be assigned only to guarded signals", + Assign_Stmt); + end if; + else + if not Check_Implicit_Conversion (Targ_Type, Expr) then + Error_Msg_Sem + ("length of value does not match length of target", We); + end if; + end if; + We := Get_Chain (We); + end loop; + end Sem_Check_Waveform_Chain; + + procedure Sem_Signal_Assignment (Stmt: Iir) + is + Target : Iir; + Waveform_Type : Iir; + begin + Target := Get_Target (Stmt); + if Get_Kind (Target) /= Iir_Kind_Aggregate then + if not Sem_Signal_Assignment_Target_And_Option (Stmt, Null_Iir) then + return; + end if; + + -- check the expression. + Waveform_Type := Get_Type (Get_Target (Stmt)); + if Waveform_Type /= Null_Iir then + Sem_Waveform_Chain + (Stmt, Get_Waveform_Chain (Stmt), Waveform_Type); + Sem_Check_Waveform_Chain (Stmt, Get_Waveform_Chain (Stmt)); + end if; + else + Waveform_Type := Null_Iir; + Sem_Waveform_Chain (Stmt, Get_Waveform_Chain (Stmt), Waveform_Type); + if Waveform_Type = Null_Iir + or else + not Sem_Signal_Assignment_Target_And_Option (Stmt, Waveform_Type) + then + return; + end if; + Sem_Check_Waveform_Chain (Stmt, Get_Waveform_Chain (Stmt)); + end if; + end Sem_Signal_Assignment; + + procedure Sem_Variable_Assignment (Stmt: Iir) is + Target: Iir; + Expr: Iir; + Target_Type : Iir; + begin + -- Find the variable. + Target := Get_Target (Stmt); + Expr := Get_Expression (Stmt); + + -- LRM93 8.5 Variable assignment statement + -- If the target of the variable assignment statement is in the form of + -- an aggregate, then the type of the aggregate must be determinable + -- from the context, excluding the aggregate itself but including the + -- fact that the type of the aggregate must be a composite type. The + -- base type of the expression on the right-hand side must be the + -- same as the base type of the aggregate. + -- + -- GHDL: this means that the type can only be deduced from the + -- expression (and not from the target). + if Get_Kind (Target) = Iir_Kind_Aggregate then + if Get_Kind (Expr) = Iir_Kind_Aggregate then + Error_Msg_Sem ("can't determine type, use type qualifier", Expr); + return; + end if; + Expr := Sem_Composite_Expression (Get_Expression (Stmt)); + if Expr = Null_Iir then + return; + end if; + Check_Read (Expr); + Set_Expression (Stmt, Expr); + Target_Type := Get_Type (Expr); + + -- An aggregate cannot be analyzed without a type. + -- FIXME: partially analyze the aggregate ? + if Target_Type = Null_Iir then + return; + end if; + + -- FIXME: check elements are identified at most once. + else + Target_Type := Null_Iir; + end if; + + Target := Sem_Expression (Target, Target_Type); + if Target = Null_Iir then + return; + end if; + Set_Target (Stmt, Target); + + Check_Target (Stmt, Target); + + if Get_Kind (Target) /= Iir_Kind_Aggregate then + Expr := Sem_Expression (Expr, Get_Type (Target)); + if Expr /= Null_Iir then + Check_Read (Expr); + Expr := Eval_Expr_If_Static (Expr); + Set_Expression (Stmt, Expr); + end if; + end if; + if not Check_Implicit_Conversion (Get_Type (Target), Expr) then + Warning_Msg_Sem + ("expression length does not match target length", Stmt); + end if; + end Sem_Variable_Assignment; + + procedure Sem_Return_Statement (Stmt: Iir_Return_Statement) is + Expr: Iir; + begin + if Current_Subprogram = Null_Iir then + Error_Msg_Sem ("return statement not in a subprogram body", Stmt); + return; + end if; + Expr := Get_Expression (Stmt); + case Get_Kind (Current_Subprogram) is + when Iir_Kind_Procedure_Declaration => + if Expr /= Null_Iir then + Error_Msg_Sem + ("return in a procedure can't have an expression", Stmt); + end if; + return; + when Iir_Kind_Function_Declaration => + if Expr = Null_Iir then + Error_Msg_Sem + ("return in a function must have an expression", Stmt); + return; + end if; + when Iir_Kinds_Process_Statement => + Error_Msg_Sem ("return statement not allowed in a process", Stmt); + return; + when others => + Error_Kind ("sem_return_statement", Stmt); + end case; + Set_Type (Stmt, Get_Return_Type (Current_Subprogram)); + Expr := Sem_Expression (Expr, Get_Return_Type (Current_Subprogram)); + if Expr /= Null_Iir then + Check_Read (Expr); + Set_Expression (Stmt, Eval_Expr_If_Static (Expr)); + end if; + end Sem_Return_Statement; + + -- Sem for concurrent and sequential assertion statements. + procedure Sem_Report_Statement (Stmt : Iir) + is + Expr : Iir; + begin + Expr := Get_Report_Expression (Stmt); + if Expr /= Null_Iir then + Expr := Sem_Expression (Expr, String_Type_Definition); + Check_Read (Expr); + Expr := Eval_Expr_If_Static (Expr); + Set_Report_Expression (Stmt, Expr); + end if; + + Expr := Get_Severity_Expression (Stmt); + if Expr /= Null_Iir then + Expr := Sem_Expression (Expr, Severity_Level_Type_Definition); + Check_Read (Expr); + Set_Severity_Expression (Stmt, Expr); + end if; + end Sem_Report_Statement; + + procedure Sem_Assertion_Statement (Stmt: Iir) + is + Expr : Iir; + begin + Expr := Get_Assertion_Condition (Stmt); + Expr := Sem_Condition (Expr); + Expr := Eval_Expr_If_Static (Expr); + Set_Assertion_Condition (Stmt, Expr); + + Sem_Report_Statement (Stmt); + end Sem_Assertion_Statement; + + -- Semantize a list of case choice LIST, and check for correct CHOICE type. + procedure Sem_Case_Choices + (Choice : Iir; Chain : in out Iir; Loc : Location_Type) + is + -- Check restrictions on the expression of a One-Dimensional Character + -- Array Type (ODCAT) given by LRM 8.8 + -- Return FALSE in case of violation. + function Check_Odcat_Expression (Expr : Iir) return Boolean + is + Expr_Type : constant Iir := Get_Type (Expr); + begin + -- LRM 8.8 Case Statement + -- If the expression is of a one-dimensional character array type, + -- then the expression must be one of the following: + case Get_Kind (Expr) is + when Iir_Kinds_Object_Declaration + | Iir_Kind_Selected_Element => + -- FIXME: complete the list. + -- * the name of an object whose subtype is locally static. + if Get_Type_Staticness (Expr_Type) /= Locally then + Error_Msg_Sem ("object subtype is not locally static", + Choice); + return False; + end if; + when Iir_Kind_Indexed_Name => + -- LRM93 + -- * an indexed name whose prefix is one of the members of + -- this list and whose indexing expressions are locally + -- static expression. + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Sem ("indexed name not allowed here in vhdl87", + Expr); + return False; + end if; + if not Check_Odcat_Expression (Get_Prefix (Expr)) then + return False; + end if; + -- GHDL: I don't understand why the indexing expressions + -- must be locally static. So I don't check this in 93c. + if Flags.Vhdl_Std /= Vhdl_93c + and then + Get_Expr_Staticness (Get_First_Element + (Get_Index_List (Expr))) /= Locally + then + Error_Msg_Sem ("indexing expression must be locally static", + Expr); + return False; + end if; + when Iir_Kind_Slice_Name => + -- LRM93 + -- * a slice name whose prefix is one of the members of this + -- list and whose discrete range is a locally static + -- discrete range. + + -- LRM87/INT1991 IR96 + -- then the expression must be either a slice name whose + -- discrete range is locally static, or .. + if False and Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Sem + ("slice not allowed as case expression in vhdl87", Expr); + return False; + end if; + if not Check_Odcat_Expression (Get_Prefix (Expr)) then + return False; + end if; + if Get_Type_Staticness (Expr_Type) /= Locally then + Error_Msg_Sem ("slice discrete range must be locally static", + Expr); + return False; + end if; + when Iir_Kind_Function_Call => + -- LRM93 + -- * a function call whose return type mark denotes a + -- locally static subtype. + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Sem ("function call not allowed here in vhdl87", + Expr); + return False; + end if; + if Get_Type_Staticness (Expr_Type) /= Locally then + Error_Msg_Sem ("function call type is not locally static", + Expr); + end if; + when Iir_Kind_Qualified_Expression + | Iir_Kind_Type_Conversion => + -- * a qualified expression or type conversion whose type mark + -- denotes a locally static subtype. + if Get_Type_Staticness (Expr_Type) /= Locally then + Error_Msg_Sem ("type mark is not a locally static subtype", + Expr); + return False; + end if; + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Check_Odcat_Expression (Get_Named_Entity (Expr)); + when others => + Error_Msg_Sem ("bad form of case expression (refer to LRM 8.8)", + Choice); + return False; + end case; + return True; + end Check_Odcat_Expression; + + Choice_Type : Iir; + Low, High : Iir; + El_Type : Iir; + begin + -- LRM 8.8 Case Statement + -- The expression must be of a discrete type, or of a one-dimensional + -- array type whose element base type is a character type. + Choice_Type := Get_Type (Choice); + case Get_Kind (Choice_Type) is + when Iir_Kinds_Discrete_Type_Definition => + Sem_Choices_Range + (Chain, Choice_Type, False, True, Loc, Low, High); + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + if not Is_One_Dimensional_Array_Type (Choice_Type) then + Error_Msg_Sem + ("expression must be of a one-dimensional array type", + Choice); + return; + end if; + El_Type := Get_Base_Type (Get_Element_Subtype (Choice_Type)); + if Get_Kind (El_Type) /= Iir_Kind_Enumeration_Type_Definition then + -- FIXME: check character. + Error_Msg_Sem + ("element type of the expression must be a character type", + Choice); + return; + end if; + if not Check_Odcat_Expression (Choice) then + return; + end if; + Sem_String_Choices_Range (Chain, Choice); + when others => + Error_Msg_Sem ("type of expression must be discrete", Choice); + end case; + end Sem_Case_Choices; + + procedure Sem_Case_Statement (Stmt: Iir_Case_Statement) + is + Expr: Iir; + Chain : Iir; + El: Iir; + begin + Expr := Get_Expression (Stmt); + -- FIXME: overload. + Expr := Sem_Case_Expression (Expr); + if Expr = Null_Iir then + return; + end if; + Check_Read (Expr); + Set_Expression (Stmt, Expr); + Chain := Get_Case_Statement_Alternative_Chain (Stmt); + Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); + Set_Case_Statement_Alternative_Chain (Stmt, Chain); + -- Sem on associated. + El := Chain; + while El /= Null_Iir loop + Sem_Sequential_Statements_Internal (Get_Associated_Chain (El)); + El := Get_Chain (El); + end loop; + end Sem_Case_Statement; + + -- Sem the sensitivity list LIST. + procedure Sem_Sensitivity_List (List: Iir_Designator_List) + is + El: Iir; + Res: Iir; + Prefix : Iir; + begin + if List = Iir_List_All then + return; + end if; + + for I in Natural loop + -- El is an iir_identifier. + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + + Sem_Name (El); + + Res := Get_Named_Entity (El); + if Res = Error_Mark then + null; + elsif Is_Overload_List (Res) or else not Is_Object_Name (Res) then + Error_Msg_Sem ("a sensitivity element must be a signal name", El); + else + Res := Finish_Sem_Name (El); + Prefix := Get_Object_Prefix (Res); + case Get_Kind (Prefix) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kinds_Signal_Attribute => + null; + when Iir_Kind_Interface_Signal_Declaration => + if not Iir_Mode_Readable (Get_Mode (Prefix)) then + Error_Msg_Sem + (Disp_Node (Res) & " of mode out" + & " can't be in a sensivity list", El); + end if; + when others => + Error_Msg_Sem (Disp_Node (Res) + & " is neither a signal nor a port", El); + end case; + -- LRM 9.2 + -- Only static signal names (see section 6.1) for which reading + -- is permitted may appear in the sensitivity list of a process + -- statement. + + -- LRM 8.1 Wait statement + -- Each signal name in the sensitivity list must be a static + -- signal name, and each name must denote a signal for which + -- reading is permitted. + if Get_Name_Staticness (Res) < Globally then + Error_Msg_Sem ("sensitivity element " & Disp_Node (Res) + & " must be a static name", El); + end if; + + Replace_Nth_Element (List, I, Res); + end if; + end loop; + end Sem_Sensitivity_List; + + procedure Sem_Wait_Statement (Stmt: Iir_Wait_Statement) + is + Expr: Iir; + Sensitivity_List : Iir_List; + begin + -- Check validity. + case Get_Kind (Current_Subprogram) is + when Iir_Kind_Process_Statement => + null; + when Iir_Kinds_Function_Declaration => + -- LRM93 §8.2 + -- It is an error if a wait statement appears in a function + -- subprogram [...] + Error_Msg_Sem + ("wait statement not allowed in a function subprogram", Stmt); + return; + when Iir_Kinds_Procedure_Declaration => + -- LRM93 §8.2 + -- [It is an error ...] or in a procedure that has a parent that + -- is a function subprogram. + -- LRM93 §8.2 + -- [...] or in a procedure that has a parent that is such a + -- process statement. + -- GHDL: this is checked at the end of analysis or during + -- elaboration. + Set_Wait_State (Current_Subprogram, True); + when Iir_Kind_Sensitized_Process_Statement => + -- LRM93 §8.2 + -- Furthermore, it is an error if a wait statement appears in an + -- explicit process statement that includes a sensitivity list, + -- [...] + Error_Msg_Sem + ("wait statement not allowed in a sensitized process", Stmt); + return; + when others => + raise Internal_Error; + end case; + + Sensitivity_List := Get_Sensitivity_List (Stmt); + if Sensitivity_List /= Null_Iir_List then + Sem_Sensitivity_List (Sensitivity_List); + end if; + Expr := Get_Condition_Clause (Stmt); + if Expr /= Null_Iir then + Expr := Sem_Condition (Expr); + Set_Condition_Clause (Stmt, Expr); + end if; + Expr := Get_Timeout_Clause (Stmt); + if Expr /= Null_Iir then + Expr := Sem_Expression (Expr, Time_Type_Definition); + if Expr /= Null_Iir then + Check_Read (Expr); + Expr := Eval_Expr_If_Static (Expr); + Set_Timeout_Clause (Stmt, Expr); + if Get_Expr_Staticness (Expr) = Locally + and then Get_Value (Expr) < 0 + then + Error_Msg_Sem ("timeout value must be positive", Stmt); + end if; + end if; + end if; + end Sem_Wait_Statement; + + procedure Sem_Exit_Next_Statement (Stmt : Iir) + is + Cond: Iir; + Loop_Label : Iir; + Loop_Stmt: Iir; + P : Iir; + begin + Cond := Get_Condition (Stmt); + if Cond /= Null_Iir then + Cond := Sem_Condition (Cond); + Set_Condition (Stmt, Cond); + end if; + + Loop_Label := Get_Loop_Label (Stmt); + if Loop_Label /= Null_Iir then + Loop_Label := Sem_Denoting_Name (Loop_Label); + Set_Loop_Label (Stmt, Loop_Label); + Loop_Stmt := Get_Named_Entity (Loop_Label); + case Get_Kind (Loop_Stmt) is + when Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement => + null; + when others => + Error_Class_Match (Loop_Label, "loop statement"); + Loop_Stmt := Null_Iir; + end case; + else + Loop_Stmt := Null_Iir; + end if; + + -- Check the current statement is inside the labeled loop. + P := Stmt; + loop + P := Get_Parent (P); + case Get_Kind (P) is + when Iir_Kind_While_Loop_Statement + | Iir_Kind_For_Loop_Statement => + if Loop_Stmt = Null_Iir or else P = Loop_Stmt then + exit; + end if; + when Iir_Kind_If_Statement + | Iir_Kind_Elsif + | Iir_Kind_Case_Statement => + null; + when others => + -- FIXME: should emit a message for label mismatch. + Error_Msg_Sem ("exit/next must be inside a loop", Stmt); + exit; + end case; + end loop; + end Sem_Exit_Next_Statement; + + -- Process is the scope, this is also the process for which drivers can + -- be created. + procedure Sem_Sequential_Statements_Internal (First_Stmt : Iir) + is + Stmt: Iir; + begin + Stmt := First_Stmt; + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Null_Statement => + null; + when Iir_Kind_If_Statement => + declare + Clause: Iir := Stmt; + Cond: Iir; + begin + while Clause /= Null_Iir loop + Cond := Get_Condition (Clause); + if Cond /= Null_Iir then + Cond := Sem_Condition (Cond); + Set_Condition (Clause, Cond); + end if; + Sem_Sequential_Statements_Internal + (Get_Sequential_Statement_Chain (Clause)); + Clause := Get_Else_Clause (Clause); + end loop; + end; + when Iir_Kind_For_Loop_Statement => + declare + Iterator: Iir; + begin + -- LRM 10.1 Declarative region + -- 9. A loop statement. + Open_Declarative_Region; + + Set_Is_Within_Flag (Stmt, True); + Iterator := Get_Parameter_Specification (Stmt); + Sem_Scopes.Add_Name (Iterator); + Sem_Iterator (Iterator, None); + Set_Visible_Flag (Iterator, True); + Sem_Sequential_Statements_Internal + (Get_Sequential_Statement_Chain (Stmt)); + Set_Is_Within_Flag (Stmt, False); + + Close_Declarative_Region; + end; + when Iir_Kind_While_Loop_Statement => + declare + Cond: Iir; + begin + Cond := Get_Condition (Stmt); + if Cond /= Null_Iir then + Cond := Sem_Condition (Cond); + Set_Condition (Stmt, Cond); + end if; + Sem_Sequential_Statements_Internal + (Get_Sequential_Statement_Chain (Stmt)); + end; + when Iir_Kind_Signal_Assignment_Statement => + Sem_Signal_Assignment (Stmt); + if Current_Concurrent_Statement /= Null_Iir and then + Get_Kind (Current_Concurrent_Statement) + in Iir_Kinds_Process_Statement + and then Get_Passive_Flag (Current_Concurrent_Statement) + then + Error_Msg_Sem + ("signal statement forbidden in passive process", Stmt); + end if; + when Iir_Kind_Variable_Assignment_Statement => + Sem_Variable_Assignment (Stmt); + when Iir_Kind_Return_Statement => + Sem_Return_Statement (Stmt); + when Iir_Kind_Assertion_Statement => + Sem_Assertion_Statement (Stmt); + when Iir_Kind_Report_Statement => + Sem_Report_Statement (Stmt); + when Iir_Kind_Case_Statement => + Sem_Case_Statement (Stmt); + when Iir_Kind_Wait_Statement => + Sem_Wait_Statement (Stmt); + when Iir_Kind_Procedure_Call_Statement => + Sem_Procedure_Call (Get_Procedure_Call (Stmt), Stmt); + when Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement => + Sem_Exit_Next_Statement (Stmt); + when others => + Error_Kind ("sem_sequential_statements_Internal", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Sem_Sequential_Statements_Internal; + + procedure Sem_Sequential_Statements (Decl : Iir; Body_Parent : Iir) + is + Outer_Subprogram: Iir; + begin + Outer_Subprogram := Current_Subprogram; + Current_Subprogram := Decl; + + -- Sem declarations + Sem_Sequential_Labels (Get_Sequential_Statement_Chain (Body_Parent)); + Sem_Declaration_Chain (Body_Parent); + Sem_Specification_Chain (Body_Parent, Null_Iir); + + -- Sem statements. + Sem_Sequential_Statements_Internal + (Get_Sequential_Statement_Chain (Body_Parent)); + + Check_Full_Declaration (Body_Parent, Body_Parent); + + Current_Subprogram := Outer_Subprogram; + end Sem_Sequential_Statements; + + -- Sem the instantiated unit of STMT and return the node constaining + -- ports and generics (either a entity_declaration or a component + -- declaration). + function Sem_Instantiated_Unit + (Stmt : Iir_Component_Instantiation_Statement) + return Iir + is + Inst : Iir; + Comp_Name : Iir; + Comp : Iir; + begin + Inst := Get_Instantiated_Unit (Stmt); + + if Get_Kind (Inst) in Iir_Kinds_Denoting_Name then + Comp := Get_Named_Entity (Inst); + if Comp /= Null_Iir then + -- Already semantized before, while trying to separate + -- concurrent procedure calls from instantiation stmts. + pragma Assert (Get_Kind (Comp) = Iir_Kind_Component_Declaration); + return Comp; + end if; + -- The component may be an entity or a configuration. + Comp_Name := Sem_Denoting_Name (Inst); + Set_Instantiated_Unit (Stmt, Comp_Name); + Comp := Get_Named_Entity (Comp_Name); + if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then + Error_Class_Match (Comp_Name, "component"); + return Null_Iir; + end if; + return Comp; + else + return Sem_Entity_Aspect (Inst); + end if; + end Sem_Instantiated_Unit; + + procedure Sem_Component_Instantiation_Statement + (Stmt: Iir_Component_Instantiation_Statement; Is_Passive : Boolean) + is + Decl : Iir; + Entity_Unit : Iir_Design_Unit; + Bind : Iir_Binding_Indication; + begin + -- FIXME: move this check in parse ? + if Is_Passive then + Error_Msg_Sem ("component instantiation forbidden in entity", Stmt); + end if; + + -- Check for label. + -- This cannot be moved in parse since a procedure_call may be revert + -- into a component instantiation. + if Get_Label (Stmt) = Null_Identifier then + Error_Msg_Sem ("component instantiation requires a label", Stmt); + end if; + + -- Look for the component. + Decl := Sem_Instantiated_Unit (Stmt); + if Decl = Null_Iir then + return; + end if; + + -- The association + Sem_Generic_Port_Association_Chain (Decl, Stmt); + + -- FIXME: add sources for signals, in order to detect multiple sources + -- to unresolved signals. + -- What happen if the component is not bound ? + + -- Create a default binding indication if necessary. + if Get_Component_Configuration (Stmt) = Null_Iir + and then Get_Kind (Decl) = Iir_Kind_Component_Declaration + then + Entity_Unit := Get_Visible_Entity_Declaration (Decl); + if Entity_Unit = Null_Iir then + if Flags.Warn_Default_Binding + and then not Flags.Flag_Elaborate + then + Warning_Msg_Sem ("no default binding for instantiation of " + & Disp_Node (Decl), Stmt); + Explain_No_Visible_Entity (Decl); + end if; + elsif Flags.Flag_Elaborate + and then (Flags.Flag_Elaborate_With_Outdated + or else Get_Date (Entity_Unit) in Date_Valid) + then + Bind := Sem_Create_Default_Binding_Indication + (Decl, Entity_Unit, Stmt, False); + Set_Default_Binding_Indication (Stmt, Bind); + end if; + end if; + end Sem_Component_Instantiation_Statement; + + -- Note: a statement such as + -- label1: name; + -- can be parsed as a procedure call statement or as a + -- component instantiation statement. + -- Check now and revert in case of error. + function Sem_Concurrent_Procedure_Call_Statement + (Stmt : Iir; Is_Passive : Boolean) return Iir + is + Call : Iir_Procedure_Call; + Decl : Iir; + Label : Name_Id; + N_Stmt : Iir_Component_Instantiation_Statement; + Imp : Iir; + begin + Call := Get_Procedure_Call (Stmt); + if Get_Parameter_Association_Chain (Call) = Null_Iir then + Imp := Get_Prefix (Call); + Sem_Name (Imp); + Set_Prefix (Call, Imp); + + Decl := Get_Named_Entity (Imp); + if Get_Kind (Decl) = Iir_Kind_Component_Declaration then + N_Stmt := Create_Iir (Iir_Kind_Component_Instantiation_Statement); + Label := Get_Label (Stmt); + Set_Label (N_Stmt, Label); + Set_Parent (N_Stmt, Get_Parent (Stmt)); + Set_Instantiated_Unit (N_Stmt, Finish_Sem_Name (Imp)); + Location_Copy (N_Stmt, Stmt); + + if Label /= Null_Identifier then + -- A component instantiation statement must have + -- a label, this condition is checked during the + -- sem of the statement. + Sem_Scopes.Replace_Name (Label, Stmt, N_Stmt); + end if; + + Free_Iir (Stmt); + Free_Iir (Call); + + Sem_Component_Instantiation_Statement (N_Stmt, Is_Passive); + return N_Stmt; + end if; + end if; + Sem_Procedure_Call (Call, Stmt); + + if Is_Passive then + Imp := Get_Implementation (Call); + if Get_Kind (Imp) = Iir_Kind_Procedure_Declaration then + Decl := Get_Interface_Declaration_Chain (Imp); + while Decl /= Null_Iir loop + if Get_Mode (Decl) in Iir_Out_Modes then + Error_Msg_Sem (Disp_Node (Imp) & " is not passive", Stmt); + exit; + end if; + Decl := Get_Chain (Decl); + end loop; + end if; + end if; + + return Stmt; + end Sem_Concurrent_Procedure_Call_Statement; + + procedure Sem_Block_Statement (Stmt: Iir_Block_Statement) + is + Expr: Iir; + Guard : Iir_Guard_Signal_Declaration; + Header : Iir_Block_Header; + Generic_Chain : Iir; + Port_Chain : Iir; + begin + -- LRM 10.1 Declarative region. + -- 7. A block statement. + Open_Declarative_Region; + + Set_Is_Within_Flag (Stmt, True); + + Header := Get_Block_Header (Stmt); + if Header /= Null_Iir then + Generic_Chain := Get_Generic_Chain (Header); + Sem_Interface_Chain (Generic_Chain, Generic_Interface_List); + Port_Chain := Get_Port_Chain (Header); + Sem_Interface_Chain (Port_Chain, Port_Interface_List); + + -- LRM 9.1 + -- Such actuals are evaluated in the context of the enclosing + -- declarative region. + -- GHDL: close the declarative region... + Set_Is_Within_Flag (Stmt, False); + Close_Declarative_Region; + + Sem_Generic_Port_Association_Chain (Header, Header); + + -- ... and reopen-it. + Open_Declarative_Region; + Set_Is_Within_Flag (Stmt, True); + Add_Declarations_From_Interface_Chain (Generic_Chain); + Add_Declarations_From_Interface_Chain (Port_Chain); + end if; + + -- LRM93 9.1 + -- If a guard expression appears after the reserved word BLOCK, then a + -- signal with the simple name GUARD of predefined type BOOLEAN is + -- implicitly declared at the beginning of the declarative part of the + -- block, and the guard expression defined the value of that signal at + -- any given time. + Guard := Get_Guard_Decl (Stmt); + if Guard /= Null_Iir then + -- LRM93 9.1 + -- The type of the guard expression must be type BOOLEAN. + -- GHDL: guard expression must be semantized before creating the + -- implicit GUARD signal, since the expression may reference GUARD. + Set_Expr_Staticness (Guard, None); + Set_Name_Staticness (Guard, Locally); + Expr := Get_Guard_Expression (Guard); + Expr := Sem_Condition (Expr); + if Expr /= Null_Iir then + Set_Guard_Expression (Guard, Expr); + end if; + + -- FIXME: should extract sensivity now and set the has_active flag + -- on signals, since the guard expression is evaluated when one of + -- its signal is active. However, how can a bug be introduced by + -- evaluating only when signals have events ? + + -- the guard expression is an implicit definition of a signal named + -- GUARD. Create this definition. This is necessary for the type. + Set_Identifier (Guard, Std_Names.Name_Guard); + Set_Type (Guard, Boolean_Type_Definition); + Set_Block_Statement (Guard, Stmt); + Sem_Scopes.Add_Name (Guard); + Set_Visible_Flag (Guard, True); + end if; + + Sem_Block (Stmt, True); + Set_Is_Within_Flag (Stmt, False); + Close_Declarative_Region; + end Sem_Block_Statement; + + procedure Sem_Generate_Statement (Stmt : Iir_Generate_Statement) + is + Scheme : Iir; + begin + -- LRM93 10.1 Declarative region. + -- 12. A generate statement. + Open_Declarative_Region; + + Scheme := Get_Generation_Scheme (Stmt); + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Sem_Scopes.Add_Name (Scheme); + -- LRM93 §7.4.2 (Globally Static Primaries) + -- 4. a generate parameter; + Sem_Iterator (Scheme, Globally); + Set_Visible_Flag (Scheme, True); + -- LRM93 §9.7 + -- The discrete range in a generation scheme of the first form must + -- be a static discrete range; + if Get_Type (Scheme) /= Null_Iir + and then Get_Type_Staticness (Get_Type (Scheme)) < Globally + then + Error_Msg_Sem ("range must be a static discrete range", Stmt); + end if; + else + Scheme := Sem_Condition (Scheme); + -- LRM93 §9.7 + -- the condition in a generation scheme of the second form must be + -- a static expression. + if Scheme /= Null_Iir + and then Get_Expr_Staticness (Scheme) < Globally + then + Error_Msg_Sem ("condition must be a static expression", Stmt); + else + Set_Generation_Scheme (Stmt, Scheme); + end if; + end if; + + Sem_Block (Stmt, True); -- Flags.Vhdl_Std /= Vhdl_87); + Close_Declarative_Region; + end Sem_Generate_Statement; + + procedure Sem_Process_Statement (Proc: Iir) is + begin + Set_Is_Within_Flag (Proc, True); + + -- LRM 10.1 + -- 8. A process statement + Open_Declarative_Region; + + -- Sem declarations + Sem_Sequential_Statements (Proc, Proc); + + Close_Declarative_Region; + + Set_Is_Within_Flag (Proc, False); + + if Get_Kind (Proc) = Iir_Kind_Sensitized_Process_Statement + and then Get_Callees_List (Proc) /= Null_Iir_List + then + -- Check there is no wait statement in subprograms called. + -- Also in the case of all-sensitized process, check that package + -- subprograms don't read signals. + Sem.Add_Analysis_Checks_List (Proc); + end if; + end Sem_Process_Statement; + + procedure Sem_Sensitized_Process_Statement + (Proc: Iir_Sensitized_Process_Statement) is + begin + Sem_Sensitivity_List (Get_Sensitivity_List (Proc)); + Sem_Process_Statement (Proc); + end Sem_Sensitized_Process_Statement; + + procedure Sem_Guard (Stmt: Iir) + is + Guard: Iir; + Guard_Interpretation : Name_Interpretation_Type; + begin + Guard := Get_Guard (Stmt); + if Guard = Null_Iir then + -- This assignment is not guarded. + + -- LRM93 9.5 + -- It is an error if a concurrent signal assignment is not a guarded + -- assignment, and the target of the concurrent signal assignment + -- is a guarded target. + if Get_Guarded_Target_State (Stmt) = True then + Error_Msg_Sem + ("not a guarded assignment for a guarded target", Stmt); + end if; + return; + end if; + if Guard /= Stmt then + -- if set, guard must be equal to stmt here. + raise Internal_Error; + end if; + Guard_Interpretation := Get_Interpretation (Std_Names.Name_Guard); + if not Valid_Interpretation (Guard_Interpretation) then + Error_Msg_Sem ("no guard signals for this guarded assignment", Stmt); + return; + end if; + + Guard := Get_Declaration (Guard_Interpretation); + -- LRM93 9.5: + -- The signal GUARD [...] an explicitly declared signal of type + -- BOOLEAN that is visible at the point of the concurrent signal + -- assignment statement + -- FIXME. + case Get_Kind (Guard) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration => + null; + when others => + Error_Msg_Sem ("visible GUARD object is not a signal", Stmt); + Error_Msg_Sem ("GUARD object is " & Disp_Node (Guard), Stmt); + return; + end case; + + if Get_Type (Guard) /= Boolean_Type_Definition then + Error_Msg_Sem ("GUARD is not of boolean type", Guard); + end if; + Set_Guard (Stmt, Guard); + end Sem_Guard; + + procedure Sem_Concurrent_Conditional_Signal_Assignment + (Stmt: Iir_Concurrent_Conditional_Signal_Assignment) + is + Cond_Wf : Iir_Conditional_Waveform; + Expr : Iir; + Wf_Chain : Iir_Waveform_Element; + Target_Type : Iir; + Target : Iir; + begin + Target := Get_Target (Stmt); + if Get_Kind (Target) /= Iir_Kind_Aggregate then + if not Sem_Signal_Assignment_Target_And_Option (Stmt, Null_Iir) then + return; + end if; + Target := Get_Target (Stmt); + Target_Type := Get_Type (Target); + else + Target_Type := Null_Iir; + end if; + + Cond_Wf := Get_Conditional_Waveform_Chain (Stmt); + while Cond_Wf /= Null_Iir loop + Wf_Chain := Get_Waveform_Chain (Cond_Wf); + Sem_Waveform_Chain (Stmt, Wf_Chain, Target_Type); + Sem_Check_Waveform_Chain (Stmt, Wf_Chain); + Expr := Get_Condition (Cond_Wf); + if Expr /= Null_Iir then + Expr := Sem_Condition (Expr); + if Expr /= Null_Iir then + Set_Condition (Cond_Wf, Expr); + end if; + end if; + Cond_Wf := Get_Chain (Cond_Wf); + end loop; + Sem_Guard (Stmt); + if Get_Kind (Target) = Iir_Kind_Aggregate then + if not Sem_Signal_Assignment_Target_And_Option (Stmt, Target_Type) + then + return; + end if; + end if; + end Sem_Concurrent_Conditional_Signal_Assignment; + + procedure Sem_Concurrent_Selected_Signal_Assignment (Stmt: Iir) + is + Expr: Iir; + Chain : Iir; + El: Iir; + Waveform_Type : Iir; + Target : Iir; + Assoc_El : Iir; + begin + Target := Get_Target (Stmt); + Chain := Get_Selected_Waveform_Chain (Stmt); + Waveform_Type := Null_Iir; + + if Get_Kind (Target) = Iir_Kind_Aggregate then + -- LRM 9.5 Concurrent Signal Assgnment Statements. + -- The process statement equivalent to a concurrent signal assignment + -- statement [...] is constructed as follows: [...] + -- + -- LRM 9.5.2 Selected Signa Assignment + -- The characteristics of the selected expression, the waveforms and + -- the choices in the selected assignment statement must be such that + -- the case statement in the equivalent statement is a legal + -- statement + + -- Find the first waveform that will appear in the equivalent + -- process statement, and extract type from it. + Assoc_El := Null_Iir; + El := Chain; + + while El /= Null_Iir loop + Assoc_El := Get_Associated_Expr (El); + exit when Assoc_El /= Null_Iir; + El := Get_Chain (El); + end loop; + if Assoc_El = Null_Iir then + Error_Msg_Sem + ("cannot determine type of the aggregate target", Target); + else + Sem_Waveform_Chain (Stmt, Assoc_El, Waveform_Type); + end if; + if Waveform_Type = Null_Iir then + -- Type of target still unknown. + -- Since the target is an aggregate, we won't be able to + -- semantize it. + -- Avoid a crash. + return; + end if; + end if; + if not Sem_Signal_Assignment_Target_And_Option (Stmt, Waveform_Type) then + return; + end if; + Waveform_Type := Get_Type (Get_Target (Stmt)); + + -- Sem on associated. + if Waveform_Type /= Null_Iir then + El := Chain; + while El /= Null_Iir loop + Sem_Waveform_Chain + (Stmt, Get_Associated_Chain (El), Waveform_Type); + Sem_Check_Waveform_Chain (Stmt, Get_Associated_Chain (El)); + El := Get_Chain (El); + end loop; + end if; + + -- The choices. + Expr := Sem_Case_Expression (Get_Expression (Stmt)); + if Expr = Null_Iir then + return; + end if; + Check_Read (Expr); + Set_Expression (Stmt, Expr); + Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); + Set_Selected_Waveform_Chain (Stmt, Chain); + + Sem_Guard (Stmt); + end Sem_Concurrent_Selected_Signal_Assignment; + + procedure Simple_Simultaneous_Statement (Stmt : Iir) is + Left, Right : Iir; + Res_Type : Iir; + begin + Left := Get_Simultaneous_Left (Stmt); + Right := Get_Simultaneous_Right (Stmt); + + Left := Sem_Expression_Ov (Left, Null_Iir); + Right := Sem_Expression_Ov (Right, Null_Iir); + + -- Give up in case of error + if Left = Null_Iir or else Right = Null_Iir then + return; + end if; + + Res_Type := Search_Compatible_Type (Get_Type (Left), Get_Type (Right)); + if Res_Type = Null_Iir then + Error_Msg_Sem ("types of left and right expressions are incompatible", + Stmt); + return; + end if; + + -- FIXME: check for nature type... + end Simple_Simultaneous_Statement; + + procedure Sem_Concurrent_Statement_Chain (Parent : Iir) + is + Is_Passive : constant Boolean := + Get_Kind (Parent) = Iir_Kind_Entity_Declaration; + El: Iir; + Prev_El : Iir; + Prev_Concurrent_Statement : Iir; + Prev_Psl_Default_Clock : Iir; + begin + Prev_Concurrent_Statement := Current_Concurrent_Statement; + Prev_Psl_Default_Clock := Current_Psl_Default_Clock; + + El := Get_Concurrent_Statement_Chain (Parent); + Prev_El := Null_Iir; + while El /= Null_Iir loop + Current_Concurrent_Statement := El; + + case Get_Kind (El) is + when Iir_Kind_Concurrent_Conditional_Signal_Assignment => + if Is_Passive then + Error_Msg_Sem ("signal assignment forbidden in entity", El); + end if; + Sem_Concurrent_Conditional_Signal_Assignment (El); + when Iir_Kind_Concurrent_Selected_Signal_Assignment => + if Is_Passive then + Error_Msg_Sem ("signal assignment forbidden in entity", El); + end if; + Sem_Concurrent_Selected_Signal_Assignment (El); + when Iir_Kind_Sensitized_Process_Statement => + Set_Passive_Flag (El, Is_Passive); + Sem_Sensitized_Process_Statement (El); + when Iir_Kind_Process_Statement => + Set_Passive_Flag (El, Is_Passive); + Sem_Process_Statement (El); + when Iir_Kind_Component_Instantiation_Statement => + Sem_Component_Instantiation_Statement (El, Is_Passive); + when Iir_Kind_Concurrent_Assertion_Statement => + -- FIXME: must check assertion expressions does not contain + -- non-passive subprograms ?? + Sem_Assertion_Statement (El); + when Iir_Kind_Block_Statement => + if Is_Passive then + Error_Msg_Sem ("block forbidden in entity", El); + end if; + Sem_Block_Statement (El); + when Iir_Kind_Generate_Statement => + if Is_Passive then + Error_Msg_Sem ("generate statement forbidden in entity", El); + end if; + Sem_Generate_Statement (El); + when Iir_Kind_Concurrent_Procedure_Call_Statement => + declare + Next_El : Iir; + N_Stmt : Iir; + begin + Next_El := Get_Chain (El); + N_Stmt := Sem_Concurrent_Procedure_Call_Statement + (El, Is_Passive); + if N_Stmt /= El then + -- Replace this node. + El := N_Stmt; + if Prev_El = Null_Iir then + Set_Concurrent_Statement_Chain (Parent, El); + else + Set_Chain (Prev_El, El); + end if; + Set_Chain (El, Next_El); + end if; + end; + when Iir_Kind_Psl_Declaration => + Sem_Psl.Sem_Psl_Declaration (El); + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Sem_Psl.Sem_Psl_Assert_Statement (El); + when Iir_Kind_Psl_Default_Clock => + Sem_Psl.Sem_Psl_Default_Clock (El); + when Iir_Kind_Simple_Simultaneous_Statement => + Simple_Simultaneous_Statement (El); + when others => + Error_Kind ("sem_concurrent_statement_chain", El); + end case; + Prev_El := El; + El := Get_Chain (El); + end loop; + + Current_Concurrent_Statement := Prev_Concurrent_Statement; + Current_Psl_Default_Clock := Prev_Psl_Default_Clock; + end Sem_Concurrent_Statement_Chain; + + -- Put labels in declarative region. + procedure Sem_Labels_Chain (Parent : Iir) + is + Stmt: Iir; + Label: Name_Id; + begin + Stmt := Get_Concurrent_Statement_Chain (Parent); + while Stmt /= Null_Iir loop + + case Get_Kind (Stmt) is + when Iir_Kind_Psl_Declaration => + -- Special case for in-lined PSL declarations. + null; + when others => + Label := Get_Label (Stmt); + + if Label /= Null_Identifier then + Sem_Scopes.Add_Name (Stmt); + Name_Visible (Stmt); + Xref_Decl (Stmt); + end if; + end case; + + -- INT-1991/issue report 27 + -- Generate statements represent declarative region and have + -- implicit declarative part. + if False + and then Flags.Vhdl_Std = Vhdl_87 + and then Get_Kind (Stmt) = Iir_Kind_Generate_Statement + then + Sem_Labels_Chain (Stmt); + end if; + + Stmt := Get_Chain (Stmt); + end loop; + end Sem_Labels_Chain; + + procedure Sem_Block (Blk: Iir; Sem_Decls : Boolean) + is + Implicit : Implicit_Signal_Declaration_Type; + begin + Push_Signals_Declarative_Part (Implicit, Blk); + + if Sem_Decls then + Sem_Labels_Chain (Blk); + Sem_Declaration_Chain (Blk); + end if; + + Sem_Concurrent_Statement_Chain (Blk); + + if Sem_Decls then + -- FIXME: do it only if there is conf. spec. in the declarative + -- part. + Sem_Specification_Chain (Blk, Blk); + Check_Full_Declaration (Blk, Blk); + end if; + + Pop_Signals_Declarative_Part (Implicit); + end Sem_Block; + + -- Add a driver for SIG. + -- STMT is used in case of error (it is the statement that creates the + -- driver). + -- Do nothing if: + -- The current statement list does not belong to a process, + -- SIG is a formal signal interface. + procedure Sem_Add_Driver (Sig : Iir; Stmt : Iir) + is + Sig_Object : Iir; + Sig_Object_Type : Iir; + begin + if Sig = Null_Iir then + return; + end if; + Sig_Object := Get_Object_Prefix (Sig); + Sig_Object_Type := Get_Type (Sig_Object); + + -- LRM 4.3.1.2 Signal Declaration + -- It is an error if, after the elaboration of a description, a + -- signal has multiple sources and it is not a resolved signal. + + -- Check for multiple driver for a unresolved signal declaration. + -- Do this only if the object is a non-composite signal declaration. + -- NOTE: THIS IS DISABLED, since the assignment may be within a + -- generate statement. + if False + and then Get_Kind (Sig_Object) = Iir_Kind_Signal_Declaration + and then Get_Kind (Sig_Object_Type) + not in Iir_Kinds_Composite_Type_Definition + and then not Get_Resolved_Flag (Sig_Object_Type) + then + if Get_Signal_Driver (Sig_Object) /= Null_Iir and then + Get_Signal_Driver (Sig_Object) /= Current_Concurrent_Statement + then + Error_Msg_Sem ("unresolved " & Disp_Node (Sig_Object) + & " has already a driver at " + & Disp_Location (Get_Signal_Driver (Sig_Object)), + Stmt); + else + Set_Signal_Driver (Sig_Object, Current_Concurrent_Statement); + end if; + end if; + + -- LRM 8.4.1 + -- If a given procedure is declared by a declarative item that is not + -- contained within a process statement, and if a signal assignment + -- statement appears in that procedure, then the target of the + -- assignment statement must be a formal parameter of the given + -- procedure or of a parent of that procedure, or an aggregate of such + -- formal parameters. + -- Similarly, if a given procedure is declared by a declarative item + -- that is not contained within a process statement and if a signal is + -- associated with an INOUT or OUT mode signal parameter in a + -- subprogram call within that procedure, then the signal so associated + -- must be a formal parameter of the given procedure or of a parent of + -- that procedure. + if Current_Concurrent_Statement = Null_Iir + or else (Get_Kind (Current_Concurrent_Statement) + not in Iir_Kinds_Process_Statement) + then + -- Not within a process statement. + if Current_Subprogram = Null_Iir then + -- not within a subprogram: concurrent statement. + return; + end if; + + -- Within a subprogram. + if Get_Kind (Sig_Object) = Iir_Kind_Signal_Declaration + or else (Get_Kind (Get_Parent (Sig_Object)) + /= Iir_Kind_Procedure_Declaration) + then + Error_Msg_Sem + (Disp_Node (Sig_Object) & " is not a formal parameter", Stmt); + end if; + end if; + end Sem_Add_Driver; +end Sem_Stmts; diff --git a/src/vhdl/sem_stmts.ads b/src/vhdl/sem_stmts.ads new file mode 100644 index 000000000..d3eeb8c09 --- /dev/null +++ b/src/vhdl/sem_stmts.ads @@ -0,0 +1,87 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +package Sem_Stmts is + -- Semantize declarations and concurrent statements of BLK, which is + -- either an architecture_declaration, and entity_declaration or + -- a block_statement. + -- If SEM_DECLS is true, then semantize the declarations of BLK. + procedure Sem_Block (Blk: Iir; Sem_Decls : Boolean); + + -- Analyze the concurrent statements of PARENT. + procedure Sem_Concurrent_Statement_Chain (Parent : Iir); + + -- Some signals are implicitly declared. This is the case for signals + -- declared by an attribute ('stable, 'quiet and 'transaction). + -- Note: guard signals are also implicitly declared, but with a guard + -- expression, which is located. + -- Since these signals need resources and are not easily located (can be + -- nearly in every expression), it is useful to add a node into a + -- declaration list to declare them. + -- However, only a few declaration_list can declare signals. These + -- declarations lists must register and unregister themselves with + -- push_declarative_region_with_signals and + -- pop_declarative_region_with_signals. + type Implicit_Signal_Declaration_Type is private; + + procedure Push_Signals_Declarative_Part + (Cell: out Implicit_Signal_Declaration_Type; Decls_Parent : Iir); + + procedure Pop_Signals_Declarative_Part + (Cell: in Implicit_Signal_Declaration_Type); + + -- Declare an implicit signal. + procedure Add_Declaration_For_Implicit_Signal (Sig : Iir); + + -- Semantize declaration chain and sequential statement chain + -- of BODY_PARENT. + -- DECL is the declaration for these chains (DECL is the declaration, which + -- is different from the bodies). + -- This is used by processes and subprograms semantization. + procedure Sem_Sequential_Statements (Decl : Iir; Body_Parent : Iir); + + -- Sem for concurrent and sequential assertion statements. + procedure Sem_Report_Statement (Stmt : Iir); + + -- Get the current subprogram or process. + function Get_Current_Subprogram return Iir; + pragma Inline (Get_Current_Subprogram); + + -- Get the current concurrent statement, or NULL_IIR if none. + function Get_Current_Concurrent_Statement return Iir; + pragma Inline (Get_Current_Concurrent_Statement); + + -- Current PSL default_clock declaration. + -- Automatically saved and restore while analyzing concurrent statements. + Current_Psl_Default_Clock : Iir; + + -- Add a driver for SIG. + -- STMT is used in case of error (it is the statement that creates the + -- driver). + -- Do nothing if: + -- The current statement list does not belong to a process, + -- SIG is a formal signal interface. + procedure Sem_Add_Driver (Sig : Iir; Stmt : Iir); +private + type Implicit_Signal_Declaration_Type is record + Decls_Parent : Iir; + Last_Decl : Iir; + end record; + +end Sem_Stmts; diff --git a/src/vhdl/sem_types.adb b/src/vhdl/sem_types.adb new file mode 100644 index 000000000..12f276be1 --- /dev/null +++ b/src/vhdl/sem_types.adb @@ -0,0 +1,2210 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Libraries; +with Flags; use Flags; +with Types; use Types; +with Errorout; use Errorout; +with Evaluation; use Evaluation; +with Sem; +with Sem_Expr; use Sem_Expr; +with Sem_Scopes; use Sem_Scopes; +with Sem_Names; use Sem_Names; +with Sem_Decls; +with Sem_Inst; +with Name_Table; +with Std_Names; +with Iirs_Utils; use Iirs_Utils; +with Std_Package; use Std_Package; +with Ieee.Std_Logic_1164; +with Xrefs; use Xrefs; + +package body Sem_Types is + -- Mark the resolution function (this may be required by the back-end to + -- generate resolver). + procedure Mark_Resolution_Function (Subtyp : Iir) + is + Func : Iir_Function_Declaration; + begin + if not Get_Resolved_Flag (Subtyp) then + return; + end if; + + Func := Has_Resolution_Function (Subtyp); + -- Maybe the type is resolved through its elements. + if Func /= Null_Iir then + Set_Resolution_Function_Flag (Func, True); + end if; + end Mark_Resolution_Function; + + procedure Set_Type_Has_Signal (Atype : Iir) + is + Orig : Iir; + begin + -- Sanity check: ATYPE can be a signal type (eg: not an access type) + if not Get_Signal_Type_Flag (Atype) then + -- Do not crash since this may be called on an erroneous design. + return; + end if; + + -- If the type is already marked, nothing to do. + if Get_Has_Signal_Flag (Atype) then + return; + end if; + + -- This type is used to declare a signal. + Set_Has_Signal_Flag (Atype, True); + + -- If this type was instantiated, also mark the origin. + Orig := Sem_Inst.Get_Origin (Atype); + if Orig /= Null_Iir then + Set_Type_Has_Signal (Orig); + end if; + + -- Mark resolution function, and for composite types, also mark type + -- of elements. + case Get_Kind (Atype) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Floating_Type_Definition => + null; + when Iir_Kinds_Scalar_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition => + Set_Type_Has_Signal (Get_Base_Type (Atype)); + Mark_Resolution_Function (Atype); + when Iir_Kind_Array_Subtype_Definition => + Set_Type_Has_Signal (Get_Base_Type (Atype)); + Mark_Resolution_Function (Atype); + Set_Type_Has_Signal (Get_Element_Subtype (Atype)); + when Iir_Kind_Array_Type_Definition => + 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 + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + Set_Type_Has_Signal (Get_Type (El)); + end loop; + end; + when Iir_Kind_Error => + null; + when Iir_Kind_Incomplete_Type_Definition => + -- No need to copy the flag. + null; + when others => + Error_Kind ("set_type_has_signal(2)", Atype); + end case; + end Set_Type_Has_Signal; + + -- Sem a range expression that appears in an integer, real or physical + -- type definition. + -- + -- Both left and right bounds must be of the same type class, ie + -- integer types, or if INT_ONLY is false, real types. + -- However, the two bounds need not have the same type. + function Sem_Type_Range_Expression (Expr : Iir; Int_Only : Boolean) + return Iir + is + Left, Right: Iir; + Bt_L_Kind, Bt_R_Kind : Iir_Kind; + begin + Left := Sem_Expression_Universal (Get_Left_Limit (Expr)); + Right := Sem_Expression_Universal (Get_Right_Limit (Expr)); + if Left = Null_Iir or Right = Null_Iir then + return Null_Iir; + end if; + + -- Emit error message for overflow and replace with a value to avoid + -- error storm. + if Get_Kind (Left) = Iir_Kind_Overflow_Literal then + Error_Msg_Sem ("overflow in left bound", Left); + Left := Build_Extreme_Value + (Get_Direction (Expr) = Iir_Downto, Left); + end if; + if Get_Kind (Right) = Iir_Kind_Overflow_Literal then + Error_Msg_Sem ("overflow in right bound", Right); + Right := Build_Extreme_Value + (Get_Direction (Expr) = Iir_To, Right); + end if; + Set_Left_Limit (Expr, Left); + Set_Right_Limit (Expr, Right); + + Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Left), + Get_Expr_Staticness (Right))); + + Bt_L_Kind := Get_Kind (Get_Base_Type (Get_Type (Left))); + Bt_R_Kind := Get_Kind (Get_Base_Type (Get_Type (Right))); + + if Int_Only then + if Bt_L_Kind /= Iir_Kind_Integer_Type_Definition + and then Bt_R_Kind = Iir_Kind_Integer_Type_Definition + then + Error_Msg_Sem ("left bound must be an integer expression", Left); + return Null_Iir; + end if; + if Bt_R_Kind /= Iir_Kind_Integer_Type_Definition + and then Bt_L_Kind = Iir_Kind_Integer_Type_Definition + then + Error_Msg_Sem ("right bound must be an integer expression", Left); + return Null_Iir; + end if; + if Bt_R_Kind /= Iir_Kind_Integer_Type_Definition + and then Bt_L_Kind /= Iir_Kind_Integer_Type_Definition + then + Error_Msg_Sem ("each bound must be an integer expression", Expr); + return Null_Iir; + end if; + else + if Bt_L_Kind /= Bt_R_Kind then + Error_Msg_Sem + ("left and right bounds must be of the same type class", Expr); + return Null_Iir; + end if; + case Bt_L_Kind is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition => + null; + when others => + -- Enumeration range are not allowed to define a new type. + Error_Msg_Sem + ("bad range type, only integer or float is allowed", Expr); + return Null_Iir; + end case; + end if; + + return Expr; + end Sem_Type_Range_Expression; + + function Create_Integer_Type (Loc : Iir; Constraint : Iir; Decl : Iir) + return Iir + is + Ntype: Iir_Integer_Subtype_Definition; + Ndef: Iir_Integer_Type_Definition; + begin + Ntype := Create_Iir (Iir_Kind_Integer_Subtype_Definition); + Location_Copy (Ntype, Loc); + Ndef := Create_Iir (Iir_Kind_Integer_Type_Definition); + Location_Copy (Ndef, Loc); + Set_Base_Type (Ndef, Ndef); + Set_Type_Declarator (Ndef, Decl); + Set_Type_Staticness (Ndef, Locally); + Set_Signal_Type_Flag (Ndef, True); + Set_Base_Type (Ntype, Ndef); + Set_Type_Declarator (Ntype, Decl); + Set_Range_Constraint (Ntype, Constraint); + Set_Type_Staticness (Ntype, Get_Expr_Staticness (Constraint)); + Set_Resolved_Flag (Ntype, False); + Set_Signal_Type_Flag (Ntype, True); + if Get_Type_Staticness (Ntype) /= Locally then + Error_Msg_Sem ("range constraint of type must be locally static", + Decl); + end if; + return Ntype; + end Create_Integer_Type; + + function Range_Expr_To_Type_Definition (Expr : Iir; Decl: Iir) + return Iir + is + Rng : Iir; + Res : Iir; + Base_Type : Iir; + begin + if Sem_Type_Range_Expression (Expr, False) = Null_Iir then + return Null_Iir; + end if; + Rng := Eval_Range_If_Static (Expr); + if Get_Expr_Staticness (Rng) /= Locally then + -- FIXME: create an artificial range to avoid error storm ? + null; + end if; + + case Get_Kind (Get_Base_Type (Get_Type (Get_Left_Limit (Rng)))) is + when Iir_Kind_Integer_Type_Definition => + Res := Create_Integer_Type (Expr, Rng, Decl); + when Iir_Kind_Floating_Type_Definition => + declare + Ntype: Iir_Floating_Subtype_Definition; + Ndef: Iir_Floating_Type_Definition; + begin + Ntype := Create_Iir (Iir_Kind_Floating_Subtype_Definition); + Location_Copy (Ntype, Expr); + Ndef := Create_Iir (Iir_Kind_Floating_Type_Definition); + Location_Copy (Ndef, Expr); + Set_Base_Type (Ndef, Ndef); + Set_Type_Declarator (Ndef, Decl); + Set_Type_Staticness (Ndef, Get_Expr_Staticness (Expr)); + Set_Signal_Type_Flag (Ndef, True); + Set_Base_Type (Ntype, Ndef); + Set_Type_Declarator (Ntype, Decl); + Set_Range_Constraint (Ntype, Rng); + Set_Resolved_Flag (Ntype, False); + Set_Type_Staticness (Ntype, Get_Expr_Staticness (Expr)); + Set_Signal_Type_Flag (Ntype, True); + Res := Ntype; + end; + when others => + -- sem_range_expression should catch such errors. + raise Internal_Error; + end case; + + -- A type and a subtype were declared. The type of the bounds are now + -- used for the implicit subtype declaration. But the type of the + -- bounds aren't of the type of the type declaration (this is 'obvious' + -- because they exist before the type declaration). Override their + -- type. This is doable without destroying information as they are + -- either literals (of type convertible_xx_type_definition) or an + -- evaluated literal. + -- + -- Overriding makes these implicit subtype homogenous with explicit + -- subtypes. + Base_Type := Get_Base_Type (Res); + Set_Type (Rng, Base_Type); + Set_Type (Get_Left_Limit (Rng), Base_Type); + Set_Type (Get_Right_Limit (Rng), Base_Type); + + return Res; + end Range_Expr_To_Type_Definition; + + function Create_Physical_Literal (Val : Iir_Int64; Unit : Iir) return Iir + is + Lit : Iir; + begin + Lit := Create_Iir (Iir_Kind_Physical_Int_Literal); + Set_Value (Lit, Val); + Set_Unit_Name (Lit, Unit); + Set_Expr_Staticness (Lit, Locally); + Set_Type (Lit, Get_Type (Unit)); + Location_Copy (Lit, Unit); + return Lit; + end Create_Physical_Literal; + + -- Analyze a physical type definition. Create a subtype. + function Sem_Physical_Type_Definition (Range_Expr: Iir; Decl : Iir) + return Iir_Physical_Subtype_Definition + is + Unit: Iir_Unit_Declaration; + Unit_Name : Iir; + Def : Iir_Physical_Type_Definition; + Sub_Type: Iir_Physical_Subtype_Definition; + Range_Expr1: Iir; + Val : Iir; + Lit : Iir_Physical_Int_Literal; + begin + Def := Get_Type (Range_Expr); + + -- LRM93 4.1 + -- The simple name declared by a type declaration denotes the + -- declared type, unless the type declaration declares both a base + -- type and a subtype of the base type, in which case the simple name + -- denotes the subtype, and the base type is anonymous. + Set_Type_Declarator (Def, Decl); + Set_Base_Type (Def, Def); + Set_Resolved_Flag (Def, False); + Set_Type_Staticness (Def, Locally); + Set_Signal_Type_Flag (Def, True); + + -- Set the type definition of the type declaration (it was currently the + -- range expression). Do it early so that the units can be referenced + -- by expanded names. + Set_Type_Definition (Decl, Def); + + -- LRM93 3.1.3 + -- Each bound of a range constraint that is used in a physical type + -- definition must be a locally static expression of some integer type + -- but the two bounds need not have the same integer type. + case Get_Kind (Range_Expr) is + when Iir_Kind_Range_Expression => + Range_Expr1 := Sem_Type_Range_Expression (Range_Expr, True); + when others => + Error_Kind ("sem_physical_type_definition", Range_Expr); + end case; + if Range_Expr1 /= Null_Iir then + if Get_Expr_Staticness (Range_Expr1) /= Locally then + Error_Msg_Sem + ("range constraint for a physical type must be static", + Range_Expr1); + Range_Expr1 := Null_Iir; + else + Range_Expr1 := Eval_Range_If_Static (Range_Expr1); + end if; + end if; + + -- Create the subtype. + Sub_Type := Create_Iir (Iir_Kind_Physical_Subtype_Definition); + Location_Copy (Sub_Type, Range_Expr); + Set_Base_Type (Sub_Type, Def); + Set_Signal_Type_Flag (Sub_Type, True); + + -- Analyze the primary unit. + Unit := Get_Unit_Chain (Def); + + Unit_Name := Build_Simple_Name (Unit, Unit); + Lit := Create_Physical_Literal (1, Unit_Name); + Set_Physical_Unit_Value (Unit, Lit); + + Sem_Scopes.Add_Name (Unit); + Set_Type (Unit, Def); + Set_Expr_Staticness (Unit, Locally); + Set_Name_Staticness (Unit, Locally); + Set_Visible_Flag (Unit, True); + Xref_Decl (Unit); + + if Range_Expr1 /= Null_Iir then + declare + -- Convert an integer literal to a physical literal. + -- This is used to convert bounds. + function Lit_To_Phys_Lit (Lim : Iir_Integer_Literal) + return Iir_Physical_Int_Literal + is + Res : Iir_Physical_Int_Literal; + begin + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Location_Copy (Res, Lim); + Set_Type (Res, Def); + Set_Value (Res, Get_Value (Lim)); + Set_Unit_Name (Res, Get_Primary_Unit_Name (Def)); + Set_Expr_Staticness (Res, Locally); + Set_Literal_Origin (Res, Lim); + return Res; + end Lit_To_Phys_Lit; + + Phys_Range : Iir_Range_Expression; + begin + -- Create the physical range. + Phys_Range := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Phys_Range, Range_Expr1); + Set_Type (Phys_Range, Def); + Set_Direction (Phys_Range, Get_Direction (Range_Expr1)); + Set_Left_Limit + (Phys_Range, Lit_To_Phys_Lit (Get_Left_Limit (Range_Expr1))); + Set_Right_Limit + (Phys_Range, Lit_To_Phys_Lit (Get_Right_Limit (Range_Expr1))); + Set_Expr_Staticness + (Phys_Range, Get_Expr_Staticness (Range_Expr1)); + + Set_Range_Constraint (Sub_Type, Phys_Range); + -- This must be locally... + Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (Range_Expr1)); + + -- FIXME: the original range is not used. Reuse it ? + Free_Iir (Range_Expr); + end; + end if; + Set_Resolved_Flag (Sub_Type, False); + + -- Analyze secondary units. + Unit := Get_Chain (Unit); + while Unit /= Null_Iir loop + Sem_Scopes.Add_Name (Unit); + Val := Sem_Expression (Get_Physical_Literal (Unit), Def); + if Val /= Null_Iir then + Set_Physical_Literal (Unit, Val); + Val := Eval_Physical_Literal (Val); + Set_Physical_Unit_Value (Unit, Val); + + -- LRM93 §3.1 + -- The position number of unit names need not lie within the range + -- specified by the range constraint. + -- GHDL: this was not true in VHDL87. + -- GHDL: This is not so simple if 1 is not included in the range. + if False and then Flags.Vhdl_Std = Vhdl_87 + and then Range_Expr1 /= Null_Iir + then + if not Eval_Int_In_Range (Get_Value (Unit), Range_Expr1) then + Error_Msg_Sem + ("physical literal does not lie within the range", Unit); + end if; + end if; + else + -- Avoid errors storm. + Set_Physical_Literal (Unit, Get_Primary_Unit (Def)); + Set_Physical_Unit_Value (Unit, Lit); + end if; + + Set_Type (Unit, Def); + Set_Expr_Staticness (Unit, Locally); + Set_Name_Staticness (Unit, Locally); + Sem_Scopes.Name_Visible (Unit); + Xref_Decl (Unit); + Unit := Get_Chain (Unit); + end loop; + + return Sub_Type; + end Sem_Physical_Type_Definition; + + -- Return true iff decl is std.textio.text + function Is_Text_Type_Declaration (Decl : Iir_Type_Declaration) + return Boolean + is + use Std_Names; + P : Iir; + begin + if Get_Identifier (Decl) /= Name_Text then + return False; + end if; + P := Get_Parent (Decl); + if Get_Kind (P) /= Iir_Kind_Package_Declaration + or else Get_Identifier (P) /= Name_Textio + then + return False; + end if; + -- design_unit, design_file, library_declaration. + P := Get_Library (Get_Design_File (Get_Design_Unit (P))); + if P /= Libraries.Std_Library then + return False; + end if; + return True; + end Is_Text_Type_Declaration; + + procedure Check_No_File_Type (El_Type : Iir; Loc : Iir) is + begin + case Get_Kind (El_Type) is + when Iir_Kind_File_Type_Definition => + Error_Msg_Sem + ("element of file type is not allowed in a composite type", Loc); + when others => + null; + end case; + end Check_No_File_Type; + + -- Semantize the array_element type of array type DEF. + -- Set resolved_flag of DEF. + procedure Sem_Array_Element (Def : Iir) + is + El_Type : Iir; + begin + El_Type := Get_Element_Subtype_Indication (Def); + El_Type := Sem_Subtype_Indication (El_Type); + if El_Type = Null_Iir then + Set_Type_Staticness (Def, None); + Set_Resolved_Flag (Def, False); + return; + end if; + Set_Element_Subtype_Indication (Def, El_Type); + + El_Type := Get_Type_Of_Subtype_Indication (El_Type); + Set_Element_Subtype (Def, El_Type); + Check_No_File_Type (El_Type, Def); + Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (El_Type)); + + -- LRM93 §3.2.1.1 + -- The same requirement exists [must define a constrained + -- 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 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; + Set_Resolved_Flag (Def, Get_Resolved_Flag (El_Type)); + end Sem_Array_Element; + + procedure Sem_Protected_Type_Declaration (Type_Decl : Iir_Type_Declaration) + is + Decl : Iir_Protected_Type_Declaration; + El : Iir; + begin + Decl := Get_Type_Definition (Type_Decl); + Set_Base_Type (Decl, Decl); + Set_Resolved_Flag (Decl, False); + Set_Signal_Type_Flag (Decl, False); + Set_Type_Staticness (Decl, None); + + -- LRM 10.3 Visibility + -- [...] except in the declaration of a design_unit or a protected type + -- declaration, in which case it starts immediatly after the reserved + -- word is occuring after the identifier of the design unit or + -- protected type declaration. + Set_Visible_Flag (Type_Decl, True); + + -- LRM 10.1 + -- n) A protected type declaration, together with the corresponding + -- body. + Open_Declarative_Region; + + Sem_Decls.Sem_Declaration_Chain (Decl); + El := Get_Declaration_Chain (Decl); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause + | Iir_Kind_Attribute_Specification => + null; + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + declare + Inter : Iir; + Inter_Type : Iir; + begin + Inter := Get_Interface_Declaration_Chain (El); + while Inter /= Null_Iir loop + Inter_Type := Get_Type (Inter); + if Inter_Type /= Null_Iir + and then Get_Signal_Type_Flag (Inter_Type) = False + and then Get_Kind (Inter_Type) + /= Iir_Kind_Protected_Type_Declaration + then + Error_Msg_Sem + ("formal parameter method must not be " + & "access or file type", Inter); + end if; + Inter := Get_Chain (Inter); + end loop; + if Get_Kind (El) = Iir_Kind_Function_Declaration then + Inter_Type := Get_Return_Type (El); + if Inter_Type /= Null_Iir + and then Get_Signal_Type_Flag (Inter_Type) = False + then + Error_Msg_Sem + ("method return type must not be access of file", + El); + end if; + end if; + end; + when others => + Error_Msg_Sem + (Disp_Node (El) + & " are not allowed in protected type declaration", El); + end case; + El := Get_Chain (El); + end loop; + + Close_Declarative_Region; + end Sem_Protected_Type_Declaration; + + procedure Sem_Protected_Type_Body (Bod : Iir) + is + Inter : Name_Interpretation_Type; + Type_Decl : Iir; + Decl : Iir; + El : Iir; + begin + -- LRM 3.5 Protected types. + -- Each protected type declaration appearing immediatly within a given + -- declaration region must have exactly one corresponding protected type + -- body appearing immediatly within the same declarative region and + -- textually subsequent to the protected type declaration. + -- + -- Similarly, each protected type body appearing immediatly within a + -- given declarative region must have exactly one corresponding + -- protected type declaration appearing immediatly within the same + -- declarative region and textually prior to the protected type body. + Inter := Get_Interpretation (Get_Identifier (Bod)); + if Valid_Interpretation (Inter) + and then Is_In_Current_Declarative_Region (Inter) + then + Type_Decl := Get_Declaration (Inter); + if Get_Kind (Type_Decl) = Iir_Kind_Type_Declaration then + Decl := Get_Type_Definition (Type_Decl); + else + Decl := Null_Iir; + end if; + else + Decl := Null_Iir; + end if; + + if Decl /= Null_Iir + and then Get_Kind (Decl) = Iir_Kind_Protected_Type_Declaration + then + Set_Protected_Type_Declaration (Bod, Decl); + if Get_Protected_Type_Body (Decl) /= Null_Iir then + Error_Msg_Sem + ("protected type body already declared for " + & Disp_Node (Decl), Bod); + Error_Msg_Sem + ("(previous body)", Get_Protected_Type_Body (Decl)); + Decl := Null_Iir; + elsif not Get_Visible_Flag (Type_Decl) then + -- Can this happen ? + Error_Msg_Sem + ("protected type declaration not yet visible", Bod); + Error_Msg_Sem + ("(location of protected type declaration)", Decl); + Decl := Null_Iir; + else + Set_Protected_Type_Body (Decl, Bod); + end if; + else + Error_Msg_Sem + ("no protected type declaration for this body", Bod); + if Decl /= Null_Iir then + Error_Msg_Sem + ("(found " & Disp_Node (Decl) & " declared here)", Decl); + Decl := Null_Iir; + end if; + end if; + + -- LRM 10.1 + -- n) A protected type declaration, together with the corresponding + -- body. + Open_Declarative_Region; + + if Decl /= Null_Iir then + Xref_Body (Bod, Decl); + Add_Protected_Type_Declarations (Decl); + end if; + + Sem_Decls.Sem_Declaration_Chain (Bod); + + El := Get_Declaration_Chain (Bod); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Implicit_Function_Declaration => + null; + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + null; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + null; + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration => + null; + when Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Non_Object_Alias_Declaration => + null; + when Iir_Kind_Attribute_Declaration + | Iir_Kind_Attribute_Specification + | Iir_Kind_Use_Clause + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + when others => + Error_Msg_Sem + (Disp_Node (El) & " not allowed in a protected type body", + El); + end case; + El := Get_Chain (El); + end loop; + Sem_Decls.Check_Full_Declaration (Bod, Bod); + + -- LRM 3.5.2 Protected type bodies + -- Each subprogram declaration appearing in a given protected type + -- declaration shall have a corresponding subprogram body appearing in + -- the corresponding protected type body. + if Decl /= Null_Iir then + Sem_Decls.Check_Full_Declaration (Decl, Bod); + end if; + + 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_Enumeration_Type_Definition (Def: Iir; Decl: Iir) return Iir + is + begin + Set_Base_Type (Def, Def); + Set_Type_Staticness (Def, Locally); + Set_Signal_Type_Flag (Def, True); + + -- Makes all literal visible. + declare + El: Iir; + Literal_List: Iir_List; + Only_Characters : Boolean := True; + begin + Literal_List := Get_Enumeration_Literal_List (Def); + for I in Natural loop + El := Get_Nth_Element (Literal_List, I); + exit when El = Null_Iir; + Set_Expr_Staticness (El, Locally); + Set_Name_Staticness (El, Locally); + Set_Type (El, Def); + Set_Enumeration_Decl (El, El); + Sem.Compute_Subprogram_Hash (El); + 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); + + Create_Range_Constraint_For_Enumeration_Type (Def); + + -- Identifier IEEE.Std_Logic_1164.Std_Ulogic. + if Get_Identifier (Decl) = Std_Names.Name_Std_Ulogic + and then + Get_Parent (Decl) = Ieee.Std_Logic_1164.Std_Logic_1164_Pkg + then + Ieee.Std_Logic_1164.Std_Ulogic_Type := Def; + end if; + + return Def; + end Sem_Enumeration_Type_Definition; + + function Sem_Record_Type_Definition (Def: Iir) return Iir + is + -- Semantized type of previous element + Last_Type : Iir; + + El_List : constant Iir_List := Get_Elements_Declaration_List (Def); + 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_Type := Null_Iir; + Staticness := Locally; + Constraint := Fully_Constrained; + Set_Signal_Type_Flag (Def, True); + + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + + El_Type := Get_Subtype_Indication (El); + if El_Type /= Null_Iir then + -- Be careful for a declaration list (r,g,b: integer). + El_Type := Sem_Subtype_Indication (El_Type); + Set_Subtype_Indication (El, El_Type); + El_Type := Get_Type_Of_Subtype_Indication (El_Type); + Last_Type := El_Type; + else + El_Type := Last_Type; + end if; + if El_Type /= Null_Iir then + Set_Type (El, El_Type); + Check_No_File_Type (El_Type, El); + if not Get_Signal_Type_Flag (El_Type) then + Set_Signal_Type_Flag (Def, False); + end if; + + -- LRM93 3.2.1.1 + -- The same requirement [must define a constrained array + -- subtype] exits for the subtype indication of an + -- element declaration, if the type of the record + -- element is an array type. + 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); + end if; + Resolved_Flag := + 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); + 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 Sem_Record_Type_Definition; + + function Sem_Unbounded_Array_Type_Definition (Def: Iir) return Iir + is + Index_List : constant Iir_List := + Get_Index_Subtype_Definition_List (Def); + Index_Type : Iir; + begin + Set_Base_Type (Def, Def); + + for I in Natural loop + Index_Type := Get_Nth_Element (Index_List, I); + exit when Index_Type = Null_Iir; + + Index_Type := Sem_Type_Mark (Index_Type); + Replace_Nth_Element (Index_List, I, Index_Type); + + Index_Type := Get_Type (Index_Type); + if Get_Kind (Index_Type) not in Iir_Kinds_Discrete_Type_Definition + then + Error_Msg_Sem ("an index type of an array must be a discrete type", + Index_Type); + -- FIXME: disp type Index_Type ? + end if; + end loop; + + Set_Index_Subtype_List (Def, Index_List); + + Sem_Array_Element (Def); + Set_Constraint_State (Def, Get_Array_Constraint (Def)); + + -- According to LRM93 7.4.1, an unconstrained array type is not static. + Set_Type_Staticness (Def, None); + + return Def; + end Sem_Unbounded_Array_Type_Definition; + + -- Return the subtype declaration corresponding to the base type of ATYPE + -- (for integer and real types), or the type for enumerated types. To say + -- that differently, it returns the type or subtype which defines the + -- original range. + function Get_First_Subtype_Declaration (Atype : Iir) return Iir is + Base_Type : constant Iir := Get_Base_Type (Atype); + Base_Decl : constant Iir := Get_Type_Declarator (Base_Type); + begin + if Get_Kind (Base_Type) = Iir_Kind_Enumeration_Type_Definition then + pragma Assert (Get_Kind (Base_Decl) = Iir_Kind_Type_Declaration); + return Base_Decl; + else + return Get_Type_Declarator (Get_Subtype_Definition (Base_Decl)); + end if; + end Get_First_Subtype_Declaration; + + function Sem_Constrained_Array_Type_Definition (Def: Iir; Decl: Iir) + return Iir + is + Index_Type : Iir; + Index_Name : Iir; + Index_List : Iir_List; + Base_Index_List : Iir_List; + El_Type : Iir; + Staticness : Iir_Staticness; + + -- array_type_definition, which is the same as the subtype, + -- but without any constraint in the indexes. + Base_Type: Iir; + begin + -- 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. + + -- FIXME: all indexes must be either constrained or + -- unconstrained. + -- If all indexes are unconstrained, this is really a type + -- otherwise, this is a subtype. + + -- Create a definition for the base type of subtype DEF. + Base_Type := Create_Iir (Iir_Kind_Array_Type_Definition); + Location_Copy (Base_Type, Def); + Set_Base_Type (Base_Type, Base_Type); + Set_Type_Declarator (Base_Type, Decl); + Base_Index_List := Create_Iir_List; + Set_Index_Subtype_Definition_List (Base_Type, Base_Index_List); + Set_Index_Subtype_List (Base_Type, Base_Index_List); + + Staticness := Locally; + Index_List := Get_Index_Constraint_List (Def); + for I in Natural loop + Index_Type := Get_Nth_Element (Index_List, I); + exit when Index_Type = Null_Iir; + + Index_Name := Sem_Discrete_Range_Integer (Index_Type); + if Index_Name /= Null_Iir then + Index_Name := Range_To_Subtype_Indication (Index_Name); + else + -- Avoid errors. + Index_Name := + Build_Simple_Name (Natural_Subtype_Declaration, Index_Type); + Set_Type (Index_Name, Natural_Subtype_Definition); + end if; + + Replace_Nth_Element (Index_List, I, Index_Name); + + Index_Type := Get_Index_Type (Index_Name); + Staticness := Min (Staticness, Get_Type_Staticness (Index_Type)); + + -- Set the index subtype definition for the array base type. + if Get_Kind (Index_Name) in Iir_Kinds_Denoting_Name then + Index_Type := Index_Name; + else + pragma Assert + (Get_Kind (Index_Name) in Iir_Kinds_Subtype_Definition); + Index_Type := Get_Subtype_Type_Mark (Index_Name); + if Index_Type = Null_Iir then + -- From a range expression like '1 to 4' or from an attribute + -- name. + declare + Subtype_Decl : constant Iir := + Get_First_Subtype_Declaration (Index_Name); + begin + Index_Type := Build_Simple_Name (Subtype_Decl, Index_Name); + Set_Type (Index_Type, Get_Type (Subtype_Decl)); + end; + end if; + end if; + Append_Element (Base_Index_List, Index_Type); + end loop; + Set_Index_Subtype_List (Def, Index_List); + + -- Element type. + Set_Element_Subtype_Indication (Base_Type, Get_Element_Subtype (Def)); + Sem_Array_Element (Base_Type); + El_Type := Get_Element_Subtype (Base_Type); + Set_Element_Subtype (Def, El_Type); + + Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (Base_Type)); + + -- According to LRM93 §7.4.1, an unconstrained array type + -- is not static. + Set_Type_Staticness (Base_Type, None); + Set_Type_Staticness (Def, Min (Staticness, + Get_Type_Staticness (El_Type))); + + 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_Subtype_Type_Mark (Def, Null_Iir); + return Def; + end Sem_Constrained_Array_Type_Definition; + + function Sem_Access_Type_Definition (Def: Iir) return Iir + is + D_Type : Iir; + begin + D_Type := Sem_Subtype_Indication + (Get_Designated_Subtype_Indication (Def), True); + Set_Designated_Subtype_Indication (Def, D_Type); + + D_Type := Get_Type_Of_Subtype_Indication (D_Type); + if D_Type /= Null_Iir then + case Get_Kind (D_Type) is + when Iir_Kind_Incomplete_Type_Definition => + Append_Element (Get_Incomplete_Type_List (D_Type), Def); + when Iir_Kind_File_Type_Definition => + -- LRM 3.3 + -- The designated type must not be a file type. + Error_Msg_Sem ("designated type must not be a file type", Def); + when others => + null; + end case; + Set_Designated_Type (Def, D_Type); + end if; + Set_Base_Type (Def, Def); + Set_Type_Staticness (Def, None); + Set_Resolved_Flag (Def, False); + Set_Signal_Type_Flag (Def, False); + return Def; + end Sem_Access_Type_Definition; + + function Sem_File_Type_Definition (Def: Iir; Decl: Iir) return Iir + is + Type_Mark : Iir; + begin + Type_Mark := Sem_Type_Mark (Get_File_Type_Mark (Def)); + Set_File_Type_Mark (Def, Type_Mark); + + Type_Mark := Get_Type (Type_Mark); + + if Get_Kind (Type_Mark) = Iir_Kind_Error then + null; + elsif Get_Signal_Type_Flag (Type_Mark) = False then + -- LRM 3.4 + -- The base type of this subtype must not be a file type + -- or an access type. + -- If the base type is a composite type, it must not + -- contain a subelement of an access type. + Error_Msg_Sem + (Disp_Node (Type_Mark) & " cannot be a file type", Def); + elsif Get_Kind (Type_Mark) in Iir_Kinds_Array_Type_Definition then + -- LRM 3.4 + -- If the base type is an array type, it must be a one + -- dimensional array type. + if not Is_One_Dimensional_Array_Type (Type_Mark) then + Error_Msg_Sem + ("multi-dimensional " & Disp_Node (Type_Mark) + & " cannot be a file type", Def); + end if; + end if; + + Set_Base_Type (Def, Def); + Set_Resolved_Flag (Def, False); + Set_Text_File_Flag (Def, Is_Text_Type_Declaration (Decl)); + Set_Signal_Type_Flag (Def, False); + Set_Type_Staticness (Def, None); + return Def; + end Sem_File_Type_Definition; + + function Sem_Type_Definition (Def: Iir; Decl: Iir) return Iir is + begin + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition => + return Sem_Enumeration_Type_Definition (Def, Decl); + + when Iir_Kind_Range_Expression => + if Get_Type (Def) /= Null_Iir then + return Sem_Physical_Type_Definition (Def, Decl); + else + return Range_Expr_To_Type_Definition (Def, Decl); + end if; + + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Attribute_Name + | Iir_Kind_Parenthesis_Name => + if Get_Type (Def) /= Null_Iir then + return Sem_Physical_Type_Definition (Def, Decl); + end if; + -- Nb: the attribute is expected to be a 'range or + -- a 'reverse_range attribute. + declare + Res : Iir; + begin + Res := Sem_Discrete_Range_Expression (Def, Null_Iir, True); + if Res = Null_Iir then + return Null_Iir; + end if; + -- This cannot be a floating range. + return Create_Integer_Type (Def, Res, Decl); + end; + + when Iir_Kind_Array_Subtype_Definition => + return Sem_Constrained_Array_Type_Definition (Def, Decl); + + when Iir_Kind_Array_Type_Definition => + return Sem_Unbounded_Array_Type_Definition (Def); + + when Iir_Kind_Record_Type_Definition => + return Sem_Record_Type_Definition (Def); + + when Iir_Kind_Access_Type_Definition => + return Sem_Access_Type_Definition (Def); + + when Iir_Kind_File_Type_Definition => + return Sem_File_Type_Definition (Def, Decl); + + when Iir_Kind_Protected_Type_Declaration => + Sem_Protected_Type_Declaration (Decl); + return Def; + + when others => + Error_Kind ("sem_type_definition", Def); + return Def; + end case; + end Sem_Type_Definition; + + function Range_To_Subtype_Indication (A_Range: Iir) return Iir + is + Sub_Type: Iir; + Range_Type : Iir; + begin + case Get_Kind (A_Range) is + when Iir_Kind_Range_Expression + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + -- Create a sub type. + Range_Type := Get_Type (A_Range); + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return A_Range; + when Iir_Kinds_Discrete_Type_Definition => + -- A_RANGE is already a subtype definition. + return A_Range; + when others => + Error_Kind ("range_to_subtype_indication", A_Range); + return Null_Iir; + end case; + + case Get_Kind (Range_Type) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Sub_Type := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + Sub_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition); + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + Sub_Type := Create_Iir (Iir_Kind_Floating_Subtype_Definition); + when others => + raise Internal_Error; + end case; + Location_Copy (Sub_Type, A_Range); + Set_Range_Constraint (Sub_Type, A_Range); + Set_Base_Type (Sub_Type, Get_Base_Type (Range_Type)); + Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (A_Range)); + Set_Signal_Type_Flag (Sub_Type, True); + return Sub_Type; + end Range_To_Subtype_Indication; + + -- Return TRUE iff FUNC is a resolution function for ATYPE. + function Is_A_Resolution_Function (Func: Iir; Atype: Iir) return Boolean + is + Decl: Iir; + Decl_Type : Iir; + Ret_Type : Iir; + begin + -- LRM93 2.4 + -- A resolution function must be a [pure] function; + if Get_Kind (Func) not in Iir_Kinds_Function_Declaration then + return False; + end if; + Decl := Get_Interface_Declaration_Chain (Func); + -- LRM93 2.4 + -- moreover, it must have a single input parameter of class constant + if Decl = Null_Iir or else Get_Chain (Decl) /= Null_Iir then + return False; + end if; + if Get_Kind (Decl) /= Iir_Kind_Interface_Constant_Declaration then + return False; + end if; + -- LRM93 2.4 + -- that is a one-dimensional, unconstrained array + Decl_Type := Get_Type (Decl); + if Get_Kind (Decl_Type) /= Iir_Kind_Array_Type_Definition then + return False; + end if; + if not Is_One_Dimensional_Array_Type (Decl_Type) then + return False; + end if; + -- LRM93 2.4 + -- whose element type is that of the resolved signal. + -- The type of the return value of the function must also be that of + -- the signal. + Ret_Type := Get_Return_Type (Func); + if Get_Base_Type (Get_Element_Subtype (Decl_Type)) + /= Get_Base_Type (Ret_Type) + then + return False; + end if; + if Atype /= Null_Iir + and then Get_Base_Type (Ret_Type) /= Get_Base_Type (Atype) + then + return False; + end if; + -- LRM93 2.4 + -- A resolution function must be a [pure] function; + if Flags.Vhdl_Std >= Vhdl_93 and then Get_Pure_Flag (Func) = False then + if Atype /= Null_Iir then + Error_Msg_Sem + ("resolution " & Disp_Node (Func) & " must be pure", Atype); + end if; + return False; + end if; + return True; + end Is_A_Resolution_Function; + + -- Note: this sets resolved_flag. + procedure Sem_Resolution_Function (Name : Iir; Atype : Iir) + is + Func : Iir; + Res: Iir; + El : Iir; + List : Iir_List; + Has_Error : Boolean; + Name1 : Iir; + begin + Sem_Name (Name); + + Func := Get_Named_Entity (Name); + if Func = Error_Mark then + return; + end if; + + Res := Null_Iir; + + if Is_Overload_List (Func) then + List := Get_Overload_List (Func); + Has_Error := False; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + 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", + Atype); + Error_Msg_Sem ("candidate functions are:", Atype); + Error_Msg_Sem (" " & Disp_Subprg (Func), Func); + end if; + Error_Msg_Sem (" " & Disp_Subprg (El), El); + else + Res := El; + end if; + end if; + end loop; + Free_Overload_List (Func); + if Has_Error then + return; + end if; + Set_Named_Entity (Name, Res); + else + 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), Atype); + else + Name1 := Finish_Sem_Name (Name); + Mark_Subprogram_Used (Res); + Set_Resolved_Flag (Atype, True); + Set_Resolution_Indication (Atype, Name1); + end if; + end Sem_Resolution_Function; + + -- Analyze the constraint DEF + RESOLUTION for type TYPE_MARK. The + -- result is always a subtype definition. + function Sem_Subtype_Constraint + (Def : Iir; Type_Mark : Iir; Resolution : Iir) + return Iir; + + -- DEF is an incomplete subtype_indication or array_constraint, + -- TYPE_MARK is the base type of the subtype_indication. + function Sem_Array_Constraint + (Def : Iir; Type_Mark : Iir; Resolution : Iir) + return Iir + is + El_Type : constant Iir := Get_Element_Subtype (Type_Mark); + Res : Iir; + Type_Index, Subtype_Index: Iir; + Base_Type : Iir; + El_Def : 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; + Resolv_Ind : Iir; + begin + if Resolution /= Null_Iir then + -- A resolution indication is present. + case Get_Kind (Resolution) is + when Iir_Kinds_Denoting_Name => + Resolv_Func := Resolution; + when Iir_Kind_Array_Element_Resolution => + Resolv_El := Get_Resolution_Indication (Resolution); + when Iir_Kind_Record_Resolution => + Error_Msg_Sem + ("record resolution not allowed for array subtype", + Resolution); + when others => + Error_Kind ("sem_array_constraint(resolution)", Resolution); + end case; + end if; + + if Def = Null_Iir then + -- There is no element_constraint. + pragma Assert (Resolution /= Null_Iir); + 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 Copy_Subtype_Indication (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 + -- FIXME: is it reachable ? + Free_Name (Def); + return Type_Mark; + end if; + + Res := Copy_Subtype_Indication (Type_Mark); + Location_Copy (Res, Def); + Free_Name (Def); + + -- No element constraint. + El_Def := Null_Iir; + + 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); + El_Def := Get_Element_Subtype (Def); + + Staticness := Get_Type_Staticness (El_Type); + Error_Seen := False; + Type_Index_List := + Get_Index_Subtype_Definition_List (Base_Type); + Subtype_Index_List := Get_Index_Constraint_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; + if Subtype_Index_List = Null_Iir_List then + -- Array is not constrained. + Set_Index_Constraint_Flag (Def, False); + Set_Index_Subtype_List (Def, Type_Index_List); + else + 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; + else + Subtype_Index := Sem_Discrete_Range_Expression + (Subtype_Index, Get_Index_Type (Type_Index), True); + if Subtype_Index /= Null_Iir then + Subtype_Index := + Range_To_Subtype_Indication (Subtype_Index); + Staticness := Min + (Staticness, + Get_Type_Staticness + (Get_Type_Of_Subtype_Indication + (Subtype_Index))); + end if; + 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; + if Error_Seen then + Append_Element (Subtype_Index_List, Subtype_Index); + else + Replace_Nth_Element + (Subtype_Index_List, I, Subtype_Index); + end if; + end loop; + Set_Index_Subtype_List (Def, Subtype_Index_List); + Set_Index_Constraint_Flag (Def, True); + end if; + Set_Type_Staticness (Def, Staticness); + 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 or else El_Def /= Null_Iir then + El_Def := Sem_Subtype_Constraint (El_Def, El_Type, Resolv_El); + end if; + if El_Def = Null_Iir then + El_Def := Get_Element_Subtype (Type_Mark); + end if; + Set_Element_Subtype (Res, El_Def); + + Set_Constraint_State (Res, Get_Array_Constraint (Res)); + + if Resolv_Func /= Null_Iir then + Sem_Resolution_Function (Resolv_Func, Res); + elsif Resolv_El /= Null_Iir then + Set_Resolution_Indication (Res, Resolution); + -- FIXME: may a resolution indication for a record be incomplete ? + Set_Resolved_Flag (Res, Get_Resolved_Flag (El_Def)); + elsif Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition then + Resolv_Ind := Get_Resolution_Indication (Type_Mark); + if Resolv_Ind /= Null_Iir then + case Get_Kind (Resolv_Ind) is + when Iir_Kinds_Denoting_Name => + Error_Kind ("sem_array_constraint(resolution)", Resolv_Ind); + when Iir_Kind_Array_Element_Resolution => + -- Already applied to the element. + Resolv_Ind := Null_Iir; + when others => + Error_Kind ("sem_array_constraint(resolution2)", Resolv_Ind); + end case; + Set_Resolution_Indication (Res, Resolv_Ind); + end if; + Set_Resolved_Flag (Res, Get_Resolved_Flag (Type_Mark)); + end if; + + return Res; + end Sem_Array_Constraint; + + function Reparse_As_Record_Element_Constraint (Name : Iir) return Iir + is + Prefix : Iir; + Parent : Iir; + El : Iir; + begin + if Get_Kind (Name) /= Iir_Kind_Parenthesis_Name then + Error_Msg_Sem ("record element constraint expected", Name); + return Null_Iir; + else + 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; + + 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 + 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_Constraint_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; + + 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_Indication + (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, Get_Base_Type (Type_Mark)); + Set_Type_Staticness (Res, Get_Type_Staticness (Type_Mark)); + if Get_Kind (Type_Mark) = Iir_Kind_Record_Subtype_Definition then + Set_Resolution_Indication + (Res, Get_Resolution_Indication (Type_Mark)); + end if; + + case Get_Kind (Def) is + when Iir_Kind_Subtype_Definition => + 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_Constraint_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_record_constraint", Def); + end case; + + Res_List := Null_Iir_List; + if Resolution /= Null_Iir then + case Get_Kind (Resolution) is + when Iir_Kinds_Denoting_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; + + -- 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; + + -- 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 + 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; + 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; + + Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); + + if Resolution /= Null_Iir + and then Get_Kind (Resolution) in Iir_Kinds_Denoting_Name + then + Sem_Resolution_Function (Resolution, Res); + end if; + + return Res; + end Sem_Record_Constraint; + + -- Return a scalar subtype definition (even in case of error). + function Sem_Range_Constraint + (Def : Iir; Type_Mark : Iir; Resolution : Iir) + return Iir + is + Res : Iir; + A_Range : Iir; + Tolerance : Iir; + begin + if Def = Null_Iir then + Res := Copy_Subtype_Indication (Type_Mark); + elsif 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); + Res := Copy_Subtype_Indication (Type_Mark); + else + Tolerance := Get_Tolerance (Def); + + if Get_Range_Constraint (Def) = Null_Iir + and then Resolution = Null_Iir + and then Tolerance = 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_Resolution_Indication (Res, Get_Resolution_Indication (Def)); + A_Range := Get_Range_Constraint (Def); + if A_Range = Null_Iir then + A_Range := Get_Range_Constraint (Type_Mark); + else + A_Range := Sem_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)); + if Tolerance /= Null_Iir then + -- LRM93 4.2 Subtype declarations + -- It is an error in this case the subtype is not a nature + -- type + -- + -- FIXME: should be moved into sem_subtype_indication + if Get_Kind (Res) /= Iir_Kind_Floating_Subtype_Definition then + Error_Msg_Sem ("tolerance allowed only for floating subtype", + Tolerance); + else + -- LRM93 4.2 Subtype declarations + -- If the subtype indication includes a tolerance aspect, then + -- the string expression must be a static expression + Tolerance := Sem_Expression (Tolerance, String_Type_Definition); + if Tolerance /= Null_Iir + and then Get_Expr_Staticness (Tolerance) /= Locally + then + Error_Msg_Sem ("tolerance must be a static string", + Tolerance); + end if; + Set_Tolerance (Res, Tolerance); + end if; + end if; + end if; + + if Resolution /= Null_Iir then + -- LRM08 6.3 Subtype declarations. + if Get_Kind (Resolution) not in Iir_Kinds_Denoting_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 Resolution /= Null_Iir then + Error_Msg_Sem + ("resolution function not allowed for an access type", Def); + end if; + + case Get_Kind (Def) is + when Iir_Kind_Subtype_Definition => + Free_Name (Def); + return Copy_Subtype_Indication (Type_Mark); + when Iir_Kind_Array_Subtype_Definition => + -- LRM93 3.3 + -- The only form of constraint that is allowed after a name + -- of an access type in a subtype indication is an index + -- constraint. + declare + Sub_Type : Iir; + Base_Type : Iir; + Res : Iir; + begin + Base_Type := Get_Designated_Type (Type_Mark); + 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); + Set_Designated_Subtype_Indication (Res, Sub_Type); + Set_Signal_Type_Flag (Res, False); + return Res; + end; + when others => + raise Internal_Error; + end case; + + when Iir_Kind_File_Type_Definition => + -- 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; + end if; + Free_Name (Def); + return Type_Mark; + + when others => + Error_Kind ("sem_subtype_constraint", Type_Mark); + return Type_Mark; + end case; + end Sem_Subtype_Constraint; + + function Sem_Subtype_Indication (Def: Iir; Incomplete : Boolean := False) + return Iir + is + Type_Mark_Name : Iir; + Type_Mark: Iir; + Res : Iir; + begin + -- 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_Denoting_Name then + Type_Mark := Sem_Type_Mark (Def, Incomplete); + return Type_Mark; + end if; + + -- Semantize the type mark. + Type_Mark_Name := Get_Subtype_Type_Mark (Def); + Type_Mark_Name := Sem_Type_Mark (Type_Mark_Name); + Set_Subtype_Type_Mark (Def, Type_Mark_Name); + Type_Mark := Get_Type (Type_Mark_Name); + -- FIXME: incomplete type ? + if Get_Kind (Type_Mark) = Iir_Kind_Error then + -- FIXME: handle inversion such as "subtype BASETYPE RESOLV", which + -- should emit "resolution function must precede type name". + + -- Discard the subtype definition and only keep the type mark. + return Type_Mark_Name; + end if; + + Res := Sem_Subtype_Constraint + (Def, Type_Mark, Get_Resolution_Indication (Def)); + Set_Subtype_Type_Mark (Res, Type_Mark_Name); + return Res; + end Sem_Subtype_Indication; + + function Copy_Subtype_Indication (Def : Iir) return Iir + is + Res : Iir; + begin + 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 => + Res := Create_Iir (Get_Kind (Def)); + Set_Range_Constraint (Res, Get_Range_Constraint (Def)); + Set_Resolution_Indication + (Res, Get_Resolution_Indication (Def)); + when Iir_Kind_Enumeration_Type_Definition => + Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + 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); + Set_Designated_Type (Res, Get_Designated_Type (Def)); + + 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_Index_Constraint_List (Res, Null_Iir_List); + Set_Index_Subtype_List + (Res, Get_Index_Subtype_Definition_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_Indication (Res, Get_Resolution_Indication (Def)); + Set_Resolved_Flag (Res, Get_Resolved_Flag (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_Subtype_Definition then + Set_Resolution_Indication + (Res, Get_Resolution_Indication (Def)); + end if; + Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); + Set_Constraint_State (Res, Get_Constraint_State (Def)); + Set_Elements_Declaration_List + (Res, Get_Elements_Declaration_List (Def)); + when others => + -- FIXME: todo (protected type ?) + Error_Kind ("copy_subtype_indication", Def); + end case; + 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; + + function Sem_Subnature_Indication (Def: Iir) return Iir + is + Nature_Mark: Iir; + Res : Iir; + begin + -- LRM 4.8 Nature declatation + -- + -- If the subnature indication does not include a constraint, the + -- subnature is the same as that denoted by the type mark. + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + -- Used for reference declared by a nature + return Def; + when Iir_Kinds_Denoting_Name => + Nature_Mark := Sem_Denoting_Name (Def); + Res := Get_Named_Entity (Nature_Mark); + if Get_Kind (Res) /= Iir_Kind_Scalar_Nature_Definition then + Error_Class_Match (Nature_Mark, "nature"); + raise Program_Error; -- TODO + else + return Nature_Mark; + end if; + when others => + raise Program_Error; -- TODO + end case; + end Sem_Subnature_Indication; + +end Sem_Types; diff --git a/src/vhdl/sem_types.ads b/src/vhdl/sem_types.ads new file mode 100644 index 000000000..8eb7de108 --- /dev/null +++ b/src/vhdl/sem_types.ads @@ -0,0 +1,57 @@ +-- Semantic analysis. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +package Sem_Types is + -- Semantization of types (LRM93 3 / LRM08 5) + + -- Semantize subtype indication DEF. + -- If INCOMPLETE is TRUE, then DEF may designate an incomplete type + -- definition. Return either a name (denoting a type) or an anonymous + -- subtype definition. + function Sem_Subtype_Indication (Def: Iir; Incomplete : Boolean := False) + return Iir; + + procedure Sem_Protected_Type_Body (Bod : Iir); + + function Sem_Type_Definition (Def: Iir; Decl: Iir) return Iir; + + -- If A_RANGE is a range (range expression or range attribute), convert it + -- to a subtype definition. Otherwise return A_RANGE. + -- The result is a subtype indication: either a type name or a subtype + -- definition. + function Range_To_Subtype_Indication (A_Range: Iir) return Iir; + + -- ATYPE is used to declare a signal. + -- Set (recursively) the Has_Signal_Flag on ATYPE and all types used by + -- ATYPE (basetype, elements...) + -- If ATYPE can have signal (eg: access or file type), then this procedure + -- returns silently. + procedure Set_Type_Has_Signal (Atype : Iir); + + -- Return TRUE iff FUNC is a resolution function. + -- 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; + + -- Although a nature is not a type, it is patterned like a type. + function Sem_Subnature_Indication (Def: Iir) return Iir; +end Sem_Types; diff --git a/src/vhdl/std_package.adb b/src/vhdl/std_package.adb new file mode 100644 index 000000000..1edfb6cda --- /dev/null +++ b/src/vhdl/std_package.adb @@ -0,0 +1,1200 @@ +-- std.standard package declarations. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Files_Map; +with Name_Table; +with Str_Table; +with Std_Names; use Std_Names; +with Flags; use Flags; +with Iirs_Utils; +with Sem; +with Sem_Decls; +with Iir_Chains; + +package body Std_Package is + type Bound_Array is array (Boolean) of Iir_Int64; + Low_Bound : constant Bound_Array := (False => -(2 ** 31), + True => -(2 ** 63)); + High_Bound : constant Bound_Array := (False => (2 ** 31) - 1, + True => (2 ** 63) - 1); + + Std_Location: Location_Type := Location_Nil; + Std_Filename : Name_Id := Null_Identifier; + + function Create_Std_Iir (Kind : Iir_Kind) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Kind); + Set_Location (Res, Std_Location); + return Res; + end Create_Std_Iir; + + function Create_Std_Decl (Kind : Iir_Kind) return Iir + is + Res : Iir; + begin + Res := Create_Std_Iir (Kind); + Set_Parent (Res, Standard_Package); + return Res; + end Create_Std_Decl; + + function Create_Std_Type_Mark (Ref : Iir) return Iir + is + Res : Iir; + begin + Res := Iirs_Utils.Build_Simple_Name (Ref, Std_Location); + Set_Type (Res, Get_Type (Ref)); + return Res; + end Create_Std_Type_Mark; + + procedure Create_First_Nodes + is + begin + Std_Filename := Name_Table.Get_Identifier ("*std_standard*"); + Std_Location := Files_Map.Source_File_To_Location + (Files_Map.Create_Virtual_Source_File (Std_Filename)); + + if Create_Iir_Error /= Error_Mark then + raise Internal_Error; + end if; + Set_Location (Error_Mark, Std_Location); + + if Create_Std_Iir (Iir_Kind_Integer_Type_Definition) + /= Universal_Integer_Type_Definition + then + raise Internal_Error; + end if; + + if Create_Std_Iir (Iir_Kind_Floating_Type_Definition) + /= Universal_Real_Type_Definition + then + raise Internal_Error; + end if; + + if Create_Std_Iir (Iir_Kind_Integer_Type_Definition) + /= Convertible_Integer_Type_Definition + then + raise Internal_Error; + end if; + + if Create_Std_Iir (Iir_Kind_Floating_Type_Definition) + /= Convertible_Real_Type_Definition + then + raise Internal_Error; + end if; + end Create_First_Nodes; + + procedure Create_Std_Standard_Package (Parent : Iir_Library_Declaration) + is + function Get_Std_Character (Char: Character) return Name_Id + renames Name_Table.Get_Identifier; + + procedure Set_Std_Identifier (Decl : Iir; Name : Name_Id) is + begin + Set_Identifier (Decl, Name); + Set_Visible_Flag (Decl, True); + end Set_Std_Identifier; + + function Create_Std_Integer (Val : Iir_Int64; Lit_Type : Iir) + return Iir_Integer_Literal + is + Res : Iir_Integer_Literal; + begin + Res := Create_Std_Iir (Iir_Kind_Integer_Literal); + Set_Value (Res, Val); + Set_Type (Res, Lit_Type); + Set_Expr_Staticness (Res, Locally); + return Res; + end Create_Std_Integer; + + function Create_Std_Fp (Val : Iir_Fp64; Lit_Type : Iir) + return Iir_Floating_Point_Literal + is + Res : Iir_Floating_Point_Literal; + begin + Res := Create_Std_Iir (Iir_Kind_Floating_Point_Literal); + Set_Fp_Value (Res, Val); + Set_Type (Res, Lit_Type); + Set_Expr_Staticness (Res, Locally); + return Res; + end Create_Std_Fp; + + function Create_Std_Range_Expr (Left, Right : Iir; Rtype : Iir) + return Iir + is + Res : Iir; + begin + Res := Create_Std_Iir (Iir_Kind_Range_Expression); + Set_Left_Limit (Res, Left); + Set_Direction (Res, Iir_To); + Set_Right_Limit (Res, Right); + Set_Expr_Staticness (Res, Locally); + Set_Type (Res, Rtype); + return Res; + end Create_Std_Range_Expr; + + function Create_Std_Literal + (Name : Name_Id; Sub_Type : Iir_Enumeration_Type_Definition) + return Iir_Enumeration_Literal + is + Res : Iir_Enumeration_Literal; + List : Iir_List; + begin + Res := Create_Std_Decl (Iir_Kind_Enumeration_Literal); + List := Get_Enumeration_Literal_List (Sub_Type); + Set_Std_Identifier (Res, Name); + Set_Type (Res, Sub_Type); + Set_Expr_Staticness (Res, Locally); + Set_Name_Staticness (Res, Locally); + Set_Enumeration_Decl (Res, Res); + Set_Enum_Pos (Res, Iir_Int32 (Get_Nbr_Elements (List))); + Sem.Compute_Subprogram_Hash (Res); + Append_Element (List, Res); + return Res; + end Create_Std_Literal; + + -- Append a declaration DECL to Standard_Package. + Last_Decl : Iir := Null_Iir; + procedure Add_Decl (Decl : Iir) is + begin + if Last_Decl = Null_Iir then + Set_Declaration_Chain (Standard_Package, Decl); + else + Set_Chain (Last_Decl, Decl); + end if; + Last_Decl := Decl; + end Add_Decl; + + procedure Add_Implicit_Operations (Decl : Iir) + is + Nxt : Iir; + begin + Sem_Decls.Create_Implicit_Operations (Decl, True); + loop + Nxt := Get_Chain (Last_Decl); + exit when Nxt = Null_Iir; + Last_Decl := Nxt; + end loop; + end Add_Implicit_Operations; + + procedure Create_Std_Type (Decl : out Iir; + Def : Iir; + Name : Name_Id) + is + begin + Decl := Create_Std_Decl (Iir_Kind_Type_Declaration); + Set_Std_Identifier (Decl, Name); + Set_Type_Definition (Decl, Def); + Add_Decl (Decl); + Set_Type_Declarator (Def, Decl); + end Create_Std_Type; + + procedure Create_Integer_Type (Type_Definition : Iir; + Type_Decl : out Iir; + Type_Name : Name_Id) + is + begin + --Integer_Type_Definition := + -- Create_Std_Iir (Iir_Kind_Integer_Type_Definition); + Set_Base_Type (Type_Definition, Type_Definition); + Set_Type_Staticness (Type_Definition, Locally); + Set_Signal_Type_Flag (Type_Definition, True); + Set_Has_Signal_Flag (Type_Definition, not Flags.Flag_Whole_Analyze); + + Type_Decl := Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration); + Set_Identifier (Type_Decl, Type_Name); + Set_Type_Definition (Type_Decl, Type_Definition); + Set_Type_Declarator (Type_Definition, Type_Decl); + end Create_Integer_Type; + + procedure Create_Integer_Subtype (Type_Definition : Iir; + Type_Decl : Iir; + Subtype_Definition : out Iir; + Subtype_Decl : out Iir) + is + Constraint : Iir; + begin + Subtype_Definition := + Create_Std_Iir (Iir_Kind_Integer_Subtype_Definition); + Set_Base_Type (Subtype_Definition, Type_Definition); + Constraint := Create_Std_Range_Expr + (Create_Std_Integer (Low_Bound (Flags.Flag_Integer_64), + Universal_Integer_Type_Definition), + Create_Std_Integer (High_Bound (Flags.Flag_Integer_64), + Universal_Integer_Type_Definition), + Universal_Integer_Type_Definition); + Set_Range_Constraint (Subtype_Definition, Constraint); + Set_Type_Staticness (Subtype_Definition, Locally); + Set_Signal_Type_Flag (Subtype_Definition, True); + Set_Has_Signal_Flag (Subtype_Definition, + not Flags.Flag_Whole_Analyze); + + -- subtype is + Subtype_Decl := Create_Std_Decl (Iir_Kind_Subtype_Declaration); + Set_Std_Identifier (Subtype_Decl, Get_Identifier (Type_Decl)); + Set_Type (Subtype_Decl, Subtype_Definition); + Set_Type_Declarator (Subtype_Definition, Subtype_Decl); + Set_Subtype_Definition (Type_Decl, Subtype_Definition); + end Create_Integer_Subtype; + + -- Create an array of EL_TYPE, indexed by Natural. + procedure Create_Array_Type + (Def : out Iir; Decl : out Iir; El_Decl : Iir; Name : Name_Id) + is + Index_List : Iir_List; + Index : Iir; + Element : Iir; + begin + Element := Create_Std_Type_Mark (El_Decl); + Index := Create_Std_Type_Mark (Natural_Subtype_Declaration); + + Def := Create_Std_Iir (Iir_Kind_Array_Type_Definition); + Set_Base_Type (Def, Def); + + Index_List := Create_Iir_List; + Set_Index_Subtype_Definition_List (Def, Index_List); + Set_Index_Subtype_List (Def, Index_List); + Append_Element (Index_List, Index); + + Set_Element_Subtype_Indication (Def, Element); + Set_Element_Subtype (Def, Get_Type (El_Decl)); + Set_Type_Staticness (Def, None); + Set_Signal_Type_Flag (Def, True); + Set_Has_Signal_Flag (Def, not Flags.Flag_Whole_Analyze); + + Create_Std_Type (Decl, Def, Name); + + Add_Implicit_Operations (Decl); + end Create_Array_Type; + + -- Create: + -- function TO_STRING (VALUE: inter_type) return STRING; + procedure Create_To_String (Inter_Type : Iir; + Imp : Iir_Predefined_Functions; + Name : Name_Id := Std_Names.Name_To_String; + Inter2_Id : Name_Id := Null_Identifier; + Inter2_Type : Iir := Null_Iir) + is + Decl : Iir_Implicit_Function_Declaration; + Inter : Iir_Interface_Constant_Declaration; + Inter2 : Iir_Interface_Constant_Declaration; + begin + Decl := Create_Std_Decl (Iir_Kind_Implicit_Function_Declaration); + Set_Std_Identifier (Decl, Name); + Set_Return_Type (Decl, String_Type_Definition); + Set_Pure_Flag (Decl, True); + Set_Implicit_Definition (Decl, Imp); + + Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); + Set_Identifier (Inter, Std_Names.Name_Value); + Set_Type (Inter, Inter_Type); + Set_Mode (Inter, Iir_In_Mode); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + Set_Interface_Declaration_Chain (Decl, Inter); + + if Inter2_Id /= Null_Identifier then + Inter2 := Create_Iir (Iir_Kind_Interface_Constant_Declaration); + Set_Identifier (Inter2, Inter2_Id); + Set_Type (Inter2, Inter2_Type); + Set_Mode (Inter2, Iir_In_Mode); + Set_Lexical_Layout (Inter2, Iir_Lexical_Has_Type); + Set_Chain (Inter, Inter2); + end if; + + Sem.Compute_Subprogram_Hash (Decl); + Add_Decl (Decl); + end Create_To_String; + + -- Create: + -- function NAME (signal S : I inter_type) return BOOLEAN; + procedure Create_Edge_Function + (Name : Name_Id; Func : Iir_Predefined_Functions; Inter_Type : Iir) + is + Decl : Iir_Implicit_Function_Declaration; + Inter : Iir_Interface_Constant_Declaration; + begin + Decl := Create_Std_Decl (Iir_Kind_Implicit_Function_Declaration); + Set_Std_Identifier (Decl, Name); + Set_Return_Type (Decl, Boolean_Type_Definition); + Set_Pure_Flag (Decl, True); + Set_Implicit_Definition (Decl, Func); + + Inter := Create_Iir (Iir_Kind_Interface_Signal_Declaration); + Set_Identifier (Inter, Std_Names.Name_S); + Set_Type (Inter, Inter_Type); + Set_Mode (Inter, Iir_In_Mode); + Set_Interface_Declaration_Chain (Decl, Inter); + Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type); + + Sem.Compute_Subprogram_Hash (Decl); + Add_Decl (Decl); + end Create_Edge_Function; + + begin + -- Create design file. + Std_Standard_File := Create_Std_Iir (Iir_Kind_Design_File); + Set_Parent (Std_Standard_File, Parent); + Set_Design_File_Filename (Std_Standard_File, Std_Filename); + + declare + use Str_Table; + Std_Time_Stamp : constant Time_Stamp_String := + "20020601000000.000"; + Id : Time_Stamp_Id; + begin + Id := Time_Stamp_Id (Str_Table.Start); + for I in Time_Stamp_String'Range loop + Str_Table.Append (Std_Time_Stamp (I)); + end loop; + Str_Table.Finish; + Set_Analysis_Time_Stamp (Std_Standard_File, Id); + end; + + -- Create design unit. + Std_Standard_Unit := Create_Std_Iir (Iir_Kind_Design_Unit); + Set_Identifier (Std_Standard_Unit, Name_Standard); + Set_First_Design_Unit (Std_Standard_File, Std_Standard_Unit); + Set_Last_Design_Unit (Std_Standard_File, Std_Standard_Unit); + Set_Design_File (Std_Standard_Unit, Std_Standard_File); + Set_Date_State (Std_Standard_Unit, Date_Analyze); + Set_Dependence_List (Std_Standard_Unit, Create_Iir_List); + + Set_Date (Std_Standard_Unit, Date_Valid'First); + + -- Adding "package STANDARD is" + Standard_Package := Create_Std_Iir (Iir_Kind_Package_Declaration); + Set_Std_Identifier (Standard_Package, Name_Standard); + Set_Need_Body (Standard_Package, False); + + Set_Library_Unit (Std_Standard_Unit, Standard_Package); + Set_Design_Unit (Standard_Package, Std_Standard_Unit); + + -- boolean + begin + -- (false, true) + Boolean_Type_Definition := + Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition); + Set_Base_Type (Boolean_Type_Definition, Boolean_Type_Definition); + Set_Enumeration_Literal_List + (Boolean_Type_Definition, Create_Iir_List); + Boolean_False := Create_Std_Literal + (Name_False, Boolean_Type_Definition); + Boolean_True := Create_Std_Literal + (Name_True, Boolean_Type_Definition); + Set_Type_Staticness (Boolean_Type_Definition, Locally); + Set_Signal_Type_Flag (Boolean_Type_Definition, True); + Set_Has_Signal_Flag (Boolean_Type_Definition, + not Flags.Flag_Whole_Analyze); + + -- type boolean is + Create_Std_Type (Boolean_Type_Declaration, Boolean_Type_Definition, + Name_Boolean); + + Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type + (Boolean_Type_Definition); + Add_Implicit_Operations (Boolean_Type_Declaration); + end; + + if Vhdl_Std >= Vhdl_08 then + -- Rising_Edge and Falling_Edge + Create_Edge_Function + (Std_Names.Name_Rising_Edge, Iir_Predefined_Boolean_Rising_Edge, + Boolean_Type_Definition); + Create_Edge_Function + (Std_Names.Name_Falling_Edge, Iir_Predefined_Boolean_Falling_Edge, + Boolean_Type_Definition); + end if; + + -- bit. + begin + -- ('0', '1') + Bit_Type_Definition := + Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition); + Set_Enumeration_Literal_List + (Bit_Type_Definition, Create_Iir_List); + Set_Base_Type (Bit_Type_Definition, Bit_Type_Definition); + Bit_0 := Create_Std_Literal + (Get_Std_Character ('0'), Bit_Type_Definition); + Bit_1 := Create_Std_Literal + (Get_Std_Character ('1'), Bit_Type_Definition); + Set_Type_Staticness (Bit_Type_Definition, Locally); + 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 + Create_Std_Type (Bit_Type_Declaration, Bit_Type_Definition, Name_Bit); + + Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type + (Bit_Type_Definition); + Add_Implicit_Operations (Bit_Type_Declaration); + end; + + if Vhdl_Std >= Vhdl_08 then + -- Rising_Edge and Falling_Edge + Create_Edge_Function + (Std_Names.Name_Rising_Edge, Iir_Predefined_Bit_Rising_Edge, + Bit_Type_Definition); + Create_Edge_Function + (Std_Names.Name_Falling_Edge, Iir_Predefined_Bit_Falling_Edge, + Bit_Type_Definition); + end if; + + -- characters. + declare + El: Iir; + pragma Unreferenced (El); + begin + Character_Type_Definition := + Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition); + Set_Base_Type (Character_Type_Definition, Character_Type_Definition); + Set_Enumeration_Literal_List + (Character_Type_Definition, Create_Iir_List); + + for I in Name_Nul .. Name_Usp loop + El := Create_Std_Literal (I, Character_Type_Definition); + end loop; + for I in Character'(' ') .. Character'('~') loop + El := Create_Std_Literal + (Get_Std_Character (I), Character_Type_Definition); + end loop; + El := Create_Std_Literal (Name_Del, Character_Type_Definition); + if Vhdl_Std /= Vhdl_87 then + for I in Name_C128 .. Name_C159 loop + El := Create_Std_Literal (I, Character_Type_Definition); + end loop; + for I in Character'Val (160) .. Character'Val (255) loop + El := Create_Std_Literal + (Get_Std_Character (I), Character_Type_Definition); + end loop; + end if; + Set_Type_Staticness (Character_Type_Definition, Locally); + Set_Signal_Type_Flag (Character_Type_Definition, True); + Set_Has_Signal_Flag (Character_Type_Definition, + not Flags.Flag_Whole_Analyze); + + -- type character is + Create_Std_Type + (Character_Type_Declaration, Character_Type_Definition, + Name_Character); + + Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type + (Character_Type_Definition); + Add_Implicit_Operations (Character_Type_Declaration); + end; + + -- severity level. + begin + -- (note, warning, error, failure) + Severity_Level_Type_Definition := + Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition); + Set_Base_Type (Severity_Level_Type_Definition, + Severity_Level_Type_Definition); + Set_Enumeration_Literal_List + (Severity_Level_Type_Definition, Create_Iir_List); + + Severity_Level_Note := Create_Std_Literal + (Name_Note, Severity_Level_Type_Definition); + Severity_Level_Warning := Create_Std_Literal + (Name_Warning, Severity_Level_Type_Definition); + Severity_Level_Error := Create_Std_Literal + (Name_Error, Severity_Level_Type_Definition); + Severity_Level_Failure := Create_Std_Literal + (Name_Failure, Severity_Level_Type_Definition); + Set_Type_Staticness (Severity_Level_Type_Definition, Locally); + Set_Signal_Type_Flag (Severity_Level_Type_Definition, True); + Set_Has_Signal_Flag (Severity_Level_Type_Definition, + not Flags.Flag_Whole_Analyze); + + -- type severity_level is + Create_Std_Type + (Severity_Level_Type_Declaration, Severity_Level_Type_Definition, + Name_Severity_Level); + + Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type + (Severity_Level_Type_Definition); + Add_Implicit_Operations (Severity_Level_Type_Declaration); + end; + + -- universal integer + begin + Create_Integer_Type (Universal_Integer_Type_Definition, + Universal_Integer_Type_Declaration, + Name_Universal_Integer); + Add_Decl (Universal_Integer_Type_Declaration); + + Create_Integer_Subtype (Universal_Integer_Type_Definition, + Universal_Integer_Type_Declaration, + Universal_Integer_Subtype_Definition, + Universal_Integer_Subtype_Declaration); + + Add_Decl (Universal_Integer_Subtype_Declaration); + Set_Subtype_Definition (Universal_Integer_Type_Declaration, + Universal_Integer_Subtype_Definition); + + -- Do not create implicit operations yet, since "**" needs integer + -- type. + end; + + -- Universal integer constant 1. + Universal_Integer_One := + Create_Std_Integer (1, Universal_Integer_Type_Definition); + + -- Universal real. + declare + Constraint : Iir_Range_Expression; + begin + Set_Base_Type (Universal_Real_Type_Definition, + Universal_Real_Type_Definition); + Set_Type_Staticness (Universal_Real_Type_Definition, Locally); + Set_Signal_Type_Flag (Universal_Real_Type_Definition, True); + Set_Has_Signal_Flag (Universal_Real_Type_Definition, False); + + Universal_Real_Type_Declaration := + Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration); + Set_Identifier (Universal_Real_Type_Declaration, Name_Universal_Real); + Set_Type_Definition (Universal_Real_Type_Declaration, + Universal_Real_Type_Definition); + Set_Type_Declarator (Universal_Real_Type_Definition, + Universal_Real_Type_Declaration); + Add_Decl (Universal_Real_Type_Declaration); + + Universal_Real_Subtype_Definition := + Create_Std_Iir (Iir_Kind_Floating_Subtype_Definition); + Set_Base_Type (Universal_Real_Subtype_Definition, + Universal_Real_Type_Definition); + Constraint := Create_Std_Range_Expr + (Create_Std_Fp (Iir_Fp64'First, Universal_Real_Type_Definition), + Create_Std_Fp (Iir_Fp64'Last, Universal_Real_Type_Definition), + Universal_Real_Type_Definition); + Set_Range_Constraint (Universal_Real_Subtype_Definition, Constraint); + Set_Type_Staticness (Universal_Real_Subtype_Definition, Locally); + Set_Signal_Type_Flag (Universal_Real_Subtype_Definition, True); + Set_Has_Signal_Flag (Universal_Real_Subtype_Definition, False); + + -- type is + Universal_Real_Subtype_Declaration := + Create_Std_Decl (Iir_Kind_Subtype_Declaration); + Set_Identifier (Universal_Real_Subtype_Declaration, + Name_Universal_Real); + Set_Type (Universal_Real_Subtype_Declaration, + Universal_Real_Subtype_Definition); + Set_Type_Declarator (Universal_Real_Subtype_Definition, + Universal_Real_Subtype_Declaration); + Set_Subtype_Definition (Universal_Real_Type_Declaration, + Universal_Real_Subtype_Definition); + + Add_Decl (Universal_Real_Subtype_Declaration); + + -- Do not create implicit operations yet, since "**" needs integer + -- type. + end; + + -- Convertible type. + begin + Create_Integer_Type (Convertible_Integer_Type_Definition, + Convertible_Integer_Type_Declaration, + Name_Convertible_Integer); + Create_Integer_Subtype (Convertible_Integer_Type_Definition, + Convertible_Integer_Type_Declaration, + Convertible_Integer_Subtype_Definition, + Convertible_Integer_Subtype_Declaration); + + -- Not added in std.standard. + end; + + begin + Set_Base_Type (Convertible_Real_Type_Definition, + Convertible_Real_Type_Definition); + Set_Type_Staticness (Convertible_Real_Type_Definition, Locally); + Set_Signal_Type_Flag (Convertible_Real_Type_Definition, True); + Set_Has_Signal_Flag (Convertible_Real_Type_Definition, False); + + Convertible_Real_Type_Declaration := + Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration); + Set_Identifier (Convertible_Real_Type_Declaration, + Name_Convertible_Real); + Set_Type_Definition (Convertible_Real_Type_Declaration, + Convertible_Real_Type_Definition); + Set_Type_Declarator (Convertible_Real_Type_Definition, + Convertible_Real_Type_Declaration); + end; + + -- integer type. + begin + Integer_Type_Definition := + Create_Std_Iir (Iir_Kind_Integer_Type_Definition); + Create_Integer_Type (Integer_Type_Definition, + Integer_Type_Declaration, + Name_Integer); + Add_Decl (Integer_Type_Declaration); + + Add_Implicit_Operations (Integer_Type_Declaration); + Add_Implicit_Operations (Universal_Integer_Type_Declaration); + Add_Implicit_Operations (Universal_Real_Type_Declaration); + + Create_Integer_Subtype (Integer_Type_Definition, + Integer_Type_Declaration, + Integer_Subtype_Definition, + Integer_Subtype_Declaration); + Add_Decl (Integer_Subtype_Declaration); + end; + + -- Real type. + declare + Constraint : Iir_Range_Expression; + begin + Real_Type_Definition := + Create_Std_Iir (Iir_Kind_Floating_Type_Definition); + Set_Base_Type (Real_Type_Definition, Real_Type_Definition); + Set_Type_Staticness (Real_Type_Definition, Locally); + Set_Signal_Type_Flag (Real_Type_Definition, True); + Set_Has_Signal_Flag (Real_Type_Definition, + not Flags.Flag_Whole_Analyze); + + Real_Type_Declaration := + Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration); + Set_Identifier (Real_Type_Declaration, Name_Real); + Set_Type_Definition (Real_Type_Declaration, Real_Type_Definition); + Set_Type_Declarator (Real_Type_Definition, Real_Type_Declaration); + Add_Decl (Real_Type_Declaration); + + Add_Implicit_Operations (Real_Type_Declaration); + + Real_Subtype_Definition := + Create_Std_Iir (Iir_Kind_Floating_Subtype_Definition); + Set_Base_Type (Real_Subtype_Definition, Real_Type_Definition); + Constraint := Create_Std_Range_Expr + (Create_Std_Fp (Iir_Fp64'First, Universal_Real_Type_Definition), + Create_Std_Fp (Iir_Fp64'Last, Universal_Real_Type_Definition), + Universal_Real_Type_Definition); + Set_Range_Constraint (Real_Subtype_Definition, Constraint); + Set_Type_Staticness (Real_Subtype_Definition, Locally); + Set_Signal_Type_Flag (Real_Subtype_Definition, True); + Set_Has_Signal_Flag (Real_Subtype_Definition, + not Flags.Flag_Whole_Analyze); + + Real_Subtype_Declaration := + Create_Std_Decl (Iir_Kind_Subtype_Declaration); + Set_Std_Identifier (Real_Subtype_Declaration, Name_Real); + Set_Type (Real_Subtype_Declaration, Real_Subtype_Definition); + Set_Type_Declarator + (Real_Subtype_Definition, Real_Subtype_Declaration); + Add_Decl (Real_Subtype_Declaration); + + Set_Subtype_Definition + (Real_Type_Declaration, Real_Subtype_Definition); + end; + + -- time definition + declare + Time_Staticness : Iir_Staticness; + Last_Unit : Iir_Unit_Declaration; + use Iir_Chains.Unit_Chain_Handling; + + function Create_Std_Phys_Lit (Value : Iir_Int64; + Unit : Iir_Simple_Name) + return Iir_Physical_Int_Literal + is + Lit: Iir_Physical_Int_Literal; + begin + Lit := Create_Std_Iir (Iir_Kind_Physical_Int_Literal); + Set_Value (Lit, Value); + pragma Assert (Get_Kind (Unit) = Iir_Kind_Simple_Name); + Set_Unit_Name (Lit, Unit); + Set_Type (Lit, Time_Type_Definition); + Set_Expr_Staticness (Lit, Time_Staticness); + return Lit; + end Create_Std_Phys_Lit; + + procedure Create_Unit (Unit : out Iir_Unit_Declaration; + Multiplier_Value : Iir_Int64; + Multiplier : in Iir_Unit_Declaration; + Name : Name_Id) + is + Lit: Iir_Physical_Int_Literal; + Mul_Name : Iir; + begin + Unit := Create_Std_Decl (Iir_Kind_Unit_Declaration); + Set_Std_Identifier (Unit, Name); + Set_Type (Unit, Time_Type_Definition); + + Mul_Name := Iirs_Utils.Build_Simple_Name + (Multiplier, Std_Location); + Lit := Create_Std_Phys_Lit (Multiplier_Value, Mul_Name); + Set_Physical_Literal (Unit, Lit); + Lit := Create_Std_Phys_Lit + (Multiplier_Value + * Get_Value (Get_Physical_Unit_Value (Multiplier)), + Get_Unit_Name (Get_Physical_Unit_Value (Multiplier))); + Set_Physical_Unit_Value (Unit, Lit); + + Set_Expr_Staticness (Unit, Time_Staticness); + Set_Name_Staticness (Unit, Locally); + Append (Last_Unit, Time_Type_Definition, Unit); + end Create_Unit; + + Time_Fs_Name : Iir; + Time_Fs_Unit: Iir_Unit_Declaration; + Time_Ps_Unit: Iir_Unit_Declaration; + Time_Ns_Unit: Iir_Unit_Declaration; + Time_Us_Unit: Iir_Unit_Declaration; + Time_Ms_Unit: Iir_Unit_Declaration; + Time_Sec_Unit: Iir_Unit_Declaration; + Time_Min_Unit: Iir_Unit_Declaration; + Time_Hr_Unit: Iir_Unit_Declaration; + Constraint : Iir_Range_Expression; + begin + if Vhdl_Std >= Vhdl_93c then + Time_Staticness := Globally; + else + Time_Staticness := Locally; + end if; + + Time_Type_Definition := + Create_Std_Iir (Iir_Kind_Physical_Type_Definition); + Set_Base_Type (Time_Type_Definition, Time_Type_Definition); + Set_Type_Staticness (Time_Type_Definition, Locally);--Time_Staticness + Set_Signal_Type_Flag (Time_Type_Definition, True); + Set_Has_Signal_Flag (Time_Type_Definition, + not Flags.Flag_Whole_Analyze); + Set_End_Has_Reserved_Id (Time_Type_Definition, True); + + Build_Init (Last_Unit); + + Time_Fs_Unit := Create_Std_Decl (Iir_Kind_Unit_Declaration); + Set_Std_Identifier (Time_Fs_Unit, Name_Fs); + Set_Type (Time_Fs_Unit, Time_Type_Definition); + Set_Expr_Staticness (Time_Fs_Unit, Time_Staticness); + Set_Name_Staticness (Time_Fs_Unit, Locally); + Time_Fs_Name := Iirs_Utils.Build_Simple_Name + (Time_Fs_Unit, Std_Location); + Set_Physical_Unit_Value + (Time_Fs_Unit, Create_Std_Phys_Lit (1, Time_Fs_Name)); + Append (Last_Unit, Time_Type_Definition, Time_Fs_Unit); + + Create_Unit (Time_Ps_Unit, 1000, Time_Fs_Unit, Name_Ps); + Create_Unit (Time_Ns_Unit, 1000, Time_Ps_Unit, Name_Ns); + Create_Unit (Time_Us_Unit, 1000, Time_Ns_Unit, Name_Us); + Create_Unit (Time_Ms_Unit, 1000, Time_Us_Unit, Name_Ms); + Create_Unit (Time_Sec_Unit, 1000, Time_Ms_Unit, Name_Sec); + Create_Unit (Time_Min_Unit, 60, Time_Sec_Unit, Name_Min); + Create_Unit (Time_Hr_Unit, 60, Time_Min_Unit, Name_Hr); + + -- type is + Time_Type_Declaration := + Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration); + Set_Identifier (Time_Type_Declaration, Name_Time); + Set_Type_Definition (Time_Type_Declaration, Time_Type_Definition); + Set_Type_Declarator (Time_Type_Definition, Time_Type_Declaration); + Add_Decl (Time_Type_Declaration); + + Add_Implicit_Operations (Time_Type_Declaration); + + Time_Subtype_Definition := + Create_Std_Iir (Iir_Kind_Physical_Subtype_Definition); + Constraint := Create_Std_Range_Expr + (Create_Std_Phys_Lit (Low_Bound (Flags.Flag_Time_64), + Time_Fs_Name), + Create_Std_Phys_Lit (High_Bound (Flags.Flag_Time_64), + Time_Fs_Name), + Time_Type_Definition); + Set_Range_Constraint (Time_Subtype_Definition, Constraint); + Set_Base_Type (Time_Subtype_Definition, Time_Type_Definition); + --Set_Subtype_Type_Mark (Time_Subtype_Definition, + -- Time_Type_Definition); + Set_Type_Staticness (Time_Subtype_Definition, Time_Staticness); + Set_Signal_Type_Flag (Time_Subtype_Definition, True); + Set_Has_Signal_Flag (Time_Subtype_Definition, + not Flags.Flag_Whole_Analyze); + + -- subtype time is + Time_Subtype_Declaration := + Create_Std_Decl (Iir_Kind_Subtype_Declaration); + Set_Std_Identifier (Time_Subtype_Declaration, Name_Time); + Set_Type (Time_Subtype_Declaration, Time_Subtype_Definition); + Set_Type_Declarator (Time_Subtype_Definition, + Time_Subtype_Declaration); + Add_Decl (Time_Subtype_Declaration); + Set_Subtype_Definition + (Time_Type_Declaration, Time_Subtype_Definition); + + -- The default time base. + case Flags.Time_Resolution is + when 'f' => + Time_Base := Time_Fs_Unit; + when 'p' => + Time_Base := Time_Ps_Unit; + when 'n' => + Time_Base := Time_Ns_Unit; + when 'u' => + Time_Base := Time_Us_Unit; + when 'm' => + Time_Base := Time_Ms_Unit; + when 's' => + Time_Base := Time_Sec_Unit; + when 'M' => + Time_Base := Time_Min_Unit; + when 'h' => + Time_Base := Time_Hr_Unit; + when others => + raise Internal_Error; + end case; + + -- VHDL93 + -- subtype DELAY_LENGTH is TIME range 0 to TIME'HIGH + if Vhdl_Std >= Vhdl_93c then + Delay_Length_Subtype_Definition := + Create_Std_Iir (Iir_Kind_Physical_Subtype_Definition); + Set_Subtype_Type_Mark + (Delay_Length_Subtype_Definition, + Create_Std_Type_Mark (Time_Subtype_Declaration)); + Constraint := Create_Std_Range_Expr + (Create_Std_Phys_Lit (0, Time_Fs_Name), + Create_Std_Phys_Lit (High_Bound (Flags.Flag_Time_64), + Time_Fs_Name), + Time_Type_Definition); + Set_Range_Constraint (Delay_Length_Subtype_Definition, Constraint); + Set_Base_Type + (Delay_Length_Subtype_Definition, Time_Type_Definition); + Set_Type_Staticness + (Delay_Length_Subtype_Definition, Time_Staticness); + Set_Signal_Type_Flag (Delay_Length_Subtype_Definition, True); + Set_Has_Signal_Flag (Delay_Length_Subtype_Definition, + not Flags.Flag_Whole_Analyze); + + -- subtype delay_length is ... + Delay_Length_Subtype_Declaration := + Create_Std_Decl (Iir_Kind_Subtype_Declaration); + Set_Std_Identifier (Delay_Length_Subtype_Declaration, + Name_Delay_Length); + Set_Type (Delay_Length_Subtype_Declaration, + Delay_Length_Subtype_Definition); + Set_Type_Declarator (Delay_Length_Subtype_Definition, + Delay_Length_Subtype_Declaration); + Set_Subtype_Indication (Delay_Length_Subtype_Declaration, + Delay_Length_Subtype_Definition); + Add_Decl (Delay_Length_Subtype_Declaration); + else + Delay_Length_Subtype_Definition := Null_Iir; + Delay_Length_Subtype_Declaration := Null_Iir; + end if; + end; + + -- VHDL87: + -- function NOW return TIME + -- + -- impure function NOW return DELAY_LENGTH. + declare + Function_Now : Iir_Implicit_Function_Declaration; + begin + Function_Now := + Create_Std_Decl (Iir_Kind_Implicit_Function_Declaration); + Set_Std_Identifier (Function_Now, Std_Names.Name_Now); + if Vhdl_Std = Vhdl_87 then + Set_Return_Type (Function_Now, Time_Subtype_Definition); + else + Set_Return_Type (Function_Now, Delay_Length_Subtype_Definition); + end if; + if Vhdl_Std = Vhdl_02 then + Set_Pure_Flag (Function_Now, True); + else + Set_Pure_Flag (Function_Now, False); + end if; + Set_Implicit_Definition (Function_Now, Iir_Predefined_Now_Function); + Sem.Compute_Subprogram_Hash (Function_Now); + Add_Decl (Function_Now); + end; + + -- natural subtype + declare + Constraint : Iir_Range_Expression; + begin + Natural_Subtype_Definition := + Create_Std_Iir (Iir_Kind_Integer_Subtype_Definition); + Set_Base_Type (Natural_Subtype_Definition, Integer_Type_Definition); + Set_Subtype_Type_Mark + (Natural_Subtype_Definition, + Create_Std_Type_Mark (Integer_Subtype_Declaration)); + Constraint := Create_Std_Range_Expr + (Create_Std_Integer (0, Integer_Type_Definition), + Create_Std_Integer (High_Bound (Flags.Flag_Integer_64), + Integer_Type_Definition), + Integer_Type_Definition); + Set_Range_Constraint (Natural_Subtype_Definition, Constraint); + Set_Type_Staticness (Natural_Subtype_Definition, Locally); + Set_Signal_Type_Flag (Natural_Subtype_Definition, True); + Set_Has_Signal_Flag (Natural_Subtype_Definition, + not Flags.Flag_Whole_Analyze); + + Natural_Subtype_Declaration := + Create_Std_Decl (Iir_Kind_Subtype_Declaration); + Set_Std_Identifier (Natural_Subtype_Declaration, Name_Natural); + Set_Type (Natural_Subtype_Declaration, Natural_Subtype_Definition); + Set_Subtype_Indication (Natural_Subtype_Declaration, + Natural_Subtype_Definition); + Add_Decl (Natural_Subtype_Declaration); + Set_Type_Declarator (Natural_Subtype_Definition, + Natural_Subtype_Declaration); + end; + + -- positive subtype + declare + Constraint : Iir_Range_Expression; + begin + Positive_Subtype_Definition := + Create_Std_Iir (Iir_Kind_Integer_Subtype_Definition); + Set_Base_Type (Positive_Subtype_Definition, + Integer_Type_Definition); + Set_Subtype_Type_Mark + (Positive_Subtype_Definition, + Create_Std_Type_Mark (Integer_Subtype_Declaration)); + Constraint := Create_Std_Range_Expr + (Create_Std_Integer (1, Integer_Type_Definition), + Create_Std_Integer (High_Bound (Flags.Flag_Integer_64), + Integer_Type_Definition), + Integer_Type_Definition); + Set_Range_Constraint (Positive_Subtype_Definition, Constraint); + Set_Type_Staticness (Positive_Subtype_Definition, Locally); + Set_Signal_Type_Flag (Positive_Subtype_Definition, True); + Set_Has_Signal_Flag (Positive_Subtype_Definition, + not Flags.Flag_Whole_Analyze); + + Positive_Subtype_Declaration := + Create_Std_Decl (Iir_Kind_Subtype_Declaration); + Set_Std_Identifier (Positive_Subtype_Declaration, Name_Positive); + Set_Type (Positive_Subtype_Declaration, Positive_Subtype_Definition); + Set_Subtype_Indication (Positive_Subtype_Declaration, + Positive_Subtype_Definition); + Add_Decl (Positive_Subtype_Declaration); + Set_Type_Declarator (Positive_Subtype_Definition, + Positive_Subtype_Declaration); + end; + + -- string type. + -- type string is array (positive range <>) of character; + declare + Element : Iir; + Index_List : Iir_List; + begin + Element := Create_Std_Type_Mark (Character_Type_Declaration); + + String_Type_Definition := + Create_Std_Iir (Iir_Kind_Array_Type_Definition); + Set_Base_Type (String_Type_Definition, String_Type_Definition); + Index_List := Create_Iir_List; + Append_Element (Index_List, + Create_Std_Type_Mark (Positive_Subtype_Declaration)); + Set_Index_Subtype_Definition_List (String_Type_Definition, + Index_List); + Set_Index_Subtype_List (String_Type_Definition, Index_List); + Set_Element_Subtype_Indication (String_Type_Definition, Element); + Set_Element_Subtype (String_Type_Definition, + Character_Type_Definition); + Set_Type_Staticness (String_Type_Definition, None); + Set_Signal_Type_Flag (String_Type_Definition, True); + Set_Has_Signal_Flag (String_Type_Definition, + not Flags.Flag_Whole_Analyze); + + Create_Std_Type + (String_Type_Declaration, String_Type_Definition, Name_String); + + Add_Implicit_Operations (String_Type_Declaration); + end; + + if Vhdl_Std >= Vhdl_08 then + -- type Boolean_Vector is array (Natural range <>) of Boolean; + Create_Array_Type + (Boolean_Vector_Type_Definition, Boolean_Vector_Type_Declaration, + Boolean_Type_Declaration, Name_Boolean_Vector); + end if; + + -- bit_vector type. + -- type bit_vector is array (natural range <>) of bit; + Create_Array_Type + (Bit_Vector_Type_Definition, Bit_Vector_Type_Declaration, + Bit_Type_Declaration, Name_Bit_Vector); + + -- LRM08 5.3.2.4 Predefined operations on array types + -- The following operations are implicitly declared in package + -- STD.STANDARD immediately following the declaration of type + -- BIT_VECTOR: + if Vhdl_Std >= Vhdl_08 then + Create_To_String (Bit_Vector_Type_Definition, + Iir_Predefined_Bit_Vector_To_Ostring, + Name_To_Ostring); + Create_To_String (Bit_Vector_Type_Definition, + Iir_Predefined_Bit_Vector_To_Hstring, + Name_To_Hstring); + end if; + + -- VHDL 2008 + -- Vector types + if Vhdl_Std >= Vhdl_08 then + -- type integer_vector is array (natural range <>) of Integer; + Create_Array_Type + (Integer_Vector_Type_Definition, Integer_Vector_Type_Declaration, + Integer_Subtype_Declaration, Name_Integer_Vector); + + -- type Real_vector is array (natural range <>) of Real; + Create_Array_Type + (Real_Vector_Type_Definition, Real_Vector_Type_Declaration, + Real_Subtype_Declaration, Name_Real_Vector); + + -- type Time_vector is array (natural range <>) of Time; + Create_Array_Type + (Time_Vector_Type_Definition, Time_Vector_Type_Declaration, + Time_Subtype_Declaration, Name_Time_Vector); + end if; + + -- VHDL93: + -- type file_open_kind is (read_mode, write_mode, append_mode); + if Vhdl_Std >= Vhdl_93c then + File_Open_Kind_Type_Definition := + Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition); + Set_Base_Type (File_Open_Kind_Type_Definition, + File_Open_Kind_Type_Definition); + Set_Enumeration_Literal_List + (File_Open_Kind_Type_Definition, Create_Iir_List); + + File_Open_Kind_Read_Mode := Create_Std_Literal + (Name_Read_Mode, File_Open_Kind_Type_Definition); + File_Open_Kind_Write_Mode := Create_Std_Literal + (Name_Write_Mode, File_Open_Kind_Type_Definition); + File_Open_Kind_Append_Mode := Create_Std_Literal + (Name_Append_Mode, File_Open_Kind_Type_Definition); + Set_Type_Staticness (File_Open_Kind_Type_Definition, Locally); + Set_Signal_Type_Flag (File_Open_Kind_Type_Definition, True); + Set_Has_Signal_Flag (File_Open_Kind_Type_Definition, + not Flags.Flag_Whole_Analyze); + + -- type file_open_kind is + Create_Std_Type + (File_Open_Kind_Type_Declaration, File_Open_Kind_Type_Definition, + Name_File_Open_Kind); + + Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type + (File_Open_Kind_Type_Definition); + Add_Implicit_Operations (File_Open_Kind_Type_Declaration); + else + File_Open_Kind_Type_Declaration := Null_Iir; + File_Open_Kind_Type_Definition := Null_Iir; + File_Open_Kind_Read_Mode := Null_Iir; + File_Open_Kind_Write_Mode := Null_Iir; + File_Open_Kind_Append_Mode := Null_Iir; + end if; + + -- VHDL93: + -- type file_open_status is + -- (open_ok, status_error, name_error, mode_error); + if Vhdl_Std >= Vhdl_93c then + File_Open_Status_Type_Definition := + Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition); + Set_Base_Type (File_Open_Status_Type_Definition, + File_Open_Status_Type_Definition); + Set_Enumeration_Literal_List + (File_Open_Status_Type_Definition, Create_Iir_List); + + File_Open_Status_Open_Ok := Create_Std_Literal + (Name_Open_Ok, File_Open_Status_Type_Definition); + File_Open_Status_Status_Error := Create_Std_Literal + (Name_Status_Error, File_Open_Status_Type_Definition); + File_Open_Status_Name_Error := Create_Std_Literal + (Name_Name_Error, File_Open_Status_Type_Definition); + File_Open_Status_Mode_Error := Create_Std_Literal + (Name_Mode_Error, File_Open_Status_Type_Definition); + Set_Type_Staticness (File_Open_Status_Type_Definition, Locally); + Set_Signal_Type_Flag (File_Open_Status_Type_Definition, True); + Set_Has_Signal_Flag (File_Open_Status_Type_Definition, + not Flags.Flag_Whole_Analyze); + + -- type file_open_kind is + Create_Std_Type (File_Open_Status_Type_Declaration, + File_Open_Status_Type_Definition, + Name_File_Open_Status); + Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type + (File_Open_Status_Type_Definition); + Add_Implicit_Operations (File_Open_Status_Type_Declaration); + else + File_Open_Status_Type_Declaration := Null_Iir; + File_Open_Status_Type_Definition := Null_Iir; + File_Open_Status_Open_Ok := Null_Iir; + File_Open_Status_Status_Error := Null_Iir; + File_Open_Status_Name_Error := Null_Iir; + File_Open_Status_Mode_Error := Null_Iir; + end if; + + -- VHDL93: + -- attribute FOREIGN: string; + if Vhdl_Std >= Vhdl_93c then + Foreign_Attribute := Create_Std_Decl (Iir_Kind_Attribute_Declaration); + Set_Std_Identifier (Foreign_Attribute, Name_Foreign); + Set_Type_Mark (Foreign_Attribute, + Create_Std_Type_Mark (String_Type_Declaration)); + Set_Type (Foreign_Attribute, String_Type_Definition); + Add_Decl (Foreign_Attribute); + else + Foreign_Attribute := Null_Iir; + end if; + + if Vhdl_Std >= Vhdl_08 then + Create_To_String (Boolean_Type_Definition, + Iir_Predefined_Enum_To_String); + Create_To_String (Bit_Type_Definition, + Iir_Predefined_Enum_To_String); + Create_To_String (Character_Type_Definition, + Iir_Predefined_Enum_To_String); + Create_To_String (Severity_Level_Type_Definition, + Iir_Predefined_Enum_To_String); + Create_To_String (Universal_Integer_Type_Definition, + Iir_Predefined_Integer_To_String); + Create_To_String (Universal_Real_Type_Definition, + Iir_Predefined_Floating_To_String); + Create_To_String (Integer_Type_Definition, + Iir_Predefined_Integer_To_String); + Create_To_String (Real_Type_Definition, + Iir_Predefined_Floating_To_String); + Create_To_String (Time_Type_Definition, + Iir_Predefined_Physical_To_String); + Create_To_String (File_Open_Kind_Type_Definition, + Iir_Predefined_Enum_To_String); + Create_To_String (File_Open_Status_Type_Definition, + Iir_Predefined_Enum_To_String); + + -- Predefined overload TO_STRING operations + Create_To_String (Real_Type_Definition, + Iir_Predefined_Real_To_String_Digits, + Name_To_String, + Name_Digits, + Natural_Subtype_Definition); + Create_To_String (Real_Type_Definition, + Iir_Predefined_Real_To_String_Format, + Name_To_String, + Name_Format, + String_Type_Definition); + Create_To_String (Time_Type_Definition, + Iir_Predefined_Time_To_String_Unit, + Name_To_String, + Name_Unit, + Time_Subtype_Definition); + end if; + + end Create_Std_Standard_Package; +end Std_Package; diff --git a/src/vhdl/std_package.ads b/src/vhdl/std_package.ads new file mode 100644 index 000000000..166c3c789 --- /dev/null +++ b/src/vhdl/std_package.ads @@ -0,0 +1,182 @@ +-- std.standard package declarations. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; + +package Std_Package is + + -- This is a special node, not really declared in the STANDARD package, + -- used to mark a node as erroneous. + -- Its kind is Iir_Kind_Error. + Error_Mark : constant Iir; + + -- Some well know values declared in the STANDARD package. + -- These values (except time_base) *must* not be modified, and are set by + -- create_std_standard_package. + -- Time_base is the base unit of time. It is set during the creation of + -- all these nodes, and can be modified only *immediatly* after. + + Time_Base: Iir_Unit_Declaration := Null_Iir; + + Std_Standard_File: Iir_Design_File := Null_Iir; + Std_Standard_Unit : Iir_Design_Unit := Null_Iir; + Standard_Package : Iir_Package_Declaration := Null_Iir; + + -- Boolean values. + Boolean_Type_Declaration : Iir_Type_Declaration := Null_Iir; + Boolean_Type_Definition : Iir_Enumeration_Type_Definition; + Boolean_False : Iir_Enumeration_Literal; + Boolean_True : Iir_Enumeration_Literal; + + -- Bit values. + Bit_Type_Declaration : Iir_Type_Declaration := Null_Iir; + Bit_Type_Definition : Iir_Enumeration_Type_Definition; + Bit_0 : Iir_Enumeration_Literal; + Bit_1 : Iir_Enumeration_Literal; + + -- Predefined character. + Character_Type_Declaration : Iir_Type_Declaration; + Character_Type_Definition : Iir_Enumeration_Type_Definition; + + -- severity level. + Severity_Level_Type_Declaration : Iir_Type_Declaration; + Severity_Level_Type_Definition : Iir_Enumeration_Type_Definition; + Severity_Level_Note : Iir_Enumeration_Literal; + Severity_Level_Warning : Iir_Enumeration_Literal; + Severity_Level_Error : Iir_Enumeration_Literal; + Severity_Level_Failure : Iir_Enumeration_Literal; + + -- Universal types. + Universal_Integer_Type_Declaration : Iir_Anonymous_Type_Declaration; + Universal_Integer_Type_Definition : constant Iir_Integer_Type_Definition; + Universal_Integer_Subtype_Declaration : Iir_Subtype_Declaration; + Universal_Integer_Subtype_Definition : Iir_Integer_Subtype_Definition; + + Universal_Integer_One : Iir_Integer_Literal; + + Universal_Real_Type_Declaration : Iir_Anonymous_Type_Declaration; + Universal_Real_Type_Definition : constant Iir_Floating_Type_Definition; + Universal_Real_Subtype_Declaration : Iir_Subtype_Declaration; + Universal_Real_Subtype_Definition : Iir_Floating_Subtype_Definition; + + -- Predefined integer type. + Integer_Type_Declaration : Iir_Anonymous_Type_Declaration; + Integer_Type_Definition : Iir_Integer_Type_Definition; + Integer_Subtype_Declaration : Iir_Subtype_Declaration; + Integer_Subtype_Definition : Iir_Integer_Subtype_Definition; + + -- Type used when a subtype indication cannot be semantized. + -- FIXME: To be improved. + Error_Type : Iir_Integer_Type_Definition renames Integer_Type_Definition; + + -- Predefined real type. + Real_Type_Declaration : Iir_Anonymous_Type_Declaration; + Real_Type_Definition : Iir_Floating_Type_Definition; + Real_Subtype_Declaration : Iir_Subtype_Declaration; + Real_Subtype_Definition : Iir_Floating_Subtype_Definition; + + -- Predefined natural subtype. + Natural_Subtype_Declaration : Iir_Subtype_Declaration; + Natural_Subtype_Definition : Iir_Integer_Subtype_Definition; + + -- Predefined positive subtype. + Positive_Subtype_Declaration : Iir_Subtype_Declaration; + Positive_Subtype_Definition : Iir_Integer_Subtype_Definition; + + -- Predefined positive subtype. + String_Type_Declaration : Iir_Type_Declaration; + String_Type_Definition : Iir_Array_Type_Definition; + + -- Predefined positive subtype. + Bit_Vector_Type_Declaration : Iir_Type_Declaration; + Bit_Vector_Type_Definition : Iir_Array_Type_Definition; + + -- predefined time subtype + Time_Type_Declaration : Iir_Anonymous_Type_Declaration; + Time_Type_Definition: Iir_Physical_Type_Definition; + Time_Subtype_Definition: Iir_Physical_Subtype_Definition; + Time_Subtype_Declaration : Iir_Subtype_Declaration; + + -- For VHDL-93 + Delay_Length_Subtype_Definition : Iir_Physical_Subtype_Definition; + Delay_Length_Subtype_Declaration : Iir_Subtype_Declaration; + + -- For VHDL-93: + -- type File_Open_Kind + File_Open_Kind_Type_Declaration : Iir_Type_Declaration; + File_Open_Kind_Type_Definition : Iir_Enumeration_Type_Definition; + File_Open_Kind_Read_Mode : Iir_Enumeration_Literal; + File_Open_Kind_Write_Mode : Iir_Enumeration_Literal; + File_Open_Kind_Append_Mode : Iir_Enumeration_Literal; + + -- For VHDL-93: + -- type File_Open_Status + File_Open_Status_Type_Declaration : Iir_Type_Declaration; + File_Open_Status_Type_Definition : Iir_Enumeration_Type_Definition; + File_Open_Status_Open_Ok : Iir_Enumeration_Literal; + File_Open_Status_Status_Error : Iir_Enumeration_Literal; + File_Open_Status_Name_Error : Iir_Enumeration_Literal; + File_Open_Status_Mode_Error : Iir_Enumeration_Literal; + + -- For VHDL-93: + -- atribute foreign : string; + Foreign_Attribute : Iir_Attribute_Declaration; + + -- For VHDL-08 + Boolean_Vector_Type_Definition : Iir_Array_Type_Definition; + Boolean_Vector_Type_Declaration : Iir_Type_Declaration; + + Integer_Vector_Type_Definition : Iir_Array_Type_Definition; + Integer_Vector_Type_Declaration : Iir_Type_Declaration; + + Real_Vector_Type_Definition : Iir_Array_Type_Definition; + Real_Vector_Type_Declaration : Iir_Type_Declaration; + + Time_Vector_Type_Definition : Iir_Array_Type_Definition; + Time_Vector_Type_Declaration : Iir_Type_Declaration; + + -- Internal use only. + -- These types should be considered like universal types, but + -- furthermore, they can be converted to any integer/real types while + -- universal cannot. + Convertible_Integer_Type_Definition : constant Iir_Integer_Type_Definition; + Convertible_Real_Type_Definition : constant Iir_Floating_Type_Definition; + Convertible_Integer_Type_Declaration : Iir_Anonymous_Type_Declaration; + Convertible_Real_Type_Declaration : Iir_Anonymous_Type_Declaration; + + Convertible_Integer_Subtype_Definition : Iir_Integer_Subtype_Definition; + Convertible_Integer_Subtype_Declaration : Iir_Subtype_Declaration; + + -- Create the first well-known nodes. + procedure Create_First_Nodes; + + -- Create the node for the standard package. + procedure Create_Std_Standard_Package (Parent : Iir_Library_Declaration); + +private + -- For speed reasons, some often used nodes are hard-coded. + Error_Mark : constant Iir := 2; + Universal_Integer_Type_Definition : constant Iir_Integer_Type_Definition + := 3; + Universal_Real_Type_Definition : constant Iir_Floating_Type_Definition + := 4; + + Convertible_Integer_Type_Definition : constant Iir_Integer_Type_Definition + := 5; + Convertible_Real_Type_Definition : constant Iir_Floating_Type_Definition + := 6; +end Std_Package; diff --git a/src/vhdl/tokens.adb b/src/vhdl/tokens.adb new file mode 100644 index 000000000..5d27be8d9 --- /dev/null +++ b/src/vhdl/tokens.adb @@ -0,0 +1,443 @@ +-- Scanner token definitions. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package body Tokens is + -- Return the name of the token. + function Image (Token: Token_Type) return String is + begin + case Token is + when Tok_Invalid => + return "<invalid>"; + when Tok_Left_Paren => + return "("; + when Tok_Right_Paren => + return ")"; + when Tok_Left_Bracket => + return "["; + when Tok_Right_Bracket => + return "]"; + when Tok_Colon => + return ":"; + when Tok_Semi_Colon => + return ";"; + when Tok_Comma => + return ","; + when Tok_Tick => + return "'"; + when Tok_Double_Star => + return "**"; + when Tok_Double_Arrow => + return "=>"; + when Tok_Assign => + return ":="; + when Tok_Bar => + return "|"; + when Tok_Box => + return "<>"; + when Tok_Dot => + return "."; + + when Tok_Eof => + return "<EOF>"; + when Tok_Newline => + return "<newline>"; + when Tok_Comment => + return "<comment>"; + when Tok_Character => + return "<character>"; + when Tok_Identifier => + return "<identifier>"; + when Tok_Integer => + return "<integer>"; + when Tok_Real => + return "<real>"; + when Tok_String => + return "<string>"; + when Tok_Bit_String => + return "<bit string>"; + + when Tok_Equal_Equal => + return "=="; + + -- relational_operator: + when Tok_Equal => + return "="; + when Tok_Not_Equal => + return "/="; + when Tok_Less => + return "<"; + when Tok_Less_Equal => + return "<="; + when Tok_Greater => + return ">"; + when Tok_Greater_Equal => + return ">="; + + when Tok_Match_Equal => + return "?="; + when Tok_Match_Not_Equal => + return "?/="; + when Tok_Match_Less => + return "?<"; + when Tok_Match_Less_Equal => + return "?<="; + when Tok_Match_Greater => + return "?>"; + when Tok_Match_Greater_Equal => + return "?>="; + + -- sign token + when Tok_Plus => + return "+"; + when Tok_Minus => + return "-"; + -- and adding_operator + when Tok_Ampersand => + return "&"; + + when Tok_Condition => + return "??"; + + -- multiplying operator + when Tok_Star => + return "*"; + when Tok_Slash => + return "/"; + when Tok_Mod => + return "mod"; + when Tok_Rem => + return "rem"; + + -- relation token: + when Tok_And => + return "and"; + when Tok_Or => + return "or"; + when Tok_Xor => + return "xor"; + when Tok_Nand => + return "nand"; + when Tok_Nor => + return "nor"; + when Tok_Xnor => + return "xnor"; + + -- Reserved words. + when Tok_Abs => + return "abs"; + when Tok_Access => + return "access"; + when Tok_After => + return "after"; + when Tok_Alias => + return "alias"; + when Tok_All => + return "all"; + when Tok_Architecture => + return "architecture"; + when Tok_Array => + return "array"; + when Tok_Assert => + return "assert"; + when Tok_Attribute => + return "attribute"; + + when Tok_Begin => + return "begin"; + when Tok_Block => + return "block"; + when Tok_Body => + return "body"; + when Tok_Buffer => + return "buffer"; + when Tok_Bus => + return "bus"; + + when Tok_Case => + return "case"; + when Tok_Component => + return "component"; + when Tok_Configuration => + return "configuration"; + when Tok_Constant => + return "constant"; + + when Tok_Disconnect => + return "disconnect"; + when Tok_Downto => + return "downto"; + + when Tok_Else => + return "else"; + when Tok_Elsif => + return "elsif"; + when Tok_End => + return "end"; + when Tok_Entity => + return "entity"; + when Tok_Exit => + return "exit"; + + when Tok_File => + return "file"; + when Tok_For => + return "for"; + when Tok_Function => + return "function"; + + when Tok_Generate => + return "generate"; + when Tok_Generic => + return "generic"; + when Tok_Group => + return "group"; + when Tok_Guarded => + return "guarded"; + + when Tok_If => + return "if"; + when Tok_Impure => + return "impure"; + when Tok_In => + return "in"; + when Tok_Inertial => + return "inertial"; + when Tok_Inout => + return "inout"; + when Tok_Is => + return "is"; + + when Tok_Label => + return "label"; + when Tok_Library => + return "library"; + when Tok_Linkage => + return "linkage"; + when Tok_Literal => + return "literal"; + when Tok_Loop => + return "loop"; + + when Tok_Map => + return "map"; + + when Tok_New => + return "new"; + when Tok_Next => + return "next"; + when Tok_Not => + return "not"; + when Tok_Null => + return "null"; + + when Tok_Of => + return "of"; + when Tok_On => + return "on"; + when Tok_Open => + return "open"; + when Tok_Out => + return "out"; + when Tok_Others => + return "others"; + + when Tok_Package => + return "package"; + when Tok_Port => + return "port"; + when Tok_Postponed => + return "postponed"; + when Tok_Procedure => + return "procedure"; + when Tok_Process => + return "process"; + when Tok_Pure => + return "pure"; + + when Tok_Range => + return "range"; + when Tok_Record => + return "record"; + when Tok_Register => + return "register"; + when Tok_Reject => + return "reject"; + when Tok_Report => + return "report"; + when Tok_Return => + return "return"; + + when Tok_Select => + return "select"; + when Tok_Severity => + return "severity"; + when Tok_Shared => + return "shared"; + when Tok_Signal => + return "signal"; + when Tok_Subtype => + return "subtype"; + + when Tok_Then => + return "then"; + when Tok_To => + return "to"; + when Tok_Transport => + return "transport"; + when Tok_Type => + return "type"; + + when Tok_Unaffected => + return "unaffected"; + when Tok_Units => + return "units"; + when Tok_Until => + return "until"; + when Tok_Use => + return "use"; + + when Tok_Variable => + return "variable"; + + when Tok_Wait => + return "wait"; + when Tok_When => + return "when"; + when Tok_While => + return "while"; + when Tok_With => + return "with"; + + -- shift_operator + when Tok_Sll => + return "sll"; + when Tok_Sla => + return "sla"; + when Tok_Sra => + return "sra"; + when Tok_Srl => + return "srl"; + when Tok_Rol => + return "rol"; + when Tok_Ror => + return "ror"; + + -- VHDL 00 + when Tok_Protected => + return "protected"; + + -- AMS-VHDL + when Tok_Across => + return "across"; + when Tok_Break => + return "break"; + when Tok_Limit => + return "limit"; + when Tok_Nature => + return "nature"; + when Tok_Noise => + return "noise"; + when Tok_Procedural => + return "procedural"; + when Tok_Quantity => + return "quantity"; + when Tok_Reference => + return "reference"; + when Tok_Spectrum => + return "spectrum"; + when Tok_Subnature => + return "subnature"; + when Tok_Terminal => + return "terminal"; + when Tok_Through => + return "through"; + when Tok_Tolerance => + return "tolerance"; + + when Tok_And_And => + return "&&"; + when Tok_Bar_Bar => + return "||"; + when Tok_Left_Curly => + return "{"; + when Tok_Right_Curly => + return "}"; + when Tok_Exclam_Mark => + return "!"; + when Tok_Brack_Star => + return "[*"; + when Tok_Brack_Plus_Brack => + return "[+]"; + when Tok_Brack_Arrow => + return "[->"; + when Tok_Brack_Equal => + return "[="; + when Tok_Bar_Arrow => + return "|->"; + when Tok_Bar_Double_Arrow => + return "|=>"; + when Tok_Minus_Greater => + return "->"; + when Tok_Arobase => + return "@"; + + when Tok_Psl_Default => + return "default"; + when Tok_Psl_Clock => + return "clock"; + when Tok_Psl_Property => + return "property"; + when Tok_Psl_Sequence => + return "sequence"; + when Tok_Psl_Endpoint => + return "endpoint"; + when Tok_Psl_Assert => + return "assert"; + when Tok_Psl_Cover => + return "cover"; + when Tok_Psl_Const => + return "const"; + when Tok_Psl_Boolean => + return "boolean"; + when Tok_Inf => + return "inf"; + when Tok_Within => + return "within"; + when Tok_Abort => + return "abort"; + when Tok_Before => + return "before"; + when Tok_Always => + return "always"; + when Tok_Never => + return "never"; + when Tok_Eventually => + return "eventually"; + when Tok_Next_A => + return "next_a"; + when Tok_Next_E => + return "next_e"; + when Tok_Next_Event => + return "next_event"; + when Tok_Next_Event_A => + return "next_event_a"; + when Tok_Next_Event_E => + return "next_event_e"; + end case; + end Image; + +end Tokens; diff --git a/src/vhdl/tokens.ads b/src/vhdl/tokens.ads new file mode 100644 index 000000000..c72873103 --- /dev/null +++ b/src/vhdl/tokens.ads @@ -0,0 +1,279 @@ +-- Scanner token definitions. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Tokens is + pragma Pure (Tokens); + + type Token_Type is + ( + Tok_Invalid, -- current_token is not valid. + + Tok_Left_Paren, -- ( + Tok_Right_Paren, -- ) + Tok_Left_Bracket, -- [ + Tok_Right_Bracket, -- ] + Tok_Colon, -- : + Tok_Semi_Colon, -- ; + Tok_Comma, -- , + Tok_Double_Arrow, -- => + Tok_Tick, -- ' + Tok_Double_Star, -- ** + Tok_Assign, -- := + Tok_Bar, -- | + Tok_Box, -- <> + Tok_Dot, -- . + + Tok_Equal_Equal, -- == (AMS Vhdl) + + Tok_Eof, -- End of file. + Tok_Newline, + Tok_Comment, + Tok_Character, + Tok_Identifier, + Tok_Integer, + Tok_Real, + Tok_String, + Tok_Bit_String, + + -- relational_operator + Tok_Equal, -- = + Tok_Not_Equal, -- /= + Tok_Less, -- < + Tok_Less_Equal, -- <= + Tok_Greater, -- > + Tok_Greater_Equal, -- >= + + Tok_Match_Equal, -- ?= + Tok_Match_Not_Equal, -- ?/= + Tok_Match_Less, -- ?< + Tok_Match_Less_Equal, -- ?<= + Tok_Match_Greater, -- ?> + Tok_Match_Greater_Equal, -- ?>= + + -- sign token + Tok_Plus, -- + + Tok_Minus, -- - + -- and adding_operator + Tok_Ampersand, -- & + + Tok_Condition, -- ?? + + -- PSL + Tok_And_And, -- && + Tok_Bar_Bar, -- || + Tok_Left_Curly, -- { + Tok_Right_Curly, -- } + Tok_Exclam_Mark, -- ! + Tok_Brack_Star, -- [* + Tok_Brack_Plus_Brack, -- [+] + Tok_Brack_Arrow, -- [-> + Tok_Brack_Equal, -- [= + Tok_Bar_Arrow, -- |-> + Tok_Bar_Double_Arrow, -- |=> + Tok_Minus_Greater, -- -> + Tok_Arobase, -- @ + + -- multiplying operator + Tok_Star, -- * + Tok_Slash, -- / + Tok_Mod, -- mod + Tok_Rem, -- rem + + -- relation token: + Tok_And, + Tok_Or, + Tok_Xor, + Tok_Nand, + Tok_Nor, + + -- miscellaneous operator + Tok_Abs, + Tok_Not, + + -- Key words + Tok_Access, + Tok_After, + Tok_Alias, + Tok_All, + Tok_Architecture, + Tok_Array, + Tok_Assert, + Tok_Attribute, + + Tok_Begin, + Tok_Block, + Tok_Body, + Tok_Buffer, + Tok_Bus, + + Tok_Case, + Tok_Component, + Tok_Configuration, + Tok_Constant, + + Tok_Disconnect, + Tok_Downto, + + Tok_Else, + Tok_Elsif, + Tok_End, + Tok_Entity, + Tok_Exit, + + Tok_File, + Tok_For, + Tok_Function, + + Tok_Generate, + Tok_Generic, + Tok_Guarded, + + Tok_If, + Tok_In, + Tok_Inout, + Tok_Is, + + Tok_Label, + Tok_Library, + Tok_Linkage, + Tok_Loop, + + Tok_Map, + + Tok_New, + Tok_Next, + Tok_Null, + + Tok_Of, + Tok_On, + Tok_Open, + Tok_Others, + Tok_Out, + + Tok_Package, + Tok_Port, + Tok_Procedure, + Tok_Process, + + Tok_Range, + Tok_Record, + Tok_Register, + Tok_Report, + Tok_Return, + + Tok_Select, + Tok_Severity, + Tok_Signal, + Tok_Subtype, + + Tok_Then, + Tok_To, + Tok_Transport, + Tok_Type, + + Tok_Units, + Tok_Until, + Tok_Use, + + Tok_Variable, + + Tok_Wait, + Tok_When, + Tok_While, + Tok_With, + + -- Tokens below this line are key words in vhdl93 but not in vhdl87 + Tok_Xnor, + Tok_Group, + Tok_Impure, + Tok_Inertial, + Tok_Literal, + Tok_Postponed, + Tok_Pure, + Tok_Reject, + Tok_Shared, + Tok_Unaffected, + + -- shift_operator + Tok_Sll, + Tok_Sla, + Tok_Sra, + Tok_Srl, + Tok_Rol, + Tok_Ror, + + -- Added by Vhdl 2000: + Tok_Protected, + + -- AMS reserved words + Tok_Across, + Tok_Break, + Tok_Limit, + Tok_Nature, + Tok_Noise, + Tok_Procedural, + Tok_Quantity, + Tok_Reference, + Tok_Spectrum, + Tok_Subnature, + Tok_Terminal, + Tok_Through, + Tok_Tolerance, + + -- PSL words + Tok_Psl_Default, + Tok_Psl_Clock, + Tok_Psl_Property, + Tok_Psl_Sequence, + Tok_Psl_Endpoint, + Tok_Psl_Assert, + Tok_Psl_Cover, + + Tok_Psl_Const, + Tok_Psl_Boolean, + Tok_Inf, + + Tok_Within, + Tok_Abort, + Tok_Before, + Tok_Always, + Tok_Never, + Tok_Eventually, + Tok_Next_A, + Tok_Next_E, + Tok_Next_Event, + Tok_Next_Event_A, + Tok_Next_Event_E + ); + + -- subtype Token_Relation_Type is Token_Type range Tok_And .. Tok_Xnor; + subtype Token_Relational_Operator_Type is Token_Type range + Tok_Equal .. Tok_Match_Greater_Equal; + subtype Token_Shift_Operator_Type is Token_Type range + Tok_Sll .. Tok_Ror; + subtype Token_Sign_Type is Token_Type range + Tok_Plus .. Tok_Minus; + subtype Token_Adding_Operator_Type is Token_Type range + Tok_Plus .. Tok_Ampersand; + subtype Token_Multiplying_Operator_Type is Token_Type range + Tok_Star .. Tok_Rem; + + Tok_First_Keyword : constant Tokens.Token_Type := Tokens.Tok_Mod; + + -- Return the name of the token. + function Image (Token: Token_Type) return String; +end Tokens; diff --git a/src/vhdl/xrefs.adb b/src/vhdl/xrefs.adb new file mode 100644 index 000000000..15696696b --- /dev/null +++ b/src/vhdl/xrefs.adb @@ -0,0 +1,279 @@ +-- Cross references. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with GNAT.Table; +with GNAT.Heap_Sort_A; +with Flags; +with Std_Package; +with Errorout; use Errorout; +with Nodes; + +package body Xrefs is + type Xref_Type is record + -- Where the cross-reference (or the name) appears. + Loc : Location_Type; + + -- What the name refer to. + Ref : Iir; + + -- Kind of reference (See package specification). + Kind : Xref_Kind; + end record; + + package Xref_Table is new GNAT.Table + (Table_Index_Type => Natural, + Table_Component_Type => Xref_Type, + Table_Low_Bound => 0, + Table_Initial => 128, + Table_Increment => 100); + + function Get_Xref_Location (N : Xref) return Location_Type is + begin + return Xref_Table.Table (N).Loc; + end Get_Xref_Location; + + function Get_Xref_Kind (N : Xref) return Xref_Kind is + begin + return Xref_Table.Table (N).Kind; + end Get_Xref_Kind; + + function Get_Xref_Node (N : Xref) return Iir is + begin + return Xref_Table.Table (N).Ref; + end Get_Xref_Node; + + function Get_Last_Xref return Xref is + begin + return Xref_Table.Last; + end Get_Last_Xref; + + procedure Init is + begin + Xref_Table.Set_Last (Bad_Xref); + end Init; + + procedure Add_Xref (Loc : Location_Type; Ref : Iir; Kind : Xref_Kind) is + begin + -- Check there is no xref for the same location to the same reference. + -- (Note that a designatore may reference several declarations, this + -- is possible in attribute specification for an overloadable name). + -- This is a simple heuristic as this catch only two referenced in the + -- row but efficient and should be enough to catch errors. + pragma Assert + (Xref_Table.Last < Xref_Table.First + or else Xref_Table.Table (Xref_Table.Last).Loc /= Loc + or else Xref_Table.Table (Xref_Table.Last).Ref /= Ref); + + Xref_Table.Append (Xref_Type'(Loc => Loc, + Ref => Ref, + Kind => Kind)); + end Add_Xref; + + procedure Xref_Decl (Decl : Iir) is + begin + if Flags.Flag_Xref then + Add_Xref (Get_Location (Decl), Decl, Xref_Decl); + end if; + end Xref_Decl; + + procedure Xref_Ref (Name : Iir; Decl : Iir) is + begin + if Flags.Flag_Xref then + Add_Xref (Get_Location (Name), Decl, Xref_Ref); + end if; + end Xref_Ref; + + procedure Xref_Body (Bod : Iir; Spec : Iir) is + begin + if Flags.Flag_Xref then + Add_Xref (Get_Location (Bod), Spec, Xref_Body); + end if; + end Xref_Body; + + procedure Xref_End (Loc : Location_Type; Decl : Iir) is + begin + if Flags.Flag_Xref then + Add_Xref (Loc, Decl, Xref_End); + end if; + end Xref_End; + + procedure Xref_Name_1 (Name : Iir) is + begin + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Operator_Symbol + | Iir_Kind_Character_Literal => + declare + Res : constant Iir := Get_Named_Entity (Name); + begin + if Res = Std_Package.Error_Mark then + return; + end if; + Add_Xref (Get_Location (Name), Res, Xref_Ref); + end; + when Iir_Kind_Selected_Element => + Add_Xref (Get_Location (Name), + Get_Selected_Element (Name), Xref_Ref); + when Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Function_Call => + null; + when Iir_Kinds_Attribute => + null; + when Iir_Kind_Attribute_Name => + -- FIXME: user defined attributes. + null; + when Iir_Kind_Type_Conversion => + return; + when others => + Error_Kind ("xref_name_1", Name); + end case; + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol + | Iir_Kind_Character_Literal => + null; + when Iir_Kind_Selected_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Attribute_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kinds_Attribute + | Iir_Kind_Function_Call => + Xref_Name_1 (Get_Prefix (Name)); + when others => + Error_Kind ("xref_name_1", Name); + end case; + end Xref_Name_1; + + procedure Xref_Name (Name : Iir) is + begin + if Flags.Flag_Xref and Name /= Null_Iir then + Xref_Name_1 (Name); + end if; + end Xref_Name; + + procedure Move (From : Natural; To : Natural) + is + Tmp : Xref_Type; + begin + Tmp := Xref_Table.Table (To); + Xref_Table.Table (To) := Xref_Table.Table (From); + Xref_Table.Table (From) := Tmp; + end Move; + + function Loc_Lt (Op1, Op2 : Natural) return Boolean + is + L1 : constant Location_Type := Xref_Table.Table (Op1).Loc; + L2 : constant Location_Type := Xref_Table.Table (Op2).Loc; + begin + return L1 < L2; + end Loc_Lt; + + procedure Sort_By_Location is + begin + GNAT.Heap_Sort_A.Sort (Xref_Table.Last, Move'Access, Loc_Lt'Access); + end Sort_By_Location; + + -- Sorting function by ref field. + -- If ref fields are the same, then compare by location. + function Node_Lt (Op1, Op2 : Natural) return Boolean + is + L1, L2 : Location_Type; + N1, N2 : Iir; + K1, K2 : Xref_Kind; + begin + L1 := Get_Location (Get_Xref_Node (Op1)); + L2 := Get_Location (Get_Xref_Node (Op2)); + + if L1 /= L2 then + return L1 < L2; + end if; + + -- L1 = L2. + -- Note: nodes of std_standard have the same location. FIXME ? + N1 := Get_Xref_Node (Op1); + N2 := Get_Xref_Node (Op2); + if Iirs."/=" (N1, N2) then + return Nodes."<" (N1, N2); + end if; + + -- Try to get declaration first. + K1 := Get_Xref_Kind (Op1); + K2 := Get_Xref_Kind (Op2); + if K1 /= K2 then + return K1 < K2; + end if; + L1 := Get_Xref_Location (Op1); + L2 := Get_Xref_Location (Op2); + return L1 < L2; + end Node_Lt; + + procedure Sort_By_Node_Location is + begin + GNAT.Heap_Sort_A.Sort (Xref_Table.Last, Move'Access, Node_Lt'Access); + end Sort_By_Node_Location; + + function Find (Loc : Location_Type) return Xref + is + Low : Xref; + High : Xref; + Mid : Xref; + Mid_Loc : Location_Type; + begin + Low := First_Xref; + High := Xref_Table.Last; + loop + Mid := (Low + High + 1) / 2; + Mid_Loc := Xref_Table.Table (Mid).Loc; + if Loc = Mid_Loc then + return Mid; + end if; + if Mid = Low then + return Bad_Xref; + end if; + if Loc > Mid_Loc then + Low := Mid + 1; + else + High := Mid - 1; + end if; + end loop; + end Find; + + procedure Fix_End_Xrefs + is + N : Iir; + begin + for I in First_Xref .. Get_Last_Xref loop + if Get_Xref_Kind (I) = Xref_End then + N := Get_Xref_Node (I); + case Get_Kind (N) is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Xref_Table.Table (I).Ref := Get_Subprogram_Specification (N); + when others => + null; + end case; + end if; + end loop; + end Fix_End_Xrefs; +end Xrefs; diff --git a/src/vhdl/xrefs.ads b/src/vhdl/xrefs.ads new file mode 100644 index 000000000..74f2d0c7e --- /dev/null +++ b/src/vhdl/xrefs.ads @@ -0,0 +1,108 @@ +-- Cross references. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Iirs; use Iirs; + +package Xrefs is + type Xref_Kind is + ( + -- Declaration of an identifier. + Xref_Decl, + + -- Use of a named entity. + Xref_Ref, + + -- Identifier after the 'end' keyword. + Xref_End, + + -- Body of a declaration (for package, subprograms or protected type). + Xref_Body + ); + + -- Initialize the xref table. + -- Must be called once. + procedure Init; + + -- Low level xref addition. + -- An entity at LOC references REF with the KIND way. + procedure Add_Xref (Loc : Location_Type; Ref : Iir; Kind : Xref_Kind); + + -- Add a declaration of an identifier. + -- This is somewhat a self-reference. + procedure Xref_Decl (Decl : Iir); + pragma Inline (Xref_Decl); + + -- NAME refers to DECL. + procedure Xref_Ref (Name : Iir; Decl : Iir); + pragma Inline (Xref_Ref); + + -- BODy refers to SPEC. + procedure Xref_Body (Bod : Iir; Spec : Iir); + pragma Inline (Xref_Body); + + -- Just resolved NAME refers to its named entity. + procedure Xref_Name (Name : Iir); + pragma Inline (Xref_Name); + + -- LOC is the location of the simple_name after 'end' for DECL. + procedure Xref_End (Loc : Location_Type; Decl : Iir); + pragma Inline (Xref_End); + + -- Sort the xref table by location. This is required before searching with + -- Find. + procedure Sort_By_Location; + + -- Sort the xref table by location of the nodes. + procedure Sort_By_Node_Location; + + subtype Xref is Natural; + + -- A bad xref. + -- May be returned by Find. + Bad_Xref : constant Xref := 0; + + -- First xref. + -- May be used to size a table. + First_Xref : constant Xref := 1; + + -- Find a reference by location. + -- The table must already be sorted with Sort_By_Location. + -- Returns BAD_REF is does not exist. + function Find (Loc : Location_Type) return Xref; + + -- End_Xrefs are added by parse and points to the subprogram_body. + -- This procedure make them points to the subprogram_decl node. + -- This is done so that every node has a name. + procedure Fix_End_Xrefs; + + -- Get the last possible xref available. + -- May be used to size tables. + function Get_Last_Xref return Xref; + + -- Get the location of N, ie where a name (or operator) appears. + function Get_Xref_Location (N : Xref) return Location_Type; + pragma Inline (Get_Xref_Location); + + -- Get the kind of cross-reference. + function Get_Xref_Kind (N : Xref) return Xref_Kind; + pragma Inline (Get_Xref_Kind); + + -- Get the node referenced by the name. + function Get_Xref_Node (N : Xref) return Iir; + pragma Inline (Get_Xref_Node); +end Xrefs; |