From 6230ad4e5e9329e57d44066aba8c8d7711042fa3 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Mon, 15 May 2017 18:30:57 +0200 Subject: Handle instantiation of protected types. --- src/vhdl/sem_inst.adb | 25 +++++++++++-------------- src/vhdl/translate/trans-chap2.adb | 38 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 49 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/vhdl/sem_inst.adb b/src/vhdl/sem_inst.adb index 2d39396f0..e76d9cada 100644 --- a/src/vhdl/sem_inst.adb +++ b/src/vhdl/sem_inst.adb @@ -357,20 +357,17 @@ package body Sem_Inst is 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; - - -- RES is null_iir unless RES is also an instance (and therefore has - -- an origin). - -- pragma Assert (Res = Null_Iir); + -- In general, Get_Instance (N) is Null_Iir. There are two + -- exceptions: + -- - N is also an instance (instance within an uninstantiated + -- package). As instances and origin share the same table, + -- Get_Instance returns the origin. During instantiation, the old + -- value of Origin is saved so this case is correctly handled. + -- - N is shared, so it was already instantiated. This happends only + -- for interface_constant of implicit operators. In that case, + -- multiple instances are created for the same node, which is not + -- ideal. That's still ok (if no infos are attached to the + -- interface) and is the price to pay for this optimization. -- Create a new node. Res := Create_Iir (Kind); diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb index d24700f3e..fef4957ac 100644 --- a/src/vhdl/translate/trans-chap2.adb +++ b/src/vhdl/translate/trans-chap2.adb @@ -1121,6 +1121,32 @@ package body Trans.Chap2 is end case; end Instantiate_Iir_List_Info; + -- B must be passed by reference. + procedure Adjust_Info_Basetype (B : access Ortho_Info_Basetype_Type; + Orig : access Ortho_Info_Basetype_Type) is + begin + case B.Kind is + when Kind_Type_Scalar => + null; + when Kind_Type_Array + | Kind_Type_Record => + null; + when Kind_Type_File => + null; + when Kind_Type_Protected => + B.Prot_Scope := Instantiate_Var_Scope (B.Prot_Scope); + Push_Instantiate_Var_Scope + (B.Prot_Scope'Unrestricted_access, + Orig.Prot_Scope'Unrestricted_access); + B.Prot_Prev_Scope := Instantiated_Var_Scope + (B.Prot_Prev_Scope); + B.Prot_Init_Instance := Instantiate_Subprg_Instance + (B.Prot_Init_Instance); + B.Prot_Final_Instance := Instantiate_Subprg_Instance + (B.Prot_Final_Instance); + end case; + end Adjust_Info_Basetype; + function Copy_Info_Subtype (Src : Ortho_Info_Subtype_Type) return Ortho_Info_Subtype_Type is @@ -1155,6 +1181,8 @@ package body Trans.Chap2 is B => Src.B, S => Copy_Info_Subtype (Src.S), Type_Rti => Src.Type_Rti); + Adjust_Info_Basetype (Dest.B'Unrestricted_Access, + Src.B'Unrestricted_Access); if Src.C /= null then Dest.C := new Complex_Type_Arr_Info' (Mode_Value => @@ -1311,6 +1339,8 @@ package body Trans.Chap2 is Push_Instantiate_Var_Scope (Info.Subprg_Frame_Scope'Access, Orig_Info.Subprg_Frame_Scope'Access); + when Kind_Type => + null; when others => null; end case; @@ -1393,6 +1423,14 @@ package body Trans.Chap2 is when Kind_Subprg => Pop_Instantiate_Var_Scope (Info.Subprg_Frame_Scope'Access); + when Kind_Type => + case Info.B.Kind is + when Kind_Type_Protected => + Pop_Instantiate_Var_Scope + (Info.B.Prot_Scope'Unrestricted_access); + when others => + null; + end case; when others => null; end case; -- cgit v1.2.3