wip: rework subprogram translation.

6 files changed, 123 insertions, 101 deletions

diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb
index df3298347..d24700f3e 100644
--- a/src/vhdl/translate/trans-chap2.adb
+++ b/src/vhdl/translate/trans-chap2.adb
@@ -426,6 +426,7 @@ package body Trans.Chap2 is
 
       Frame_Ptr_Type : O_Tnode;
       Upframe_Field  : O_Fnode;
+      Upframe_Scope  : Var_Scope_Acc;
 
       Frame     : O_Dnode;
       Frame_Ptr : O_Dnode;
@@ -457,7 +458,7 @@ package body Trans.Chap2 is
          --  Unnest subprograms.
          --  Create an instance for the local declarations.
          Push_Instance_Factory (Info.Subprg_Frame_Scope'Access);
-         Add_Subprg_Instance_Field (Upframe_Field);
+         Add_Subprg_Instance_Field (Upframe_Field, Upframe_Scope);
 
          if Info.Subprg_Params_Ptr /= O_Tnode_Null then
             --  Field for the parameters structure
@@ -526,14 +527,14 @@ package body Trans.Chap2 is
             Wki_Upframe, Prev_Subprg_Instances);
          --  Link to previous frame
          Subprgs.Start_Prev_Subprg_Instance_Use_Via_Field
-           (Prev_Subprg_Instances, Upframe_Field);
+           (Upframe_Scope, Upframe_Field);
 
          Chap4.Translate_Declaration_Chain_Subprograms
            (Subprg, Subprg_Translate_Spec_And_Body);
 
          --  Link to previous frame
          Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field
-           (Prev_Subprg_Instances, Upframe_Field);
+           (Upframe_Scope, Upframe_Field);
          --  Local frame
          Subprgs.Pop_Subprg_Instance (Wki_Upframe, Prev_Subprg_Instances);
       end if;
@@ -796,24 +797,18 @@ package body Trans.Chap2 is
          Chap2.Declare_Inst_Type_And_Ptr
            (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type);
 
