From 0a088b311ed2fcebc542f8a2e42d09e2e3c9311c Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Tue, 4 Nov 2014 20:21:00 +0100 Subject: Create src/vhdl subdirectory. --- src/back_end.adb | 38 - src/back_end.ads | 57 - src/canon.adb | 2735 ----------- src/canon.ads | 70 - src/canon_psl.adb | 43 - src/canon_psl.ads | 26 - src/configuration.adb | 614 --- src/configuration.ads | 55 - src/disp_tree.adb | 511 -- src/disp_tree.ads | 27 - src/disp_vhdl.adb | 3247 ------------- src/disp_vhdl.ads | 38 - src/errorout.adb | 1113 ----- src/errorout.ads | 128 - src/evaluation.adb | 3047 ------------ src/evaluation.ads | 161 - src/ieee-std_logic_1164.adb | 170 - src/ieee-std_logic_1164.ads | 35 - src/ieee-vital_timing.adb | 1377 ------ src/ieee-vital_timing.ads | 41 - src/ieee.ads | 5 - src/iir_chain_handling.adb | 68 - src/iir_chain_handling.ads | 47 - src/iir_chains.adb | 64 - src/iir_chains.ads | 113 - src/iirs.adb | 4515 ------------------ src/iirs.adb.in | 229 - src/iirs.ads | 6445 ------------------------- src/iirs_utils.adb | 1131 ----- src/iirs_utils.ads | 250 - src/iirs_walk.adb | 115 - src/iirs_walk.ads | 45 - src/nodes.adb | 467 -- src/nodes.ads | 335 -- src/nodes_gc.adb | 206 - src/nodes_gc.adb.in | 159 - src/nodes_gc.ads | 24 - src/nodes_meta.adb | 9409 ------------------------------------- src/nodes_meta.adb.in | 76 - src/nodes_meta.ads | 823 ---- src/nodes_meta.ads.in | 66 - src/parse.adb | 7143 ---------------------------- src/parse.ads | 44 - src/parse_psl.adb | 667 --- src/parse_psl.ads | 26 - src/post_sems.adb | 71 - src/post_sems.ads | 25 - src/psl-errors.ads | 3 - src/scanner-scan_literal.adb | 651 --- src/scanner.adb | 1621 ------- src/scanner.ads | 120 - src/sem.adb | 2749 ----------- src/sem.ads | 82 - src/sem_assocs.adb | 1903 -------- src/sem_assocs.ads | 60 - src/sem_decls.adb | 3018 ------------ src/sem_decls.ads | 52 - src/sem_expr.adb | 4262 ----------------- src/sem_expr.ads | 178 - src/sem_inst.adb | 639 --- src/sem_inst.ads | 26 - src/sem_names.adb | 3788 --------------- src/sem_names.ads | 159 - src/sem_psl.adb | 617 --- src/sem_psl.ads | 26 - src/sem_scopes.adb | 1412 ------ src/sem_scopes.ads | 217 - src/sem_specs.adb | 1731 ------- src/sem_specs.ads | 88 - src/sem_stmts.adb | 2007 -------- src/sem_stmts.ads | 87 - src/sem_types.adb | 2210 --------- src/sem_types.ads | 57 - src/std_package.adb | 1200 ----- src/std_package.ads | 182 - src/tokens.adb | 443 -- src/tokens.ads | 279 -- src/vhdl/back_end.adb | 38 + src/vhdl/back_end.ads | 57 + src/vhdl/canon.adb | 2735 +++++++++++ src/vhdl/canon.ads | 70 + src/vhdl/canon_psl.adb | 43 + src/vhdl/canon_psl.ads | 26 + src/vhdl/configuration.adb | 614 +++ src/vhdl/configuration.ads | 55 + src/vhdl/disp_tree.adb | 511 ++ src/vhdl/disp_tree.ads | 27 + src/vhdl/disp_vhdl.adb | 3247 +++++++++++++ src/vhdl/disp_vhdl.ads | 38 + src/vhdl/errorout.adb | 1113 +++++ src/vhdl/errorout.ads | 128 + src/vhdl/evaluation.adb | 3047 ++++++++++++ src/vhdl/evaluation.ads | 161 + src/vhdl/ieee-std_logic_1164.adb | 170 + src/vhdl/ieee-std_logic_1164.ads | 35 + src/vhdl/ieee-vital_timing.adb | 1377 ++++++ src/vhdl/ieee-vital_timing.ads | 41 + src/vhdl/ieee.ads | 5 + src/vhdl/iir_chain_handling.adb | 68 + src/vhdl/iir_chain_handling.ads | 47 + src/vhdl/iir_chains.adb | 64 + src/vhdl/iir_chains.ads | 113 + src/vhdl/iirs.adb | 4515 ++++++++++++++++++ src/vhdl/iirs.adb.in | 229 + src/vhdl/iirs.ads | 6445 +++++++++++++++++++++++++ src/vhdl/iirs_utils.adb | 1131 +++++ src/vhdl/iirs_utils.ads | 250 + src/vhdl/iirs_walk.adb | 115 + src/vhdl/iirs_walk.ads | 45 + src/vhdl/nodes.adb | 467 ++ src/vhdl/nodes.ads | 335 ++ src/vhdl/nodes_gc.adb | 206 + src/vhdl/nodes_gc.adb.in | 159 + src/vhdl/nodes_gc.ads | 24 + src/vhdl/nodes_meta.adb | 9409 +++++++++++++++++++++++++++++++++++++ src/vhdl/nodes_meta.adb.in | 76 + src/vhdl/nodes_meta.ads | 823 ++++ src/vhdl/nodes_meta.ads.in | 66 + src/vhdl/parse.adb | 7143 ++++++++++++++++++++++++++++ src/vhdl/parse.ads | 44 + src/vhdl/parse_psl.adb | 667 +++ src/vhdl/parse_psl.ads | 26 + src/vhdl/post_sems.adb | 71 + src/vhdl/post_sems.ads | 25 + src/vhdl/psl-errors.ads | 3 + src/vhdl/scanner-scan_literal.adb | 651 +++ src/vhdl/scanner.adb | 1621 +++++++ src/vhdl/scanner.ads | 120 + src/vhdl/sem.adb | 2749 +++++++++++ src/vhdl/sem.ads | 82 + src/vhdl/sem_assocs.adb | 1903 ++++++++ src/vhdl/sem_assocs.ads | 60 + src/vhdl/sem_decls.adb | 3018 ++++++++++++ src/vhdl/sem_decls.ads | 52 + src/vhdl/sem_expr.adb | 4262 +++++++++++++++++ src/vhdl/sem_expr.ads | 178 + src/vhdl/sem_inst.adb | 639 +++ src/vhdl/sem_inst.ads | 26 + src/vhdl/sem_names.adb | 3788 +++++++++++++++ src/vhdl/sem_names.ads | 159 + src/vhdl/sem_psl.adb | 617 +++ src/vhdl/sem_psl.ads | 26 + src/vhdl/sem_scopes.adb | 1412 ++++++ src/vhdl/sem_scopes.ads | 217 + src/vhdl/sem_specs.adb | 1731 +++++++ src/vhdl/sem_specs.ads | 88 + src/vhdl/sem_stmts.adb | 2007 ++++++++ src/vhdl/sem_stmts.ads | 87 + src/vhdl/sem_types.adb | 2210 +++++++++ src/vhdl/sem_types.ads | 57 + src/vhdl/std_package.adb | 1200 +++++ src/vhdl/std_package.ads | 182 + src/vhdl/tokens.adb | 443 ++ src/vhdl/tokens.ads | 279 ++ src/vhdl/xrefs.adb | 279 ++ src/vhdl/xrefs.ads | 108 + src/xrefs.adb | 279 -- src/xrefs.ads | 108 - 158 files changed, 76355 insertions(+), 76355 deletions(-) delete mode 100644 src/back_end.adb delete mode 100644 src/back_end.ads delete mode 100644 src/canon.adb delete mode 100644 src/canon.ads delete mode 100644 src/canon_psl.adb delete mode 100644 src/canon_psl.ads delete mode 100644 src/configuration.adb delete mode 100644 src/configuration.ads delete mode 100644 src/disp_tree.adb delete mode 100644 src/disp_tree.ads delete mode 100644 src/disp_vhdl.adb delete mode 100644 src/disp_vhdl.ads delete mode 100644 src/errorout.adb delete mode 100644 src/errorout.ads delete mode 100644 src/evaluation.adb delete mode 100644 src/evaluation.ads delete mode 100644 src/ieee-std_logic_1164.adb delete mode 100644 src/ieee-std_logic_1164.ads delete mode 100644 src/ieee-vital_timing.adb delete mode 100644 src/ieee-vital_timing.ads delete mode 100644 src/ieee.ads delete mode 100644 src/iir_chain_handling.adb delete mode 100644 src/iir_chain_handling.ads delete mode 100644 src/iir_chains.adb delete mode 100644 src/iir_chains.ads delete mode 100644 src/iirs.adb delete mode 100644 src/iirs.adb.in delete mode 100644 src/iirs.ads delete mode 100644 src/iirs_utils.adb delete mode 100644 src/iirs_utils.ads delete mode 100644 src/iirs_walk.adb delete mode 100644 src/iirs_walk.ads delete mode 100644 src/nodes.adb delete mode 100644 src/nodes.ads delete mode 100644 src/nodes_gc.adb delete mode 100644 src/nodes_gc.adb.in delete mode 100644 src/nodes_gc.ads delete mode 100644 src/nodes_meta.adb delete mode 100644 src/nodes_meta.adb.in delete mode 100644 src/nodes_meta.ads delete mode 100644 src/nodes_meta.ads.in delete mode 100644 src/parse.adb delete mode 100644 src/parse.ads delete mode 100644 src/parse_psl.adb delete mode 100644 src/parse_psl.ads delete mode 100644 src/post_sems.adb delete mode 100644 src/post_sems.ads delete mode 100644 src/psl-errors.ads delete mode 100644 src/scanner-scan_literal.adb delete mode 100644 src/scanner.adb delete mode 100644 src/scanner.ads delete mode 100644 src/sem.adb delete mode 100644 src/sem.ads delete mode 100644 src/sem_assocs.adb delete mode 100644 src/sem_assocs.ads delete mode 100644 src/sem_decls.adb delete mode 100644 src/sem_decls.ads delete mode 100644 src/sem_expr.adb delete mode 100644 src/sem_expr.ads delete mode 100644 src/sem_inst.adb delete mode 100644 src/sem_inst.ads delete mode 100644 src/sem_names.adb delete mode 100644 src/sem_names.ads delete mode 100644 src/sem_psl.adb delete mode 100644 src/sem_psl.ads delete mode 100644 src/sem_scopes.adb delete mode 100644 src/sem_scopes.ads delete mode 100644 src/sem_specs.adb delete mode 100644 src/sem_specs.ads delete mode 100644 src/sem_stmts.adb delete mode 100644 src/sem_stmts.ads delete mode 100644 src/sem_types.adb delete mode 100644 src/sem_types.ads delete mode 100644 src/std_package.adb delete mode 100644 src/std_package.ads delete mode 100644 src/tokens.adb delete mode 100644 src/tokens.ads create mode 100644 src/vhdl/back_end.adb create mode 100644 src/vhdl/back_end.ads create mode 100644 src/vhdl/canon.adb create mode 100644 src/vhdl/canon.ads create mode 100644 src/vhdl/canon_psl.adb create mode 100644 src/vhdl/canon_psl.ads create mode 100644 src/vhdl/configuration.adb create mode 100644 src/vhdl/configuration.ads create mode 100644 src/vhdl/disp_tree.adb create mode 100644 src/vhdl/disp_tree.ads create mode 100644 src/vhdl/disp_vhdl.adb create mode 100644 src/vhdl/disp_vhdl.ads create mode 100644 src/vhdl/errorout.adb create mode 100644 src/vhdl/errorout.ads create mode 100644 src/vhdl/evaluation.adb create mode 100644 src/vhdl/evaluation.ads create mode 100644 src/vhdl/ieee-std_logic_1164.adb create mode 100644 src/vhdl/ieee-std_logic_1164.ads create mode 100644 src/vhdl/ieee-vital_timing.adb create mode 100644 src/vhdl/ieee-vital_timing.ads create mode 100644 src/vhdl/ieee.ads create mode 100644 src/vhdl/iir_chain_handling.adb create mode 100644 src/vhdl/iir_chain_handling.ads create mode 100644 src/vhdl/iir_chains.adb create mode 100644 src/vhdl/iir_chains.ads create mode 100644 src/vhdl/iirs.adb create mode 100644 src/vhdl/iirs.adb.in create mode 100644 src/vhdl/iirs.ads create mode 100644 src/vhdl/iirs_utils.adb create mode 100644 src/vhdl/iirs_utils.ads create mode 100644 src/vhdl/iirs_walk.adb create mode 100644 src/vhdl/iirs_walk.ads create mode 100644 src/vhdl/nodes.adb create mode 100644 src/vhdl/nodes.ads create mode 100644 src/vhdl/nodes_gc.adb create mode 100644 src/vhdl/nodes_gc.adb.in create mode 100644 src/vhdl/nodes_gc.ads create mode 100644 src/vhdl/nodes_meta.adb create mode 100644 src/vhdl/nodes_meta.adb.in create mode 100644 src/vhdl/nodes_meta.ads create mode 100644 src/vhdl/nodes_meta.ads.in create mode 100644 src/vhdl/parse.adb create mode 100644 src/vhdl/parse.ads create mode 100644 src/vhdl/parse_psl.adb create mode 100644 src/vhdl/parse_psl.ads create mode 100644 src/vhdl/post_sems.adb create mode 100644 src/vhdl/post_sems.ads create mode 100644 src/vhdl/psl-errors.ads create mode 100644 src/vhdl/scanner-scan_literal.adb create mode 100644 src/vhdl/scanner.adb create mode 100644 src/vhdl/scanner.ads create mode 100644 src/vhdl/sem.adb create mode 100644 src/vhdl/sem.ads create mode 100644 src/vhdl/sem_assocs.adb create mode 100644 src/vhdl/sem_assocs.ads create mode 100644 src/vhdl/sem_decls.adb create mode 100644 src/vhdl/sem_decls.ads create mode 100644 src/vhdl/sem_expr.adb create mode 100644 src/vhdl/sem_expr.ads create mode 100644 src/vhdl/sem_inst.adb create mode 100644 src/vhdl/sem_inst.ads create mode 100644 src/vhdl/sem_names.adb create mode 100644 src/vhdl/sem_names.ads create mode 100644 src/vhdl/sem_psl.adb create mode 100644 src/vhdl/sem_psl.ads create mode 100644 src/vhdl/sem_scopes.adb create mode 100644 src/vhdl/sem_scopes.ads create mode 100644 src/vhdl/sem_specs.adb create mode 100644 src/vhdl/sem_specs.ads create mode 100644 src/vhdl/sem_stmts.adb create mode 100644 src/vhdl/sem_stmts.ads create mode 100644 src/vhdl/sem_types.adb create mode 100644 src/vhdl/sem_types.ads create mode 100644 src/vhdl/std_package.adb create mode 100644 src/vhdl/std_package.ads create mode 100644 src/vhdl/tokens.adb create mode 100644 src/vhdl/tokens.ads create mode 100644 src/vhdl/xrefs.adb create mode 100644 src/vhdl/xrefs.ads delete mode 100644 src/xrefs.adb delete mode 100644 src/xrefs.ads (limited to 'src') diff --git a/src/back_end.adb b/src/back_end.adb deleted file mode 100644 index 81bc207..0000000 --- a/src/back_end.adb +++ /dev/null @@ -1,38 +0,0 @@ --- 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/back_end.ads b/src/back_end.ads deleted file mode 100644 index 3ee1e68..0000000 --- a/src/back_end.ads +++ /dev/null @@ -1,57 +0,0 @@ --- 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/canon.adb b/src/canon.adb deleted file mode 100644 index cd2dae0..0000000 --- a/src/canon.adb +++ /dev/null @@ -1,2735 +0,0 @@ --- 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/canon.ads b/src/canon.ads deleted file mode 100644 index 574a318..0000000 --- a/src/canon.ads +++ /dev/null @@ -1,70 +0,0 @@ --- 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/canon_psl.adb b/src/canon_psl.adb deleted file mode 100644 index 1e1d8de..0000000 --- a/src/canon_psl.adb +++ /dev/null @@ -1,43 +0,0 @@ --- 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/canon_psl.ads b/src/canon_psl.ads deleted file mode 100644 index 3a8c501..0000000 --- a/src/canon_psl.ads +++ /dev/null @@ -1,26 +0,0 @@ --- 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/configuration.adb b/src/configuration.adb deleted file mode 100644 index f570b69..0000000 --- a/src/configuration.adb +++ /dev/null @@ -1,614 +0,0 @@ --- 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/configuration.ads b/src/configuration.ads deleted file mode 100644 index 0a19a23..0000000 --- a/src/configuration.ads +++ /dev/null @@ -1,55 +0,0 @@ --- 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/disp_tree.adb b/src/disp_tree.adb deleted file mode 100644 index fbaaa93..0000000 --- a/src/disp_tree.adb +++ /dev/null @@ -1,511 +0,0 @@ --- 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 ""; - 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/disp_tree.ads b/src/disp_tree.ads deleted file mode 100644 index 94b1d29..0000000 --- a/src/disp_tree.ads +++ /dev/null @@ -1,27 +0,0 @@ --- 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/disp_vhdl.adb b/src/disp_vhdl.adb deleted file mode 100644 index 73a8e42..0000000 --- a/src/disp_vhdl.adb +++ /dev/null @@ -1,3247 +0,0 @@ --- 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 (""); - 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 (""); - 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 (""); - when Iir_Kind_Floating_Type_Definition => - Put (""); - when Iir_Kind_Physical_Type_Definition => - Put (""); - 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 (" "); - 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/disp_vhdl.ads b/src/disp_vhdl.ads deleted file mode 100644 index 880290e..0000000 --- a/src/disp_vhdl.ads +++ /dev/null @@ -1,38 +0,0 @@ --- 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/errorout.adb b/src/errorout.adb deleted file mode 100644 index 1652bb4..0000000 --- a/src/errorout.adb +++ /dev/null @@ -1,1113 +0,0 @@ --- 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/errorout.ads b/src/errorout.ads deleted file mode 100644 index ce694fe..0000000 --- a/src/errorout.ads +++ /dev/null @@ -1,128 +0,0 @@ --- 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/evaluation.adb b/src/evaluation.adb deleted file mode 100644 index 8279e14..0000000 --- a/src/evaluation.adb +++ /dev/null @@ -1,3047 +0,0 @@ --- 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/evaluation.ads b/src/evaluation.ads deleted file mode 100644 index 66ec2a1..0000000 --- a/src/evaluation.ads +++ /dev/null @@ -1,161 +0,0 @@ --- 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/ieee-std_logic_1164.adb b/src/ieee-std_logic_1164.adb deleted file mode 100644 index ee58fe7..0000000 --- a/src/ieee-std_logic_1164.adb +++ /dev/null @@ -1,170 +0,0 @@ --- 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/ieee-std_logic_1164.ads b/src/ieee-std_logic_1164.ads deleted file mode 100644 index b1f14f2..0000000 --- a/src/ieee-std_logic_1164.ads +++ /dev/null @@ -1,35 +0,0 @@ --- 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/ieee-vital_timing.adb b/src/ieee-vital_timing.adb deleted file mode 100644 index d6429e2..0000000 --- a/src/ieee-vital_timing.adb +++ /dev/null @@ -1,1377 +0,0 @@ --- 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; - - -- ::= - -- - -- | - -- | _ - 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; - - -- ::= - -- [_] - -- - -- ::= - -- [_] - -- | [_]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 - -- ::= - -- TPD__[_] - 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 '_'. - 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/ieee-vital_timing.ads b/src/ieee-vital_timing.ads deleted file mode 100644 index 7abda2e..0000000 --- a/src/ieee-vital_timing.ads +++ /dev/null @@ -1,41 +0,0 @@ --- 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/ieee.ads b/src/ieee.ads deleted file mode 100644 index 48ab376..0000000 --- a/src/ieee.ads +++ /dev/null @@ -1,5 +0,0 @@ --- Top of ieee hierarchy. --- Too small to be copyrighted. -package Ieee is - pragma Pure (Ieee); -end Ieee; diff --git a/src/iir_chain_handling.adb b/src/iir_chain_handling.adb deleted file mode 100644 index 1e70a36..0000000 --- a/src/iir_chain_handling.adb +++ /dev/null @@ -1,68 +0,0 @@ --- 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/iir_chain_handling.ads b/src/iir_chain_handling.ads deleted file mode 100644 index 3865e9b..0000000 --- a/src/iir_chain_handling.ads +++ /dev/null @@ -1,47 +0,0 @@ --- 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/iir_chains.adb b/src/iir_chains.adb deleted file mode 100644 index ef47b64..0000000 --- a/src/iir_chains.adb +++ /dev/null @@ -1,64 +0,0 @@ --- 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/iir_chains.ads b/src/iir_chains.ads deleted file mode 100644 index dc2f389..0000000 --- a/src/iir_chains.ads +++ /dev/null @@ -1,113 +0,0 @@ --- 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/iirs.adb b/src/iirs.adb deleted file mode 100644 index 876d146..0000000 --- a/src/iirs.adb +++ /dev/null @@ -1,4515 +0,0 @@ --- 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/iirs.adb.in b/src/iirs.adb.in deleted file mode 100644 index 04511bb..0000000 --- a/src/iirs.adb.in +++ /dev/null @@ -1,229 +0,0 @@ --- 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/iirs.ads b/src/iirs.ads deleted file mode 100644 index cd58daa..0000000 --- a/src/iirs.ads +++ /dev/null @@ -1,6445 +0,0 @@ --- 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/iirs_utils.adb b/src/iirs_utils.adb deleted file mode 100644 index 52c1ee8..0000000 --- a/src/iirs_utils.adb +++ /dev/null @@ -1,1131 +0,0 @@ --- 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/iirs_utils.ads b/src/iirs_utils.ads deleted file mode 100644 index a588ab8..0000000 --- a/src/iirs_utils.ads +++ /dev/null @@ -1,250 +0,0 @@ --- 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/iirs_walk.adb b/src/iirs_walk.adb deleted file mode 100644 index 3998329..0000000 --- a/src/iirs_walk.adb +++ /dev/null @@ -1,115 +0,0 @@ --- 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/iirs_walk.ads b/src/iirs_walk.ads deleted file mode 100644 index 4c098f7..0000000 --- a/src/iirs_walk.ads +++ /dev/null @@ -1,45 +0,0 @@ --- 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/nodes.adb b/src/nodes.adb deleted file mode 100644 index 2dc7736..0000000 --- a/src/nodes.adb +++ /dev/null @@ -1,467 +0,0 @@ --- 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/nodes.ads b/src/nodes.ads deleted file mode 100644 index adf6a5e..0000000 --- a/src/nodes.ads +++ /dev/null @@ -1,335 +0,0 @@ --- 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/nodes_gc.adb b/src/nodes_gc.adb deleted file mode 100644 index 38966f2..0000000 --- a/src/nodes_gc.adb +++ /dev/null @@ -1,206 +0,0 @@ --- 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/nodes_gc.adb.in b/src/nodes_gc.adb.in deleted file mode 100644 index 7c4303b..0000000 --- a/src/nodes_gc.adb.in +++ /dev/null @@ -1,159 +0,0 @@ --- 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/nodes_gc.ads b/src/nodes_gc.ads deleted file mode 100644 index ef8e647..0000000 --- a/src/nodes_gc.ads +++ /dev/null @@ -1,24 +0,0 @@ --- 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/nodes_meta.adb b/src/nodes_meta.adb deleted file mode 100644 index 3e038f5..0000000 --- a/src/nodes_meta.adb +++ /dev/null @@ -1,9409 +0,0 @@ --- 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/nodes_meta.adb.in b/src/nodes_meta.adb.in deleted file mode 100644 index d94c2d6..0000000 --- a/src/nodes_meta.adb.in +++ /dev/null @@ -1,76 +0,0 @@ --- 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/nodes_meta.ads b/src/nodes_meta.ads deleted file mode 100644 index 2d1f5e1..0000000 --- a/src/nodes_meta.ads +++ /dev/null @@ -1,823 +0,0 @@ --- 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/nodes_meta.ads.in b/src/nodes_meta.ads.in deleted file mode 100644 index 8e1dcec..0000000 --- a/src/nodes_meta.ads.in +++ /dev/null @@ -1,66 +0,0 @@ --- 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/parse.adb b/src/parse.adb deleted file mode 100644 index 97ff876..0000000 --- a/src/parse.adb +++ /dev/null @@ -1,7143 +0,0 @@ --- 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/parse.ads b/src/parse.ads deleted file mode 100644 index 26bdef3..0000000 --- a/src/parse.ads +++ /dev/null @@ -1,44 +0,0 @@ --- 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/parse_psl.adb b/src/parse_psl.adb deleted file mode 100644 index 7cb20ca..0000000 --- a/src/parse_psl.adb +++ /dev/null @@ -1,667 +0,0 @@ --- 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/parse_psl.ads b/src/parse_psl.ads deleted file mode 100644 index 62869fe..0000000 --- a/src/parse_psl.ads +++ /dev/null @@ -1,26 +0,0 @@ --- 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/post_sems.adb b/src/post_sems.adb deleted file mode 100644 index 78eda50..0000000 --- a/src/post_sems.adb +++ /dev/null @@ -1,71 +0,0 @@ --- 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/post_sems.ads b/src/post_sems.ads deleted file mode 100644 index ed04226..0000000 --- a/src/post_sems.ads +++ /dev/null @@ -1,25 +0,0 @@ --- 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/psl-errors.ads b/src/psl-errors.ads deleted file mode 100644 index e99bb7d..0000000 --- a/src/psl-errors.ads +++ /dev/null @@ -1,3 +0,0 @@ -with Errorout; - -package PSL.Errors renames Errorout; diff --git a/src/scanner-scan_literal.adb b/src/scanner-scan_literal.adb deleted file mode 100644 index 74acf44..0000000 --- a/src/scanner-scan_literal.adb +++ /dev/null @@ -1,651 +0,0 @@ --- 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/scanner.adb b/src/scanner.adb deleted file mode 100644 index 260bd7c..0000000 --- a/src/scanner.adb +++ /dev/null @@ -1,1621 +0,0 @@ --- 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/scanner.ads b/src/scanner.ads deleted file mode 100644 index ddc0d18..0000000 --- a/src/scanner.ads +++ /dev/null @@ -1,120 +0,0 @@ --- 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/sem.adb b/src/sem.adb deleted file mode 100644 index e82bd72..0000000 --- a/src/sem.adb +++ /dev/null @@ -1,2749 +0,0 @@ --- 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/sem.ads b/src/sem.ads deleted file mode 100644 index 5586483..0000000 --- a/src/sem.ads +++ /dev/null @@ -1,82 +0,0 @@ --- 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/sem_assocs.adb b/src/sem_assocs.adb deleted file mode 100644 index 96e6608..0000000 --- a/src/sem_assocs.adb +++ /dev/null @@ -1,1903 +0,0 @@ --- 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/sem_assocs.ads b/src/sem_assocs.ads deleted file mode 100644 index ec460e0..0000000 --- a/src/sem_assocs.ads +++ /dev/null @@ -1,60 +0,0 @@ --- 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/sem_decls.adb b/src/sem_decls.adb deleted file mode 100644 index a7c0b4b..0000000 --- a/src/sem_decls.adb +++ /dev/null @@ -1,3018 +0,0 @@ --- 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/sem_decls.ads b/src/sem_decls.ads deleted file mode 100644 index 7a8e240..0000000 --- a/src/sem_decls.ads +++ /dev/null @@ -1,52 +0,0 @@ --- 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/sem_expr.adb b/src/sem_expr.adb deleted file mode 100644 index f7af76c..0000000 --- a/src/sem_expr.adb +++ /dev/null @@ -1,4262 +0,0 @@ --- 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/sem_expr.ads b/src/sem_expr.ads deleted file mode 100644 index a0422e7..0000000 --- a/src/sem_expr.ads +++ /dev/null @@ -1,178 +0,0 @@ --- 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/sem_inst.adb b/src/sem_inst.adb deleted file mode 100644 index a9ba756..0000000 --- a/src/sem_inst.adb +++ /dev/null @@ -1,639 +0,0 @@ --- 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/sem_inst.ads b/src/sem_inst.ads deleted file mode 100644 index da8cd5d..0000000 --- a/src/sem_inst.ads +++ /dev/null @@ -1,26 +0,0 @@ --- 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/sem_names.adb b/src/sem_names.adb deleted file mode 100644 index 151e817..0000000 --- a/src/sem_names.adb +++ /dev/null @@ -1,3788 +0,0 @@ --- 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/sem_names.ads b/src/sem_names.ads deleted file mode 100644 index 3bc8530..0000000 --- a/src/sem_names.ads +++ /dev/null @@ -1,159 +0,0 @@ --- 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/sem_psl.adb b/src/sem_psl.adb deleted file mode 100644 index cae63f7..0000000 --- a/src/sem_psl.adb +++ /dev/null @@ -1,617 +0,0 @@ --- 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/sem_psl.ads b/src/sem_psl.ads deleted file mode 100644 index 59df96f..0000000 --- a/src/sem_psl.ads +++ /dev/null @@ -1,26 +0,0 @@ --- 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/sem_scopes.adb b/src/sem_scopes.adb deleted file mode 100644 index 71c7585..0000000 --- a/src/sem_scopes.adb +++ /dev/null @@ -1,1412 +0,0 @@ --- 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/sem_scopes.ads b/src/sem_scopes.ads deleted file mode 100644 index 76faaf1..0000000 --- a/src/sem_scopes.ads +++ /dev/null @@ -1,217 +0,0 @@ --- 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/sem_specs.adb b/src/sem_specs.adb deleted file mode 100644 index ca821b2..0000000 --- a/src/sem_specs.adb +++ /dev/null @@ -1,1731 +0,0 @@ --- 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/sem_specs.ads b/src/sem_specs.ads deleted file mode 100644 index c27207b..0000000 --- a/src/sem_specs.ads +++ /dev/null @@ -1,88 +0,0 @@ --- 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/sem_stmts.adb b/src/sem_stmts.adb deleted file mode 100644 index b5912fb..0000000 --- a/src/sem_stmts.adb +++ /dev/null @@ -1,2007 +0,0 @@ --- 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/sem_stmts.ads b/src/sem_stmts.ads deleted file mode 100644 index d3eeb8c..0000000 --- a/src/sem_stmts.ads +++ /dev/null @@ -1,87 +0,0 @@ --- 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/sem_types.adb b/src/sem_types.adb deleted file mode 100644 index 12f276b..0000000 --- a/src/sem_types.adb +++ /dev/null @@ -1,2210 +0,0 @@ --- 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/sem_types.ads b/src/sem_types.ads deleted file mode 100644 index 8eb7de1..0000000 --- a/src/sem_types.ads +++ /dev/null @@ -1,57 +0,0 @@ --- 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/std_package.adb b/src/std_package.adb deleted file mode 100644 index 1edfb6c..0000000 --- a/src/std_package.adb +++ /dev/null @@ -1,1200 +0,0 @@ --- 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/std_package.ads b/src/std_package.ads deleted file mode 100644 index 166c3c7..0000000 --- a/src/std_package.ads +++ /dev/null @@ -1,182 +0,0 @@ --- 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/tokens.adb b/src/tokens.adb deleted file mode 100644 index 5d27be8..0000000 --- a/src/tokens.adb +++ /dev/null @@ -1,443 +0,0 @@ --- 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 ""; - 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 ""; - when Tok_Newline => - return ""; - when Tok_Comment => - return ""; - when Tok_Character => - return ""; - when Tok_Identifier => - return ""; - when Tok_Integer => - return ""; - when Tok_Real => - return ""; - when Tok_String => - return ""; - when Tok_Bit_String => - return ""; - - 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/tokens.ads b/src/tokens.ads deleted file mode 100644 index c728731..0000000 --- a/src/tokens.ads +++ /dev/null @@ -1,279 +0,0 @@ --- 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/back_end.adb b/src/vhdl/back_end.adb new file mode 100644 index 0000000..81bc207 --- /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 0000000..3ee1e68 --- /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 0000000..cd2dae0 --- /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 0000000..574a318 --- /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 0000000..1e1d8de --- /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 0000000..3a8c501 --- /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 0000000..f570b69 --- /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 0000000..0a19a23 --- /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 0000000..fbaaa93 --- /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 ""; + 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 0000000..94b1d29 --- /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 0000000..73a8e42 --- /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 (""); + 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 (""); + 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 (""); + when Iir_Kind_Floating_Type_Definition => + Put (""); + when Iir_Kind_Physical_Type_Definition => + Put (""); + 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 (" "); + 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 0000000..880290e --- /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 0000000..1652bb4 --- /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 0000000..ce694fe --- /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 0000000..8279e14 --- /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 0000000..66ec2a1 --- /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 0000000..ee58fe7 --- /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 0000000..b1f14f2 --- /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 0000000..d6429e2 --- /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; + + -- ::= + -- + -- | + -- | _ + 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; + + -- ::= + -- [_] + -- + -- ::= + -- [_] + -- | [_]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 + -- ::= + -- TPD__[_] + 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 '_'. + 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 0000000..7abda2e --- /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 0000000..48ab376 --- /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 0000000..1e70a36 --- /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 0000000..3865e9b --- /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 0000000..ef47b64 --- /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 0000000..dc2f389 --- /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 0000000..876d146 --- /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 0000000..04511bb --- /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 0000000..cd58daa --- /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 0000000..52c1ee8 --- /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 0000000..a588ab8 --- /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 0000000..3998329 --- /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 0000000..4c098f7 --- /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 0000000..2dc7736 --- /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 0000000..adf6a5e --- /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 0000000..38966f2 --- /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 0000000..7c4303b --- /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 0000000..ef8e647 --- /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 0000000..3e038f5 --- /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 0000000..d94c2d6 --- /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 0000000..2d1f5e1 --- /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 0000000..8e1dcec --- /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 0000000..97ff876 --- /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 0000000..26bdef3 --- /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 0000000..7cb20ca --- /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 0000000..62869fe --- /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 0000000..78eda50 --- /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 0000000..ed04226 --- /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 0000000..e99bb7d --- /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 0000000..74acf44 --- /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 0000000..260bd7c --- /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 0000000..ddc0d18 --- /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 0000000..e82bd72 --- /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 0000000..5586483 --- /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 0000000..96e6608 --- /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 0000000..ec460e0 --- /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 0000000..a7c0b4b --- /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 0000000..7a8e240 --- /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 0000000..f7af76c --- /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 0000000..a0422e7 --- /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 0000000..a9ba756 --- /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 0000000..da8cd5d --- /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 0000000..151e817 --- /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 0000000..3bc8530 --- /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 0000000..cae63f7 --- /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 0000000..59df96f --- /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 0000000..71c7585 --- /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 0000000..76faaf1 --- /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 0000000..ca821b2 --- /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 0000000..c27207b --- /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 0000000..b5912fb --- /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 0000000..d3eeb8c --- /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 0000000..12f276b --- /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 0000000..8eb7de1 --- /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 0000000..1edfb6c --- /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 0000000..166c3c7 --- /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 0000000..5d27be8 --- /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 ""; + 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 ""; + when Tok_Newline => + return ""; + when Tok_Comment => + return ""; + when Tok_Character => + return ""; + when Tok_Identifier => + return ""; + when Tok_Integer => + return ""; + when Tok_Real => + return ""; + when Tok_String => + return ""; + when Tok_Bit_String => + return ""; + + 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 0000000..c728731 --- /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 0000000..1569669 --- /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 0000000..74f2d0c --- /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; diff --git a/src/xrefs.adb b/src/xrefs.adb deleted file mode 100644 index 1569669..0000000 --- a/src/xrefs.adb +++ /dev/null @@ -1,279 +0,0 @@ --- 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/xrefs.ads b/src/xrefs.ads deleted file mode 100644 index 74f2d0c..0000000 --- a/src/xrefs.ads +++ /dev/null @@ -1,108 +0,0 @@ --- 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; -- cgit