diff options
| -rw-r--r-- | disp_tree.adb | 14 | ||||
| -rw-r--r-- | disp_vhdl.adb | 2 | ||||
| -rw-r--r-- | errorout.adb | 6 | ||||
| -rw-r--r-- | iirs.adb | 59 | ||||
| -rw-r--r-- | iirs.ads | 62 | ||||
| -rw-r--r-- | iirs_utils.adb | 31 | ||||
| -rw-r--r-- | iirs_utils.ads | 6 | ||||
| -rw-r--r-- | libraries.adb | 12 | ||||
| -rw-r--r-- | libraries/Makefile.inc | 11 | ||||
| -rw-r--r-- | parse.adb | 189 | ||||
| -rw-r--r-- | sem.adb | 175 | ||||
| -rw-r--r-- | sem_decls.adb | 224 | ||||
| -rw-r--r-- | sem_expr.adb | 5 | ||||
| -rw-r--r-- | sem_scopes.adb | 187 |
14 files changed, 748 insertions, 235 deletions
diff --git a/disp_tree.adb b/disp_tree.adb index 40a949cff..a14030bf7 100644 --- a/disp_tree.adb +++ b/disp_tree.adb @@ -699,6 +699,11 @@ package body Disp_Tree is Disp_Tree_Flat (Get_Package (Tree), Ntab); Header ("declaration:"); Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); + when Iir_Kind_Package_Header => + Header ("generic chain:"); + Disp_Tree_Chain (Get_Generic_Chain (Tree), Ntab); + Header ("generic map aspect chain:"); + Disp_Tree_Chain (Get_Generic_Map_Aspect_Chain (Tree), Ntab); when Iir_Kind_Architecture_Declaration => if Flat_Decl then return; @@ -720,6 +725,15 @@ package body Disp_Tree is Header ("block_configuration:"); Disp_Tree (Get_Block_Configuration (Tree), Ntab, True); + when Iir_Kind_Package_Instantiation_Declaration => + if Flat_Decl then + return; + end if; + Header ("uninstantiated_name:"); + Disp_Tree_Flat (Get_Uninstantiated_Name (Tree), Ntab); + Header ("generic map aspect chain:"); + Disp_Tree_Chain (Get_Generic_Map_Aspect_Chain (Tree), Ntab); + when Iir_Kind_Entity_Aspect_Entity => Header ("entity:"); Disp_Tree_Flat (Get_Entity (Tree), Ntab); diff --git a/disp_vhdl.adb b/disp_vhdl.adb index fd75ea0dc..0b4627a44 100644 --- a/disp_vhdl.adb +++ b/disp_vhdl.adb @@ -210,7 +210,9 @@ package body Disp_Vhdl is Put ("."); Disp_Ident (Get_Suffix_Identifier (Name)); 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_Kind_Variable_Declaration diff --git a/errorout.adb b/errorout.adb index cd7f4f746..404c91f37 100644 --- a/errorout.adb +++ b/errorout.adb @@ -605,6 +605,12 @@ package body Errorout is & '(' & Iirs_Utils.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"); @@ -381,6 +381,7 @@ package body Iirs is | Iir_Kind_Nature_Declaration | Iir_Kind_Subnature_Declaration | Iir_Kind_Configuration_Declaration + | Iir_Kind_Package_Declaration | Iir_Kind_Package_Body | Iir_Kind_Attribute_Declaration | Iir_Kind_Group_Template_Declaration @@ -514,8 +515,9 @@ package body Iirs is | Iir_Kind_Subtype_Definition | Iir_Kind_Scalar_Nature_Definition | Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration | Iir_Kind_Architecture_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Package_Header | Iir_Kind_Unit_Declaration | Iir_Kind_Library_Declaration | Iir_Kind_Component_Declaration @@ -2247,7 +2249,7 @@ package body Iirs is case Get_Kind (Target) is when Iir_Kind_Block_Header | Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Header | Iir_Kind_Component_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration @@ -2971,7 +2973,8 @@ package body Iirs is | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration | Iir_Kind_Package_Body - | Iir_Kind_Architecture_Declaration => + | Iir_Kind_Architecture_Declaration + | Iir_Kind_Package_Instantiation_Declaration => null; when others => Failed ("Design_Unit", Target); @@ -3434,6 +3437,7 @@ package body Iirs is | Iir_Kind_Package_Declaration | Iir_Kind_Package_Body | Iir_Kind_Architecture_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Unit_Declaration | Iir_Kind_Library_Declaration | Iir_Kind_Component_Declaration @@ -3569,6 +3573,7 @@ package body Iirs is | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration | Iir_Kind_Architecture_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Unit_Declaration | Iir_Kind_Library_Declaration | Iir_Kind_Component_Declaration @@ -4948,7 +4953,8 @@ package body Iirs is case Get_Kind (Target) is when Iir_Kind_Block_Header | Iir_Kind_Binding_Indication - | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Package_Header | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration @@ -5295,6 +5301,28 @@ package body Iirs is Set_Field6 (Block, Conf); end Set_Block_Block_Configuration; + procedure Check_Kind_For_Package_Header (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Package_Declaration => + null; + when others => + Failed ("Package_Header", Target); + end case; + end Check_Kind_For_Package_Header; + + function Get_Package_Header (Pkg : Iir) return Iir_Package_Body is + begin + Check_Kind_For_Package_Header (Pkg); + return Get_Field5 (Pkg); + end Get_Package_Header; + + procedure Set_Package_Header (Pkg : Iir; Header : Iir_Package_Body) is + begin + Check_Kind_For_Package_Header (Pkg); + Set_Field5 (Pkg, Header); + end Set_Package_Header; + procedure Check_Kind_For_Block_Header (Target : Iir) is begin case Get_Kind (Target) is @@ -5317,6 +5345,28 @@ package body Iirs is Set_Field7 (Target, Header); end Set_Block_Header; + procedure Check_Kind_For_Uninstantiated_Name (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Package_Instantiation_Declaration => + null; + when others => + Failed ("Uninstantiated_Name", Target); + end case; + end Check_Kind_For_Uninstantiated_Name; + + function Get_Uninstantiated_Name (Inst : Iir) return Iir is + begin + Check_Kind_For_Uninstantiated_Name (Inst); + return Get_Field1 (Inst); + end Get_Uninstantiated_Name; + + procedure Set_Uninstantiated_Name (Inst : Iir; Name : Iir) is + begin + Check_Kind_For_Uninstantiated_Name (Inst); + Set_Field1 (Inst, Name); + end Set_Uninstantiated_Name; + procedure Check_Kind_For_Generate_Block_Configuration (Target : Iir) is begin case Get_Kind (Target) is @@ -5463,6 +5513,7 @@ package body Iirs is | Iir_Kind_Package_Declaration | Iir_Kind_Package_Body | Iir_Kind_Architecture_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Component_Declaration | Iir_Kind_Attribute_Declaration | Iir_Kind_Group_Template_Declaration @@ -664,7 +664,13 @@ package Iirs is -- -- Get/Set_Visible_Flag (Flag4) - -- Iir_Kind_Package_Declaration (Medium) + -- 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) @@ -675,11 +681,9 @@ package Iirs is -- -- Get/Set_Identifier (Field3) -- - -- Get/Set_Generic_Chain (Field6) - -- -- Get/Set_Attribute_Value_Chain (Field4) -- - -- Get/Set_Generic_Map_Aspect_Chain (Field8) + -- Get/Set_Package_Header (Field5) -- -- Get/Set_Need_Body (Flag1) -- @@ -699,6 +703,19 @@ package Iirs is -- The corresponding package declaration. -- Get/Set_Package (Field4) + -- Iir_Kind_Package_Instantiation_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- Get/Set_Design_Unit (Alias Field0) + -- + -- Get/Set_Uninstantiated_Name (Field1) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Generic_Map_Aspect_Chain (Field8) + -- + -- Get/Set_Visible_Flag (Flag4) + -- Iir_Kind_Library_Declaration (Medium) -- -- Design files in the library. @@ -2826,11 +2843,13 @@ package Iirs is Iir_Kind_Subtype_Declaration, Iir_Kind_Nature_Declaration, Iir_Kind_Subnature_Declaration, - Iir_Kind_Configuration_Declaration, - Iir_Kind_Entity_Declaration, - Iir_Kind_Package_Declaration, - Iir_Kind_Package_Body, - Iir_Kind_Architecture_Declaration, + Iir_Kind_Configuration_Declaration, -- Library_Unit + Iir_Kind_Entity_Declaration, -- Library_Unit + Iir_Kind_Package_Declaration, -- Library_Unit + Iir_Kind_Package_Body, -- Library_Unit + Iir_Kind_Architecture_Declaration, -- Library_Unit + Iir_Kind_Package_Instantiation_Declaration, + Iir_Kind_Package_Header, Iir_Kind_Unit_Declaration, Iir_Kind_Library_Declaration, Iir_Kind_Component_Declaration, @@ -2847,10 +2866,10 @@ package Iirs is Iir_Kind_Through_Quantity_Declaration, Iir_Kind_Function_Body, - Iir_Kind_Function_Declaration, - Iir_Kind_Implicit_Function_Declaration, - Iir_Kind_Implicit_Procedure_Declaration, - Iir_Kind_Procedure_Declaration, + 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_Procedure_Body, Iir_Kind_Enumeration_Literal, @@ -3379,7 +3398,8 @@ package Iirs is --Iir_Kind_Entity_Declaration --Iir_Kind_Package_Declaration --Iir_Kind_Package_Body - Iir_Kind_Architecture_Declaration; + --Iir_Kind_Architecture_Declaration + Iir_Kind_Package_Instantiation_Declaration; -- Note: does not include iir_kind_enumeration_literal since it is -- considered as a declaration. @@ -3529,6 +3549,10 @@ package Iirs is --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; @@ -3743,6 +3767,8 @@ package Iirs is --Iir_Kind_Package_Declaration --Iir_Kind_Package_Body --Iir_Kind_Architecture_Declaration + --Iir_Kind_Package_Instantiation_Declaration + --Iir_Kind_Package_Header --Iir_Kind_Unit_Declaration --Iir_Kind_Library_Declaration --Iir_Kind_Component_Declaration @@ -5120,10 +5146,18 @@ package Iirs is 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_Package_Body; + procedure Set_Package_Header (Pkg : Iir; Header : Iir_Package_Body); + -- Field: Field7 function Get_Block_Header (Target : Iir) return Iir; procedure Set_Block_Header (Target : Iir; Header : Iir); + -- Field: Field1 + function Get_Uninstantiated_Name (Inst : Iir) return Iir; + procedure Set_Uninstantiated_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. diff --git a/iirs_utils.adb b/iirs_utils.adb index fa69e8e23..060c3f74e 100644 --- a/iirs_utils.adb +++ b/iirs_utils.adb @@ -860,6 +860,37 @@ package body Iirs_Utils is end loop; 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 Get_HDL_Node (N : PSL_Node) return Iir is begin return Iir (PSL.Nodes.Get_HDL_Node (N)); diff --git a/iirs_utils.ads b/iirs_utils.ads index 8061cbabd..1477d8e20 100644 --- a/iirs_utils.ads +++ b/iirs_utils.ads @@ -150,6 +150,12 @@ package Iirs_Utils is -- See also Evaluation.Get_Physical_Value. function Get_Physical_Literal_Value (Lit : Iir) return Iir_Int64; + -- 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; diff --git a/libraries.adb b/libraries.adb index e48707d8e..a9efb0a2e 100644 --- a/libraries.adb +++ b/libraries.adb @@ -142,7 +142,8 @@ package body Libraries is when Iir_Kind_Entity_Declaration | Iir_Kind_Configuration_Declaration | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body => + | Iir_Kind_Package_Body + | Iir_Kind_Package_Instantiation_Declaration => Id := Get_Identifier (Lib_Unit); when Iir_Kind_Architecture_Declaration => -- Architectures are put with the entity identifier. @@ -1225,7 +1226,8 @@ package body Libraries is WR (Image_Identifier (Library_Unit)); WR (" of "); WR (Image_Identifier (Get_Entity (Library_Unit))); - when Iir_Kind_Package_Declaration => + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => WR ("package "); WR (Image_Identifier (Library_Unit)); when Iir_Kind_Package_Body => @@ -1576,12 +1578,16 @@ package body Libraries is then case Get_Kind (Get_Library_Unit (Unit)) is when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Entity_Declaration | Iir_Kind_Configuration_Declaration => -- Only return a primary unit. return Unit; - when others => + when Iir_Kind_Package_Body + | Iir_Kind_Architecture_Declaration => null; + when others => + raise Internal_Error; end case; end if; Unit := Get_Hash_Chain (Unit); diff --git a/libraries/Makefile.inc b/libraries/Makefile.inc index 5d48c4043..fed7457fa 100644 --- a/libraries/Makefile.inc +++ b/libraries/Makefile.inc @@ -55,12 +55,15 @@ ieee2008/numeric_bit.vhdl \ ieee2008/numeric_bit_unsigned.vhdl ieee2008/numeric_bit_unsigned-body.vhdl \ ieee2008/numeric_std.vhdl \ ieee2008/numeric_std-body.vhdl \ -ieee2008/numeric_std_unsigned.vhdl ieee2008/numeric_std_unsigned-body.vhdl +ieee2008/numeric_std_unsigned.vhdl ieee2008/numeric_std_unsigned-body.vhdl \ +ieee2008/fixed_float_types.vhdl \ +ieee2008/fixed_generic_pkg.vhdl \ +ieee2008/fixed_pkg.vhdl # ieee2008/numeric_bit-body.vhdl \ -#ieee2008/fixed_float_types.vhdl +# #ieee2008/fixed_generic_pkg-body.vhdl -#ieee2008/fixed_generic_pkg.vhdl -#ieee2008/fixed_pkg.vhdl + +# #ieee2008/float_generic_pkg-body.vhdl #ieee2008/float_generic_pkg.vhdl #ieee2008/float_pkg.vhdl @@ -190,6 +190,16 @@ package body Parse is 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. -- @@ -1175,21 +1185,17 @@ package body Parse is El := Get_Chain (El); end loop; - if Current_Token /= Tok_Semi_Colon then - Error_Msg_Parse ("missing "";"" at end of port clause"); - else - Scan; - end if; + Scan_Semi_Colon ("port clause"); Set_Port_Chain (Parent, Res); end Parse_Port_Clause; -- precond : GENERIC -- postcond: next token -- - -- [ §1.1.1 ] + -- [ LRM93 1.1.1, LRM08 6.5.6.2 ] -- generic_clause ::= GENERIC ( generic_list ) ; -- - -- [ §1.1.1.1] + -- [ LRM93 1.1.1.1, LRM08 6.5.6.2] -- generic_list ::= GENERIC_interface_list procedure Parse_Generic_Clause (Parent : Iir) is @@ -1203,12 +1209,9 @@ package body Parse is Scan; Res := Parse_Interface_Chain (Iir_Kind_Constant_Interface_Declaration, Parent); - if Current_Token /= Tok_Semi_Colon then - Error_Msg_Parse ("missing "";"" at end of generic clause"); - else - Scan; - end if; Set_Generic_Chain (Parent, Res); + + Scan_Semi_Colon ("generic clause"); end Parse_Generic_Clause; -- precond : a token. @@ -1462,17 +1465,25 @@ package body Parse is begin Res := Create_Iir (Iir_Kind_Physical_Type_Definition); Set_Location (Res); + + -- Eat 'units' Expect (Tok_Units); Scan; + -- Parse primary unit. Expect (Tok_Identifier); Unit := Create_Iir (Iir_Kind_Unit_Declaration); Set_Location (Unit); Set_Identifier (Unit, Current_Identifier); + + -- Skip identifier + Scan; + + Scan_Semi_Colon ("primary unit"); + Build_Init (Last); Append (Last, Res, Unit); - Scan_Expect (Tok_Semi_Colon); - Scan; + -- Parse secondary units. while Current_Token /= Tok_End loop Unit := Create_Iir (Iir_Kind_Unit_Declaration); @@ -1490,8 +1501,7 @@ package body Parse is Error_Msg_Parse ("a physical literal is expected here"); end case; Append (Last, Res, Unit); - Expect (Tok_Semi_Colon); - Scan; + Scan_Semi_Colon ("secondary unit"); end loop; Scan; Expect (Tok_Units); @@ -1555,8 +1565,7 @@ package body Parse is Subtype_Indication := Parse_Subtype_Indication; Set_Type (First, Subtype_Indication); First := Null_Iir; - Expect (Tok_Semi_Colon); - Scan; + Scan_Semi_Colon ("element declaration"); exit when Current_Token = Tok_End; end loop; Scan_Expect (Tok_Record); @@ -4810,21 +4819,31 @@ package body Parse is 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 (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; @@ -4845,8 +4864,7 @@ package body Parse is Set_Label (Stmt, Label); end if; end if; - Expect (Tok_Semi_Colon); - Scan; + Scan_Semi_Colon ("statement"); -- Append it to the chain. if First_Stmt = Null_Iir then @@ -5247,7 +5265,7 @@ package body Parse is -- precond : GENERIC -- postcond: next token -- - -- [ §5.2.1.2 ] + -- [ 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 @@ -5354,16 +5372,14 @@ package body Parse is Parse_Generic_Clause (Res); if Current_Token = Tok_Generic then Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); - Expect (Tok_Semi_Colon); - Scan; + 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); - Expect (Tok_Semi_Colon); - Scan; + Scan_Semi_Colon ("port map aspect"); end if; end if; return Res; @@ -6106,8 +6122,7 @@ package body Parse is | Tok_Generic | Tok_Port => Set_Binding_Indication (Res, Parse_Binding_Indication); - Expect (Tok_Semi_Colon); - Scan; + Scan_Semi_Colon ("binding indication"); when others => null; end case; @@ -6361,26 +6376,50 @@ package body Parse is Set_Library_Unit (Unit, Res); end Parse_Configuration_Declaration; - -- precond : identifier + -- 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: ';' -- - -- [ §2.5 ] + -- [ 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) + procedure Parse_Package_Declaration (Unit : Iir_Design_Unit; Id : Name_Id) is Res: Iir_Package_Declaration; begin Res := Create_Iir (Iir_Kind_Package_Declaration); Set_Location (Res); + Set_Identifier (Res, Id); - -- Get identifier. - Expect (Tok_Identifier); - Set_Identifier (Res, Current_Identifier); - Scan_Expect (Tok_Is); - Scan; + 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); @@ -6401,7 +6440,7 @@ package body Parse is -- precond : BODY -- postcond: ';' -- - -- [ §2.6 ] + -- [ LRM93 2.6, LRM08 4.8 ] -- package_body ::= -- PACKAGE BODY PACKAGE_simple_name IS -- package_body_declarative_part @@ -6436,6 +6475,76 @@ package body Parse is 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_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 : constant Location_Type := Get_Token_Location; + 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; + Scan; + + 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); + end if; + end if; + end Parse_Package; + -- Parse a design_unit. -- The lexical scanner must have been initialized, but without a -- current_token. @@ -6502,13 +6611,7 @@ package body Parse is when Tok_Architecture => Parse_Architecture (Res); when Tok_Package => - Scan; - if Current_Token = Tok_Body then - Scan; - Parse_Package_Body (Res); - else - Parse_Package_Declaration (Res); - end if; + Parse_Package (Res); when Tok_Configuration => Parse_Configuration_Declaration (Res); when others => @@ -334,22 +334,25 @@ package body Sem is return True; end Can_Collapse_Signals; - -- INTER_PARENT contains generics and ports interfaces; - -- ASSOC_PARENT constains generics and ports map aspects. - procedure Sem_Generic_Port_Association_Chain + -- INTER_PARENT contains generics interfaces; + -- ASSOC_PARENT constains generic aspects. + procedure Sem_Generic_Association_Chain (Inter_Parent : Iir; Assoc_Parent : Iir) is El : Iir; - Actual : Iir; - Prefix : Iir; - Object : Iir; Match : Boolean; Assoc_Chain : Iir; - Miss_Generic : Missing_Type; - Miss_Port : Missing_Type; - Inter : Iir; - Formal : 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 @@ -366,22 +369,22 @@ package body Sem is if Flags.Vhdl_Std = Vhdl_87 or else Get_Kind (Inter_Parent) = Iir_Kind_Entity_Declaration then - Miss_Generic := Missing_Generic; - Miss_Port := Missing_Port; + Miss := Missing_Generic; else - Miss_Generic := Missing_Allowed; - Miss_Port := Missing_Allowed; + Miss := Missing_Allowed; end if; when Iir_Kind_Binding_Indication => -- LRM 5.2.1.2 Generic map and port map aspects - Miss_Generic := Missing_Allowed; - Miss_Port := Missing_Allowed; + Miss := Missing_Allowed; when Iir_Kind_Block_Header => - -- FIXME: it is possible to have port unassociated ? - Miss_Generic := Missing_Generic; - Miss_Port := Missing_Port; + 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_port_association_list", Assoc_Parent); + Error_Kind ("sem_generic_association_list", Assoc_Parent); end case; -- The generics @@ -389,7 +392,7 @@ package body Sem is if Sem_Actual_Of_Association_Chain (Assoc_Chain) then Sem_Association_Chain (Get_Generic_Chain (Inter_Parent), Assoc_Chain, - True, Miss_Generic, Assoc_Parent, Match); + True, Miss, Assoc_Parent, Match); Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); -- LRM 5.2.1.2 Generic map and port map aspects @@ -406,13 +409,58 @@ package body Sem is when Iir_Kind_Association_Element_By_Individual => null; when others => - Error_Kind - ("sem_generic_port_map_association_chain(1)", El); + Error_Kind ("sem_generic_map_association_chain(1)", El); end case; El := Get_Chain (El); end loop; end if; end if; + 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; + 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); @@ -420,7 +468,7 @@ package body Sem is return; end if; Sem_Association_Chain (Get_Port_Chain (Inter_Parent), Assoc_Chain, - True, Miss_Port, Assoc_Parent, Match); + True, Miss, Assoc_Parent, Match); Set_Port_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); if not Match then return; @@ -528,6 +576,16 @@ package body Sem is 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 + 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. @@ -2172,6 +2230,7 @@ package body Sem is 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); @@ -2193,6 +2252,14 @@ package body Sem is Push_Signals_Declarative_Part (Implicit, Decl); + if Header /= Null_Iir then + Sem_Interface_Chain (Get_Generic_Chain (Header), Interface_Generic); + 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. @@ -2257,6 +2324,49 @@ package body Sem is Close_Declarative_Region; end Sem_Package_Body; + -- LRM08 4.9 Package Instantiation Declaration + procedure Sem_Package_Instantiation_Declaration (Decl : Iir) + is + Name : Iir; + Pkg : Iir; + 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. + Name := Get_Uninstantiated_Name (Decl); + Sem_Name (Name, False); + Pkg := Get_Named_Entity (Name); + if Get_Kind (Pkg) = Iir_Kind_Design_Unit then + Pkg := Get_Library_Unit (Pkg); + Set_Named_Entity (Name, Pkg); + end if; + if Get_Kind (Pkg) /= Iir_Kind_Package_Declaration then + Error_Msg_Sem ("name must denote a package declaration", Name); + + -- What could be done ? + return; + elsif not Is_Uninstantiated_Package (Pkg) then + Error_Msg_Sem + (Disp_Node (Pkg) & " is not an uninstantiated package", Name); + + -- What could be done ? + return; + end if; + + Xref_Name (Name); + + -- 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. + Sem_Generic_Association_Chain (Get_Package_Header (Pkg), Decl); + end Sem_Package_Instantiation_Declaration; + -- LRM 10.4 Use Clauses. procedure Sem_Use_Clause (Clauses: Iir_Use_Clause) is @@ -2305,11 +2415,20 @@ package body Sem is case Get_Kind (Prefix_Name) is when Iir_Kind_Library_Declaration => null; - when Iir_Kind_Package_Declaration => + when Iir_Kind_Package_Instantiation_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_Name) then + Error_Msg_Sem + ("use of uninstantiated package is not allowed", Prefix); + return; + end if; when others => - Error_Msg_Sem ("prefix must designate a package or a library", - Prefix); + Error_Msg_Sem + ("prefix must designate a package or a library", Prefix); return; end case; @@ -2460,6 +2579,8 @@ package body Sem is 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; diff --git a/sem_decls.adb b/sem_decls.adb index 09042c404..4ad015c2e 100644 --- a/sem_decls.adb +++ b/sem_decls.adb @@ -1900,6 +1900,136 @@ package body Sem_Decls is 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_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); + begin + Location_Copy (N_Alias, Alias); + Set_Identifier (N_Alias, Get_Identifier (Decl)); + Set_Name (N_Alias, Decl); + Set_Parent (N_Alias, Get_Parent (Alias)); + + 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 @@ -1924,94 +2054,16 @@ package body Sem_Decls is Alias); end if; when Iir_Kind_Type_Declaration => - declare - Def : Iir; - Last : Iir; - El : Iir; - Enum_List : Iir_Enumeration_Literal_List; - - procedure Add_Implicit_Alias (Decl : Iir) - is - N_Alias : constant Iir_Non_Object_Alias_Declaration := - Create_Iir (Iir_Kind_Non_Object_Alias_Declaration); - begin - Location_Copy (N_Alias, Alias); - Set_Identifier (N_Alias, Get_Identifier (Decl)); - Set_Name (N_Alias, Decl); - - Add_Name (El, Get_Identifier (El), False); - 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 - Def := Get_Type (N_Entity); - 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; [...] - 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. - 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). - if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then - raise Internal_Error; - 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. - El := Get_Chain (N_Entity); - 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) /= N_Entity; - when others => - exit; - end case; - Add_Implicit_Alias (El); - El := Get_Chain (El); - end loop; - end; + 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_Subtype_Declaration - | Iir_Kind_Attribute_Declaration + when Iir_Kind_Attribute_Declaration | Iir_Kind_Component_Declaration => null; when Iir_Kind_Terminal_Declaration => diff --git a/sem_expr.adb b/sem_expr.adb index 0814355c3..33addfde6 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -1696,7 +1696,10 @@ package body Sem_Expr is raise Internal_Error; end if; - -- If DECL has already been seen, then skip it. + -- 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; diff --git a/sem_scopes.adb b/sem_scopes.adb index 810c70d43..e00ffb809 100644 --- a/sem_scopes.adb +++ b/sem_scopes.adb @@ -17,6 +17,7 @@ -- 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; @@ -446,7 +447,10 @@ package body Sem_Scopes is if Current_Inter = No_Name_Interpretation or else (Current_Inter = Conflict_Interpretation and not Potentially) then - -- Very simple: no hide, no overloading. + -- Very simple: no hidding, no overloading. + -- (current interpretation is Conflict_Interpretation if there is + -- only potentially visible declarations that are not made directly + -- visible). Save_Current_Interpretation; Add_New_Interpretation; return; @@ -457,6 +461,7 @@ package body Sem_Scopes is -- Yet another conflicting interpretation. return; end if; + -- Do not re-add a potential decl declare Inter: Name_Interpretation_Type := Current_Inter; @@ -470,7 +475,7 @@ package body Sem_Scopes is end; end if; - -- LRM §10.3: + -- 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 @@ -483,9 +488,10 @@ package body Sem_Scopes is Current_Decl := Get_Declaration (Current_Inter); if Is_Overloadable (Current_Decl) and then Is_Overloadable (Decl) then - -- Current_Inter and Decl overloads. + -- Current_Inter and Decl overloads (well, they have the same + -- designator). - -- LRM 10.3 + -- 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 @@ -494,6 +500,7 @@ package body Sem_Scopes is declare Homograph : Name_Interpretation_Type; Prev_Homograph : Name_Interpretation_Type; + Current_Decl_Non_Alias : Iir; procedure Maybe_Save_And_Add_New_Interpretation is begin @@ -536,6 +543,15 @@ package body Sem_Scopes is end if; end Get_Hash_Non_Alias; + -- Return TRUE iff D is an implicit alias of an implicit + -- subprogram. + function Is_Implicit_Alias (D : Iir) return Boolean is + begin + return Get_Kind (D) = Iir_Kind_Non_Object_Alias_Declaration + and then Get_Kind (Get_Name (D)) + in Iir_Kinds_Implicit_Subprogram_Declaration; + end Is_Implicit_Alias; + Decl_Hash : Iir_Int32; Hash : Iir_Int32; begin @@ -559,74 +575,126 @@ package body Sem_Scopes is if Homograph = No_Name_Interpretation then -- Simple case: no homograph. Maybe_Save_And_Add_New_Interpretation; - else - -- There is an homograph. - if Potentially then - -- 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. - if Is_In_Current_Declarative_Region (Homograph) then - if not Is_Potentially_Visible (Homograph) then - return; - end if; + return; + 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 LRM. - if Get_Parent (Decl) = Get_Parent (Current_Decl) then - -- Note: no need to save previous interpretation! - Add_New_Interpretation; - Hide_Homograph; + -- There is an homograph. + if Potentially then + -- 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. + if Is_In_Current_Declarative_Region (Homograph) then + if not Is_Potentially_Visible (Homograph) then + return; + 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 LRM. + if Get_Parent (Decl) = Get_Parent (Current_Decl) then + if Flags.Vhdl_Std >= Vhdl_08 + and then Is_Implicit_Alias (Decl) + then + -- Re-declaration of an implicit subprogram via + -- an implicit alias is simply discarded. return; end if; - -- The homograph is potentially visible and was declared - -- in a scope different from the DECL scope. - -- (ie, it was certainly made visible by another use - -- clause). + -- Note: no need to save previous interpretation, as it + -- is in the same declarative region. Add_New_Interpretation; + Hide_Homograph; return; - else - -- The homograph was made visible in an outer declarative - -- region. Therefore, it must not be hidden. - Maybe_Save_And_Add_New_Interpretation; end if; + + -- The homograph is potentially visible and was declared + -- in a scope different from the DECL scope. + -- (ie, it was certainly made visible by another use + -- clause). + Add_New_Interpretation; + return; else - if not Is_Potentially_Visible (Homograph) then - if Is_In_Current_Declarative_Region (Homograph) then - if Get_Kind (Current_Decl) - /= Iir_Kind_Implicit_Function_Declaration - and then - Get_Kind (Current_Decl) - /= Iir_Kind_Implicit_Procedure_Declaration - then - Error_Msg_Sem - ("redeclaration of " & Disp_Node (Current_Decl) - & " defined at " & Disp_Location (Current_Decl), - Decl); + -- The homograph was made visible in an outer declarative + -- region. Therefore, it must not be hidden. + Maybe_Save_And_Add_New_Interpretation; + end if; + + return; + + else + -- Added declaration DECL is made directly visible. + + if not Is_Potentially_Visible (Homograph) then + -- The homograph was also directly visible + if Is_In_Current_Declarative_Region (Homograph) then + -- ... and was declared in the same region + + -- LRM08 12.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, 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 differrent named entities, + -- and [...] + if Flags.Vhdl_Std >= Vhdl_08 then + if Is_Implicit_Alias (Decl) then + -- Re-declaration of an implicit subprogram via + -- an implicit alias is simply discarded. + -- FIXME: implicit alias. return; end if; + + Current_Decl_Non_Alias := + Get_Non_Alias_Declaration (Homograph); else - -- Overload. - null; + Current_Decl_Non_Alias := Current_Decl; end if; + + if Get_Kind (Current_Decl_Non_Alias) + not in Iir_Kinds_Implicit_Subprogram_Declaration + then + Error_Msg_Sem + ("redeclaration of " & Disp_Node (Current_Decl) + & " defined at " & Disp_Location (Current_Decl), + Decl); + return; + end if; + + -- FIXME: simply discard DECL if an *implicit* alias + -- of the current declaration? 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 directly visible declaration declared in + -- an outer region. null; end if; - Maybe_Save_And_Add_New_Interpretation; + 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. - Hide_Homograph; - return; + -- GHDL: hide the potentially visible declaration. + null; end if; + Maybe_Save_And_Add_New_Interpretation; + + Hide_Homograph; + return; end if; end; - return; end if; -- The current interpretation and the new one are homograph. @@ -964,7 +1032,11 @@ package body Sem_Scopes is procedure Add_Package_Declarations (Decl: Iir_Package_Declaration; Potentially : Boolean) is + Header : constant Iir := Get_Package_Header (Decl); begin + 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; @@ -1040,6 +1112,15 @@ package body Sem_Scopes is Use_Library_All (Name); when Iir_Kind_Package_Declaration => Add_Package_Declarations (Name, True); + when Iir_Kind_Package_Instantiation_Declaration => + declare + Pkg : constant Iir := + Get_Named_Entity (Get_Uninstantiated_Name (Name)); + begin + if Pkg /= Null_Iir then + Add_Package_Declarations (Pkg, True); + end if; + end; when others => raise Internal_Error; end case; |