-         if not Get_Need_Body (Decl)
-           and then Get_Package_Body (Decl) = Null_Iir
-         then
-            --  Generic package without a body.
-            --  Create an empty body instance.
-            Push_Package_Instance_Factory (Decl);
-            Pop_Package_Instance_Factory (Decl);
-
-            Set_Scope_Via_Field (Info.Package_Spec_Scope,
-                                 Info.Package_Spec_Field,
-                                 Info.Package_Body_Scope'Access);
-         end if;
-
          --  Each subprogram has a body instance argument (because subprogram
          --  bodys can access to body declarations).
          Subprgs.Push_Subprg_Instance
            (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type,
             Wki_Instance, Prev_Subprg_Instance);
+
+         if not Is_Nested then
+            --  For nested package, this will be translated when translating
+            --  subprograms.
+            Chap4.Translate_Declaration_Chain_Subprograms
+              (Decl, Subprg_Translate_Only_Spec);
+         end if;
       else
          if Header /= Null_Iir then
             Chap4.Translate_Generic_Chain (Header);
@@ -823,64 +818,74 @@ package body Trans.Chap2 is
             Info.Package_Elab_Var := Create_Var
               (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type);
          end if;
-      end if;
 
-      --  Translate subprograms declarations.
-      if not Is_Nested then
-         --  For nested package, this will be translated when translating
-         --  subprograms.
-         Chap4.Translate_Declaration_Chain_Subprograms
-           (Decl, Subprg_Translate_Spec_And_Body);
+         --  Translate subprograms declarations.
+         if not Is_Nested then
+            --  For nested package, this will be translated when translating
+            --  subprograms.
+            Chap4.Translate_Declaration_Chain_Subprograms
+              (Decl, Subprg_Translate_Spec_And_Body);
+         end if;
       end if;
 
-      --  Declare elaborator for the body.
       if not Is_Nested then
+         --  Declare elaborator for the spec.
+         Start_Procedure_Decl
+           (Interface_List, Create_Identifier ("ELAB_SPEC"), Global_Storage);
+         Subprgs.Add_Subprg_Instance_Interfaces
+           (Interface_List, Info.Package_Elab_Spec_Instance);
+         Finish_Subprogram_Decl
+           (Interface_List, Info.Package_Elab_Spec_Subprg);
+
+         --  Declare elaborator for the body.
          Start_Procedure_Decl
            (Interface_List, Create_Identifier ("ELAB_BODY"), Global_Storage);
          Subprgs.Add_Subprg_Instance_Interfaces
            (Interface_List, Info.Package_Elab_Body_Instance);
          Finish_Subprogram_Decl
            (Interface_List, Info.Package_Elab_Body_Subprg);
+
+         if Flag_Rti then
+            --  Generate RTI.
+            Rtis.Generate_Unit (Decl);
+         end if;
       end if;
 
       if Is_Uninstantiated then
-         Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
-
          if not Get_Need_Body (Decl)
            and then Get_Package_Body (Decl) = Null_Iir
          then
-            Clear_Scope (Info.Package_Spec_Scope);
-         end if;
+            --  Generic package without a body.
+            --  Create an empty body instance.
+            Push_Package_Instance_Factory (Decl);
+            Pop_Package_Instance_Factory (Decl);
 
-         --  The spec elaborator has a spec instance argument.
-         Subprgs.Push_Subprg_Instance
-           (Info.Package_Spec_Scope'Access, Info.Package_Spec_Ptr_Type,
-            Wki_Instance, Prev_Subprg_Instance);
-      end if;
+            Set_Scope_Via_Field (Info.Package_Spec_Scope,
+                                 Info.Package_Spec_Field,
+                                 Info.Package_Body_Scope'Access);
 
-      if not Is_Nested then
-         --  Declare elaborator for the spec.
-         Start_Procedure_Decl
-           (Interface_List, Create_Identifier ("ELAB_SPEC"), Global_Storage);
-         Subprgs.Add_Subprg_Instance_Interfaces
-           (Interface_List, Info.Package_Elab_Spec_Instance);
-         Finish_Subprogram_Decl
-           (Interface_List, Info.Package_Elab_Spec_Subprg);
+            if not Is_Nested
+              and then Global_Storage /= O_Storage_External
+            then
+               --  For nested package, this will be translated when translating
+               --  subprograms.
+               Chap4.Translate_Declaration_Chain_Subprograms
+                 (Decl, Subprg_Translate_Only_Body);
 
-         if Flag_Rti then
-            --  Generate RTI.
-            Rtis.Generate_Unit (Decl);
+               --  Create elaboration procedure for the spec
+               Elab_Package (Decl, Header);
+            end if;
          end if;
 
-         if Global_Storage /= O_Storage_External then
+         Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
+      else
+         if not Is_Nested
+           and then Global_Storage /= O_Storage_External
+         then
             --  Create elaboration procedure for the spec
             Elab_Package (Decl, Header);
          end if;
       end if;
-
-      if Is_Uninstantiated then
-         Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
-      end if;
       Save_Local_Identifier (Info.Package_Local_Id);
 
       if Is_Nested then
@@ -971,8 +976,12 @@ package body Trans.Chap2 is
       end if;
 
       if Is_Spec_Decl and then Is_Uninstantiated_Package (Spec) then
-         Clear_Scope (Info.Package_Spec_Scope);
          Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
+         if not Is_Nested then
+            Chap4.Translate_Declaration_Chain_Subprograms
+              (Spec, Subprg_Translate_Only_Body);
+            Elab_Package (Spec, Get_Package_Header (Spec));
+         end if;
       end if;
 
       if not Is_Nested then
@@ -1055,12 +1064,6 @@ package body Trans.Chap2 is
       Push_Local_Factory;
       Subprgs.Start_Subprg_Instance_Use (Info.Package_Elab_Body_Instance);
 
-      if Is_Spec_Decl and then Is_Uninstantiated_Package (Spec) then
-         Set_Scope_Via_Field (Info.Package_Spec_Scope,
-                              Info.Package_Spec_Field,
-                              Info.Package_Body_Scope'Access);
-      end if;
-
       --  If the package was already elaborated, return now,
       --  else mark the package as elaborated.
       Start_If_Stmt (If_Blk, New_Value (Get_Var (Info.Package_Elab_Var)));
@@ -1082,10 +1085,6 @@ package body Trans.Chap2 is
          Close_Temp;
       end if;
 
-      if Is_Spec_Decl and then Is_Uninstantiated_Package (Spec) then
-         Clear_Scope (Info.Package_Spec_Scope);
-      end if;
-
       Subprgs.Finish_Subprg_Instance_Use (Info.Package_Elab_Body_Instance);
       Pop_Local_Factory;
       Finish_Subprogram_Body;
@@ -1542,13 +1541,9 @@ package body Trans.Chap2 is
       Set_Scope_Via_Var (Pkg_Info.Package_Body_Scope,
                          Info.Package_Instance_Body_Var);
 
-      Set_Scope_Via_Field (Pkg_Info.Package_Spec_Scope,
-                           Pkg_Info.Package_Spec_Field,
-                           Pkg_Info.Package_Body_Scope'Access);
       Chap5.Elab_Generic_Map_Aspect
         (Get_Package_Header (Spec), Inst,
          (Pkg_Info.Package_Body_Scope'Access, Pkg_Info.Package_Body_Scope));
-      Clear_Scope (Pkg_Info.Package_Spec_Scope);
 
       --  Call the elaborator of the generic.  The generic must be
       --  temporary associated with the instance variable.
diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb
index 39c170d2d..ecc5906a8 100644
--- a/src/vhdl/translate/trans-chap3.adb
+++ b/src/vhdl/translate/trans-chap3.adb
@@ -1609,7 +1609,8 @@ package body Trans.Chap3 is
       --  Create the object type
       Push_Instance_Factory (Info.B.Prot_Scope'Unrestricted_Access);
       --  First, the previous instance.
-      Subprgs.Add_Subprg_Instance_Field (Info.B.Prot_Subprg_Instance_Field);
+      Subprgs.Add_Subprg_Instance_Field
+        (Info.B.Prot_Subprg_Instance_Field, Info.B.Prot_Prev_Scope);
       --  Then the object lock
       Info.B.Prot_Lock_Field := Add_Instance_Factory_Field
         (Get_Identifier ("LOCK"), Ghdl_Ptr_Type);
@@ -1638,13 +1639,12 @@ package body Trans.Chap3 is
       New_Procedure_Call (Assoc);
    end Call_Ghdl_Protected_Procedure;
 
-   procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir)
+   procedure Translate_Protected_Type_Body_Subprograms_Spec (Bod : Iir)
    is
       Mark  : Id_Mark_Type;
       Decl  : constant Iir := Get_Protected_Type_Declaration (Bod);
       Info  : constant Type_Info_Acc := Get_Info (Decl);
       Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack;
-      Final : Boolean;
    begin
       Push_Identifier_Prefix (Mark, Get_Identifier (Bod));
 
@@ -1653,23 +1653,32 @@ package body Trans.Chap3 is
                                     Info.Ortho_Ptr_Type (Mode_Value),
                                     Wki_Obj,
                                     Prev_Subprg_Instance);
+
+      --  Environment is referenced through the object.
       Subprgs.Start_Prev_Subprg_Instance_Use_Via_Field
-        (Prev_Subprg_Instance, Info.B.Prot_Subprg_Instance_Field);
+        (Info.B.Prot_Prev_Scope, Info.B.Prot_Subprg_Instance_Field);
 
       Chap4.Translate_Declaration_Chain_Subprograms
         (Bod, Subprg_Translate_Spec_And_Body);
 
-      Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field
-        (Prev_Subprg_Instance, Info.B.Prot_Subprg_Instance_Field);
       Subprgs.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance);
 
+      Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field
+        (Info.B.Prot_Prev_Scope, Info.B.Prot_Subprg_Instance_Field);
+
       Pop_Identifier_Prefix (Mark);
+   end Translate_Protected_Type_Body_Subprograms_Spec;
 
-      if Global_Storage = O_Storage_External then
-         return;
-      end if;
+   procedure Translate_Protected_Type_Body_Subprograms_Body (Bod : Iir)
+   is
+      Decl  : constant Iir := Get_Protected_Type_Declaration (Bod);
+      Info  : constant Type_Info_Acc := Get_Info (Decl);
+      Final : Boolean;
+   begin
+      pragma Assert (Global_Storage /= O_Storage_External);
 
       --  Init subprogram
+      --  Contrary to other subprograms, no object is passed to it.
       declare
          Var_Obj : O_Dnode;
       begin
@@ -1709,6 +1718,9 @@ package body Trans.Chap3 is
          Finish_Subprogram_Body;
       end;
 
+--      Chap4.Translate_Declaration_Chain_Subprograms
+--        (Bod, Subprg_Translate_Only_Body);
+
       --  Fini subprogram
       begin
          Start_Subprogram_Body (Info.B.Prot_Final_Subprg);
@@ -1725,7 +1737,8 @@ package body Trans.Chap3 is
          Subprgs.Finish_Subprg_Instance_Use (Info.B.Prot_Final_Instance);
          Finish_Subprogram_Body;
       end;
-   end Translate_Protected_Type_Body_Subprograms;
+
+   end Translate_Protected_Type_Body_Subprograms_Body;
 
    ---------------
    --  Scalars  --
@@ -2360,7 +2373,9 @@ package body Trans.Chap3 is
          when Iir_Kind_Incomplete_Type_Definition =>
             return;
          when Iir_Kind_Protected_Type_Declaration =>
-            Translate_Protected_Type_Subprograms_Spec (Def);
+            if Kind in Subprg_Translate_Spec then
+               Translate_Protected_Type_Subprograms_Spec (Def);
+            end if;
             return;
          when Iir_Kind_Record_Type_Definition
            | Iir_Kind_Array_Type_Definition =>
diff --git a/src/vhdl/translate/trans-chap3.ads b/src/vhdl/translate/trans-chap3.ads
index 70a6fa35d..91c13e9ff 100644
--- a/src/vhdl/translate/trans-chap3.ads
+++ b/src/vhdl/translate/trans-chap3.ads
@@ -58,7 +58,8 @@ package Trans.Chap3 is
    procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode);
 
    procedure Translate_Protected_Type_Body (Bod : Iir);
-   procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir);
+   procedure Translate_Protected_Type_Body_Subprograms_Spec (Bod : Iir);
+   procedure Translate_Protected_Type_Body_Subprograms_Body (Bod : Iir);
 
    --  Translate_type_definition_Elab do 4 and 6.
    --  It generates code to do type elaboration.
diff --git a/src/vhdl/translate/trans-chap4.adb b/src/vhdl/translate/trans-chap4.adb
index 97bef532e..88ab87206 100644
--- a/src/vhdl/translate/trans-chap4.adb
+++ b/src/vhdl/translate/trans-chap4.adb
@@ -2324,6 +2324,14 @@ package body Trans.Chap4 is
    procedure Translate_Declaration_Chain_Subprograms
      (Parent : Iir; What : Subprg_Translate_Kind)
    is
+      --  True iff specs must be translated.
+      Do_Specs : constant Boolean := What in Subprg_Translate_Spec;
+
+      --  True iff bodies must be translated.
+      Do_Bodies : constant Boolean :=
+        (What in Subprg_Translate_Body
+           and then Global_Storage /= O_Storage_External);
+
       El     : Iir;
       Infos  : Chap7.Implicit_Subprogram_Infos;
    begin
@@ -2342,44 +2350,40 @@ package body Trans.Chap4 is
                           | Iir_Predefined_Record_Equality =>
                            --  Used implicitly in case statement or other
                            --  predefined equality.
-                           if What in Subprg_Translate_Spec then
+                           if Do_Specs then
                               Chap7.Translate_Implicit_Subprogram_Spec
                                 (El, Infos);
                            end if;
-                           if What in Subprg_Translate_Body then
+                           if Do_Bodies then
                               Chap7.Translate_Implicit_Subprogram_Body (El);
                            end if;
                         when others =>
                            null;
                      end case;
                   else
-                     if What in Subprg_Translate_Spec then
+                     if Do_Specs then
                         Chap7.Translate_Implicit_Subprogram_Spec
                           (El, Infos);
                      end if;
-                     if What in Subprg_Translate_Body then
+                     if Do_Bodies then
                         Chap7.Translate_Implicit_Subprogram_Body (El);
                      end if;
                   end if;
                else
                   --  Translate only if used.
-                  if What in Subprg_Translate_Spec
-                    and then Get_Info (El) /= null
-                  then
+                  if Do_Specs and then Get_Info (El) /= null then
                      Chap2.Translate_Subprogram_Declaration (El);
                      Translate_Resolution_Function (El);
                   end if;
                end if;
             when Iir_Kind_Function_Body
               | Iir_Kind_Procedure_Body =>
-               if What in Subprg_Translate_Body then
+               if Do_Bodies then
                   --  Do not translate body if generating only specs (for
                   --  subprograms in an entity).
-                  if Global_Storage /= O_Storage_External
-                    and then
-                    (not Flag_Discard_Unused
-                       or else
-                       Get_Use_Flag (Get_Subprogram_Specification (El)))
+                  if not Flag_Discard_Unused
+                    or else
+                    Get_Use_Flag (Get_Subprogram_Specification (El))
                   then
                      Chap2.Translate_Subprogram_Body (El);
                      Translate_Resolution_Function_Body
@@ -2391,11 +2395,12 @@ package body Trans.Chap4 is
                Chap3.Translate_Type_Subprograms (El, What);
                Chap7.Init_Implicit_Subprogram_Infos (Infos);
             when Iir_Kind_Protected_Type_Body =>
-               if What in Subprg_Translate_Spec then
+               if Do_Specs then
                   Chap3.Translate_Protected_Type_Body (El);
                end if;
-               if What in Subprg_Translate_Body then
-                  Chap3.Translate_Protected_Type_Body_Subprograms (El);
+               if Do_Bodies then
+                  Chap3.Translate_Protected_Type_Body_Subprograms_Spec (El);
+                  Chap3.Translate_Protected_Type_Body_Subprograms_Body (El);
                end if;
             when Iir_Kind_Package_Declaration
               | Iir_Kind_Package_Body =>
diff --git a/src/vhdl/translate/trans.adb b/src/vhdl/translate/trans.adb
index d41458d08..1f9d177a4 100644
--- a/src/vhdl/translate/trans.adb
+++ b/src/vhdl/translate/trans.adb
@@ -76,14 +76,17 @@ package body Trans is
          end if;
       end Add_Subprg_Instance_Interfaces;
 
-      procedure Add_Subprg_Instance_Field (Field : out O_Fnode) is
+      procedure Add_Subprg_Instance_Field
+        (Field : out O_Fnode; Prev_Scope : out Var_Scope_Acc) is
       begin
          if Has_Current_Subprg_Instance then
             Field := Add_Instance_Factory_Field
               (Current_Subprg_Instance.Ident,
                Current_Subprg_Instance.Ptr_Type);
+            Prev_Scope := Current_Subprg_Instance.Scope;
          else
             Field := O_Fnode_Null;
+            Prev_Scope := null;
          end if;
       end Add_Subprg_Instance_Field;
 
@@ -113,7 +116,7 @@ package body Trans is
         (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type)
       is
       begin
-         if Has_Subprg_Instance (Vars) then
+         if Has_Subprg_Instance (Vars) and then Field /= O_Fnode_Null then
             New_Assign_Stmt (New_Selected_Acc_Value (New_Obj (Var), Field),
                              New_Obj_Value (Vars.Inter));
          end if;
@@ -134,19 +137,19 @@ package body Trans is
       end Finish_Subprg_Instance_Use;
 
       procedure Start_Prev_Subprg_Instance_Use_Via_Field
-        (Prev : Subprg_Instance_Stack; Field : O_Fnode) is
+        (Prev_Scope : Var_Scope_Acc; Field : O_Fnode) is
       begin
          if Field /= O_Fnode_Null then
-            Set_Scope_Via_Field_Ptr (Prev.Scope.all, Field,
+            Set_Scope_Via_Field_Ptr (Prev_Scope.all, Field,
                                      Current_Subprg_Instance.Scope);
          end if;
       end Start_Prev_Subprg_Instance_Use_Via_Field;
 
       procedure Finish_Prev_Subprg_Instance_Use_Via_Field
-        (Prev : Subprg_Instance_Stack; Field : O_Fnode) is
+        (Prev_Scope : Var_Scope_Acc; Field : O_Fnode) is
       begin
          if Field /= O_Fnode_Null then
-            Clear_Scope (Prev.Scope.all);
+            Clear_Scope (Prev_Scope.all);
          end if;
       end Finish_Prev_Subprg_Instance_Use_Via_Field;
 
diff --git a/src/vhdl/translate/trans.ads b/src/vhdl/translate/trans.ads
index 598e662f4..a93f38198 100644
--- a/src/vhdl/translate/trans.ads
+++ b/src/vhdl/translate/trans.ads
@@ -602,7 +602,8 @@ package Trans is
 
       --  Add a field in the current factory that reference the current
       --  instance.
-      procedure Add_Subprg_Instance_Field (Field : out O_Fnode);
+      procedure Add_Subprg_Instance_Field
+        (Field : out O_Fnode; Prev_Scope : out Var_Scope_Acc);
 
       --  Associate values to the instance interface during invocation of a
       --  subprogram.
@@ -628,9 +629,9 @@ package Trans is
 
       --  Call Push_Scope to reference instance from FIELD.
       procedure Start_Prev_Subprg_Instance_Use_Via_Field
-        (Prev : Subprg_Instance_Stack; Field : O_Fnode);
+        (Prev_Scope : Var_Scope_Acc; Field : O_Fnode);
       procedure Finish_Prev_Subprg_Instance_Use_Via_Field
-        (Prev : Subprg_Instance_Stack; Field : O_Fnode);
+        (Prev_Scope : Var_Scope_Acc; Field : O_Fnode);
 
       --  Same as above, but for IIR.
       procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List;
@@ -754,6 +755,7 @@ package Trans is
 
          when Kind_Type_Protected =>
             Prot_Scope : aliased Var_Scope_Type;
+            Prot_Prev_Scope : Var_Scope_Acc;
 
             --  Init procedure for the protected type.
             Prot_Init_Subprg           : O_Dnode;
@@ -851,6 +853,7 @@ package Trans is
      (Kind => Kind_Type_Protected,
       Rti_Max_Depth => 0,
       Prot_Scope => Null_Var_Scope,
+      Prot_Prev_Scope => null,
       Prot_Init_Subprg => O_Dnode_Null,
       Prot_Init_Instance => Subprgs.Null_Subprg_Instance,
       Prot_Final_Subprg => O_Dnode_Null,