Translation: rework instance building.

Preliminary work to support llvm.

2 files changed, 345 insertions, 251 deletions

diff --git a/translate/translation.adb b/translate/translation.adb
index b2bf04272..a4d77fb02 100644
--- a/translate/translation.adb
+++ b/translate/translation.adb
@@ -181,6 +181,8 @@ package body Translation is
    Wki_Hi : O_Ident;
    Wki_Mid : O_Ident;
    Wki_Cmp : O_Ident;
+   Wki_Upframe : O_Ident;
+   Wki_Frame : O_Ident;
 
    --  ALLOCATION_KIND defines the type of memory storage.
    --  ALLOC_STACK means the object is allocated on the local stack and
@@ -461,80 +463,72 @@ package body Translation is
       --   files, signals or types.  However these data are not shared between
       --   instances of the same entity, architecture...  Subprograms instances
       --   is the way subprograms access to these data.
-      --  One subprogram instance corresponds to a record.  Generally, a
-      --   subprogram has 0 or 1 instance.  Subprograms of protected objects
-      --   have an additionnal instance for the variable (object).
-      --
+      --  One subprogram instance corresponds to a record.
+
+      --  Type to save an old instance builder.  Subprograms may have at most
+      --  one instance.  If they need severals (for example a protected
+      --  subprogram), the most recent one will have a reference to the
+      --  previous one.
+      type Subprg_Instance_Stack is limited private;
+
       --  Declare an instance to be added for subprograms.
       --  DECL_TYPE is the type of the instance; this should be a record.  This
       --   is used by PUSH_SCOPE.
       --  PTR_TYPE is a pointer to DECL_TYPE.
       --  IDENT is an identifier for the interface.
-      --  DATA is a stabilized O_LNODE whose value will be passed to call to
-      --   subprograms.
+      --  The previous instance is stored to PREV.  It must be restored with
+      --  Pop_Subprg_Instance.
       --  Add_Subprg_Instance_Interfaces will add an interface of name IDENT
       --   and type PTR_TYPE for every instance declared by
       --   PUSH_SUBPRG_INSTANCE.
       procedure Push_Subprg_Instance (Decl_Type : O_Tnode;
                                       Ptr_Type : O_Tnode;
-                                      Ident : O_Ident);
-
-      --  Revert of the previous subprogram.
-      --  Instances must be removed in opposite order they are added.
-      procedure Pop_Subprg_Instance (Ident : O_Ident);
+                                      Ident : O_Ident;
+                                      Prev : out Subprg_Instance_Stack);
 
       --  Since local subprograms has a direct access to its father interfaces,
       --  they do not required instances interfaces.
       --  These procedures are provided to temporarly disable the addition of
-      --   instances interfaces.
-      type Subprg_Instance_Stack is limited private;
-      procedure Save_Subprg_Instance (Stack : out Subprg_Instance_Stack);
-      procedure Restore_Subprg_Instance (Stack : Subprg_Instance_Stack);
-
-      --  Provides/removes an access to an instance.
-      --  PTR is a pointer to the instance.  PTR must be stable if this
-      --  access is used several times.
-      --  SET_SUBPRG_INSTANCE must not be called twice on the same instance
-      --  unless the access to the instance has been cleared with
-      --  CLEAR_SUBPRG_INSTANCE.
-      --  At the association, instances without explicit accesses are
-      --  associated with the access found in the scope.
-      --procedure Set_Subprg_Instance (Decl_Type : O_Tnode; Ptr : O_Lnode);
-      --procedure Clear_Subprg_Instance (Decl_Type : O_Tnode);
+      --  instances interfaces. Use Pop_Subpg_Instance to restore to the
+      --  previous state.
+      procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack);
 
-      --  Add interfaces during the creation of a subprogram.
-      type Subprg_Instance_El is record
-         Inter : O_Dnode;
-         Inter_Type : O_Tnode;
-         Inst_Type : O_Tnode;
-      end record;
-      Null_Subprg_Instance_El : constant Subprg_Instance_El :=
-        (O_Dnode_Null, O_Tnode_Null, O_Tnode_Null);
+      --  Revert of the previous subprogram.
+      --  Instances must be removed in opposite order they are added.
+      procedure Pop_Subprg_Instance (Ident : O_Ident;
+                                     Prev : Subprg_Instance_Stack);
 
-      type Subprg_Instance_Array is array (Natural range <>)
-        of Subprg_Instance_El;
+      --  Contains the subprogram interface for the instance.
+      type Subprg_Instance_Type is private;
+      Null_Subprg_Instance : constant Subprg_Instance_Type;
 
+      --  Add interfaces during the creation of a subprogram.
       procedure Add_Subprg_Instance_Interfaces
-        (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Array);
+        (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Type);
+
+      --  Add a field in the current factory that reference the current
+      --  instance.
+      procedure Add_Subprg_Instance_Field (Field : out O_Fnode);
+
       --  Associate values to the instance interfaces during invocation of a
       --  subprogram.
       procedure Add_Subprg_Instance_Assoc
-        (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Array);
-      procedure Add_Subprg_Instance_Assoc
-        (Assocs : in out O_Assoc_List;
-         Vars : Subprg_Instance_Array;
-         Inst1_Type : O_Tnode;
-         Inst1_Val : O_Enode);
+        (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type);
+
+      --  Assign the instance field FIELD of VAR.
+      procedure Set_Subprg_Instance_Field
+        (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type);
 
       --  To be called at the beginning and end of a subprogram body creation.
       --  Call PUSH_SCOPE for the subprogram intances.
-      procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Array);
-      procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Array);
-
-      subtype Instance_Inters is Subprg_Instance_Array (0 .. 1);
-      Null_Instance_Inters : constant Instance_Inters :=
-        (others => Null_Subprg_Instance_El);
+      procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Type);
+      procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type);
 
+      --  Call Push_Scope to reference instance from FIELD.
+      procedure Start_Prev_Subprg_Instance_Use_Via_Field
+        (Prev : Subprg_Instance_Stack; Field : O_Fnode);
+      procedure Finish_Prev_Subprg_Instance_Use_Via_Field
+        (Prev : Subprg_Instance_Stack; Field : O_Fnode);
 
       --  Same as above, but for IIR.
       procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List;
@@ -543,23 +537,25 @@ package body Translation is
       procedure Start_Subprg_Instance_Use (Subprg : Iir);
       procedure Finish_Subprg_Instance_Use (Subprg : Iir);
    private
-      type Subprg_Instance_Type;
-      type Subprg_Instance_Stack is access Subprg_Instance_Type;
-
       type Subprg_Instance_Type is record
-         --  Arguments of push.
+         Inter : O_Dnode;
+         Inter_Type : O_Tnode;
+         Inst_Type : O_Tnode;
+      end record;
+      Null_Subprg_Instance : constant Subprg_Instance_Type :=
+        (O_Dnode_Null, O_Tnode_Null, O_Tnode_Null);
+
+      type Subprg_Instance_Stack is record
          Decl_Type : O_Tnode;
          Ptr_Type : O_Tnode;
          Ident : O_Ident;
-
-         --  Double linked list.
-         Next : Subprg_Instance_Stack;
-         Prev : Subprg_Instance_Stack;
       end record;
 
-      Subprg_Instance_First : Subprg_Instance_Stack := null;
-      Subprg_Instance_Last : Subprg_Instance_Stack := null;
-      Subprg_Instance_Unused : Subprg_Instance_Stack := null;
+      Null_Subprg_Instance_Stack : constant Subprg_Instance_Stack :=
+        (O_Tnode_Null, O_Tnode_Null, O_Ident_Nul);
+
+      Current_Subprg_Instance : Subprg_Instance_Stack :=
+        Null_Subprg_Instance_Stack;
    end Chap2;
 
    package Chap5 is
@@ -792,7 +788,7 @@ package body Translation is
    type O_Dnode_Array is array (Object_Kind_Type) of O_Dnode;
    type Var_Acc_Array is array (Object_Kind_Type) of Var_Acc;
    type Instance_Inters_Array is array (Object_Kind_Type)
-     of Chap2.Instance_Inters;
+     of Chap2.Subprg_Instance_Type;
 
    type Rti_Depth_Type is new Natural range 0 .. 255;
 
@@ -861,10 +857,15 @@ package body Translation is
          when Kind_Type_Protected =>
             --  Init procedure for the protected type.
             Prot_Init_Node : O_Dnode;
-            Prot_Init_Instance : Chap2.Instance_Inters;
+            Prot_Init_Instance : Chap2.Subprg_Instance_Type;
+            Prot_Init_Obj : O_Dnode;
             --  Final procedure.
             Prot_Final_Node : O_Dnode;
-            Prot_Final_Instance : Chap2.Instance_Inters;
+            Prot_Final_Instance : Chap2.Subprg_Instance_Type;
+            --  The outer instance, if any.
+            Prot_Subprg_Instance_Field : O_Fnode;
+            --  The LOCK field in the object type
+            Prot_Lock_Field : O_Fnode;
       end case;
    end record;
 
@@ -907,9 +908,12 @@ package body Translation is
      (Kind => Kind_Type_Protected,
       Rti_Max_Depth => 0,
       Prot_Init_Node => O_Dnode_Null,
-      Prot_Init_Instance => Chap2.Null_Instance_Inters,
+      Prot_Init_Instance => Chap2.Null_Subprg_Instance,
+      Prot_Init_Obj => O_Dnode_Null,
       Prot_Final_Node => O_Dnode_Null,
-      Prot_Final_Instance => Chap2.Null_Instance_Inters);
+      Prot_Subprg_Instance_Field => O_Fnode_Null,
+      Prot_Final_Instance => Chap2.Null_Subprg_Instance,
+      Prot_Lock_Field => O_Fnode_Null);
 
    --  Mode of the type; roughly speaking, this corresponds to its size
    --  (for scalars) or its layout (for composite types).
@@ -1101,7 +1105,7 @@ package body Translation is
 
             --  For a function:
             --    If the return value is not composite, then this field
-            --      must be O_LNODE_NULL.
+            --      must be O_DNODE_NULL.
             --    If the return value is a composite type, then the caller must
             --    give to the callee an area to put the result.  This area is
             --    given via an (hidden to the user) interface.  Furthermore,
@@ -1119,8 +1123,8 @@ package body Translation is
             Res_Record_Ptr : O_Tnode := O_Tnode_Null;
 
             --  Instances for the subprograms.
-            Subprg_Instance : Chap2.Instance_Inters :=
-              Chap2.Null_Instance_Inters;
+            Subprg_Instance : Chap2.Subprg_Instance_Type :=
+              Chap2.Null_Subprg_Instance;
 
             Subprg_Resolv : Subprg_Resolv_Info_Acc := null;
 
@@ -3951,7 +3955,8 @@ package body Translation is
       is
          Info : Block_Info_Acc;
          Interface_List : O_Inter_List;
-         Instance : Chap2.Instance_Inters;
+         Instance : Chap2.Subprg_Instance_Type;
+         Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack;
       begin
          Info := Add_Info (Entity, Kind_Block);
          Chap1.Start_Block_Decl (Entity);
@@ -3971,7 +3976,8 @@ package body Translation is
 
          Chap2.Push_Subprg_Instance (Info.Block_Decls_Type,
                                      Info.Block_Decls_Ptr_Type,
-                                     Wki_Instance);
+                                     Wki_Instance,
+                                     Prev_Subprg_Instance);
 
          --  Entity elaborator.
          Start_Procedure_Decl (Interface_List, Create_Identifier ("ELAB"),
@@ -4035,7 +4041,7 @@ package body Translation is
                end;
             end if;
          end if;
-         Chap2.Pop_Subprg_Instance (Wki_Instance);
+         Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
       end Translate_Entity_Declaration;
 
       --  Push scope for architecture ARCH via INSTANCE, and for its
@@ -4079,6 +4085,7 @@ package body Translation is
          Constr : O_Assoc_List;
          Instance : O_Dnode;
          Var_Arch_Instance : O_Dnode;
+         Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack;
       begin
          if Get_Foreign_Flag (Arch) then
             Error_Msg_Sem ("FOREIGN architectures are not yet handled", Arch);
@@ -4127,7 +4134,8 @@ package body Translation is
 
          Chap2.Push_Subprg_Instance (Info.Block_Decls_Type,
                                      Info.Block_Decls_Ptr_Type,
-                                     Wki_Instance);
+                                     Wki_Instance,
+                                     Prev_Subprg_Instance);
 
          --  Create process subprograms.
          Push_Scope (Entity_Info.Block_Decls_Type,
@@ -4135,7 +4143,7 @@ package body Translation is
          Chap9.Translate_Block_Subprograms (Arch, Arch);
          Pop_Scope (Entity_Info.Block_Decls_Type);
 
-         Chap2.Pop_Subprg_Instance (Wki_Instance);
+         Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
 
          --  Elaborator body.
          Start_Subprogram_Body (Info.Block_Elab_Subprg);
@@ -5016,6 +5024,51 @@ package body Translation is
          return True;
       end Is_Subprogram_Ortho_Function;
 
+      --  Return TRUE iif SUBPRG_BODY declares explicitely or implicitely
+      --  (or even implicitely by translation) a subprogram.
+      function Has_Nested_Subprograms (Subprg_Body : Iir) return Boolean
+      is
+         Decl : Iir;
+         Atype : Iir;
+      begin
+         Decl := Get_Declaration_Chain (Subprg_Body);
+         while Decl /= Null_Iir loop
+            case Get_Kind (Decl) is
+               when Iir_Kind_Function_Declaration
+                 | Iir_Kind_Procedure_Declaration =>
+                  return True;
+               when Iir_Kind_Function_Body
+                 | Iir_Kind_Procedure_Body =>
+                  --  The declaration preceed the body.
+                  raise Internal_Error;
+               when Iir_Kind_Type_Declaration
+                 | Iir_Kind_Anonymous_Type_Declaration =>
+                  Atype := Get_Type (Decl);
+                  case Iir_Kinds_Type_And_Subtype_Definition
+                    (Get_Kind (Atype)) is
+                     when Iir_Kinds_Scalar_Type_Definition =>
+                        null;
+                     when Iir_Kind_Access_Type_Definition
+                       | Iir_Kind_Access_Subtype_Definition =>
+                        null;
+                     when Iir_Kind_File_Type_Definition =>
+                        return True;
+                     when Iir_Kind_Protected_Type_Declaration =>
+                        raise Internal_Error;
+                     when Iir_Kinds_Composite_Type_Definition =>
+                        --  At least for "=".
+                        return True;
+                     when Iir_Kind_Incomplete_Type_Definition =>
+                        null;
+                  end case;
+               when others =>
+                  null;
+            end case;
+            Decl := Get_Chain (Decl);
+         end loop;
+         return False;
+      end Has_Nested_Subprograms;
+
       procedure Translate_Subprogram_Body (Subprg : Iir)
       is
          Spec : Iir;
@@ -5030,9 +5083,18 @@ package body Translation is
          --  and retained.
          Is_Prot : Boolean := False;
 
+         --  True if the body has local (nested) subprograms.
+         Has_Nested : Boolean;
+
+         Frame_Type : O_Tnode;
+         Frame_Ptr_Type : O_Tnode;
+         Upframe_Field : O_Fnode;
+         Frame : O_Dnode;
+         Frame_Ptr : O_Dnode;
+
          Has_Return : Boolean;
 
-         Subprg_Instances : Chap2.Subprg_Instance_Stack;
+         Prev_Subprg_Instances : Chap2.Subprg_Instance_Stack;
       begin
          Spec := Get_Subprogram_Specification (Subprg);
          Info := Get_Info (Spec);
@@ -5043,18 +5105,50 @@ package body Translation is
             return;
          end if;
 
+         if Flag_Unnest_Subprograms then
+            Has_Nested := Has_Nested_Subprograms (Subprg);
+         else
+            Has_Nested := False;
+         end if;
+
          --  Set the identifier prefix with the subprogram identifier and
          --  overload number if any.
          Push_Subprg_Identifier (Spec, Mark);
-         Restore_Local_Identifier (Info.Subprg_Local_Id);
+
+         if Has_Nested then
+            --  Unnest subprograms.
+            --  Create an instance for the local declarations.
+            Push_Instance_Factory (O_Tnode_Null);
+            Add_Subprg_Instance_Field (Upframe_Field);
+
+            --  FIXME: parameters
+
+            Chap4.Translate_Declaration_Chain (Subprg);
+            Pop_Instance_Factory (Frame_Type);
+
+            New_Type_Decl (Create_Identifier ("_FRAMETYPE"), Frame_Type);
+            Frame_Ptr_Type := New_Access_Type (Frame_Type);
+            New_Type_Decl (Create_Identifier ("_FRAMEPTR"), Frame_Ptr_Type);
+
+            Rtis.Generate_Subprogram_Body (Subprg);
+
+            Chap2.Push_Subprg_Instance (Frame_Type, Frame_Ptr_Type,
+                                        Wki_Upframe, Prev_Subprg_Instances);
+
+            Chap4.Translate_Declaration_Chain_Subprograms (Subprg, Null_Iir);
+
+            Chap2.Pop_Subprg_Instance (Wki_Upframe, Prev_Subprg_Instances);
+         end if;
 
          Start_Subprogram_Body (Func_Decl);
 
          Start_Subprg_Instance_Use (Spec);
 
+         Restore_Local_Identifier (Info.Subprg_Local_Id);
+
          Push_Local_Factory;
+         Chap2.Clear_Subprg_Instance (Prev_Subprg_Instances);
          Open_Local_Temp;
-         Chap2.Save_Subprg_Instance (Subprg_Instances);
 
          --  Init out parameter passed by value/copy.
          declare
@@ -5081,9 +5175,20 @@ package body Translation is
             end loop;
          end;
 
-         Chap4.Translate_Declaration_Chain (Subprg);
-         Rtis.Generate_Subprogram_Body (Subprg);
-         Chap4.Translate_Declaration_Chain_Subprograms (Subprg, Null_Iir);
+         if not Has_Nested then
+            Chap4.Translate_Declaration_Chain (Subprg);
+            Rtis.Generate_Subprogram_Body (Subprg);
+            Chap4.Translate_Declaration_Chain_Subprograms (Subprg, Null_Iir);
+         else
+            New_Var_Decl (Frame, Wki_Frame, O_Storage_Local, Frame_Type);
+            --  FIXME!
+            New_Var_Decl (Frame_Ptr, Get_Identifier ("FRAMEPTR"),
+                          O_Storage_Local, Frame_Ptr_Type);
+            New_Assign_Stmt (New_Obj (Frame_Ptr),
+                             New_Address (New_Obj (Frame), Frame_Ptr_Type));
+            Push_Scope (Frame_Type, Frame_Ptr);
+            --  Init instance.
+         end if;
 
          Chap4.Elab_Declaration_Chain (Subprg, Final);
 
@@ -5115,7 +5220,7 @@ package body Translation is
          Current_Subprogram := Old_Subprogram;
 
          if Final or Is_Prot then
-            --  FIXME: create a barrier to catch missing return statement.
+            --  Create a barrier to catch missing return statement.
             if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then
                New_Exit_Stmt (Info.Subprg_Exit);
             else
@@ -5146,7 +5251,7 @@ package body Translation is
             end if;
          end if;
 
-         Chap2.Restore_Subprg_Instance (Subprg_Instances);
+         Chap2.Pop_Subprg_Instance (O_Ident_Nul, Prev_Subprg_Instances);
          Close_Local_Temp;
          Pop_Local_Factory;
 
@@ -5437,149 +5542,122 @@ package body Translation is
          end loop;
       end Elab_Dependence;
 
+      procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack)
+      is
+      begin
+         Prev := Current_Subprg_Instance;
+         Current_Subprg_Instance := Null_Subprg_Instance_Stack;
+      end Clear_Subprg_Instance;
+
       procedure Push_Subprg_Instance (Decl_Type : O_Tnode;
                                       Ptr_Type : O_Tnode;
-                                      Ident : O_Ident)
+                                      Ident : O_Ident;
+                                      Prev : out Subprg_Instance_Stack)
       is
-         El : Subprg_Instance_Stack;
       begin
-         if Subprg_Instance_Unused /= null then
-            El := Subprg_Instance_Unused;
-            Subprg_Instance_Unused := El.Next;
-         else
-            El := new Subprg_Instance_Type;
-         end if;
-         El.all := (Decl_Type => Decl_Type,
-                    Ptr_Type => Ptr_Type,
-                    Ident => Ident,
-                    Next => null,
-                    Prev => Subprg_Instance_Last);
-         if Subprg_Instance_First = null then
-            Subprg_Instance_First := El;
-         else
-            Subprg_Instance_Last.Next := El;
-         end if;
-         Subprg_Instance_Last := El;
+         Prev := Current_Subprg_Instance;
+         Current_Subprg_Instance := (Decl_Type => Decl_Type,
+                                     Ptr_Type => Ptr_Type,
+                                     Ident => Ident);
       end Push_Subprg_Instance;
 
-      procedure Pop_Subprg_Instance (Ident : O_Ident)
+      function Has_Current_Subprg_Instance return Boolean is
+      begin
+         return Current_Subprg_Instance.Decl_Type /= O_Tnode_Null;
+      end Has_Current_Subprg_Instance;
+
+      procedure Pop_Subprg_Instance (Ident : O_Ident;
+                                     Prev : Subprg_Instance_Stack)
       is
-         El : Subprg_Instance_Stack;
       begin
-         El := Subprg_Instance_Last;
-         if El = null or else not Is_Equal (El.Ident, Ident) then
+         if Is_Equal (Current_Subprg_Instance.Ident, Ident) then
+            Current_Subprg_Instance := Prev;
+         else
             --  POP does not match with a push.
             raise Internal_Error;
          end if;
-         Subprg_Instance_Last := El.Prev;
-         if El.Prev = null then
-            Subprg_Instance_First := null;
-         else
-            El.Prev.Next := null;
-         end if;
-         El.Next := Subprg_Instance_Unused;
-         Subprg_Instance_Unused := El;
       end Pop_Subprg_Instance;
 
-      procedure Save_Subprg_Instance (Stack : out Subprg_Instance_Stack)
+      procedure Add_Subprg_Instance_Interfaces
+        (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Type)
       is
       begin
-         Stack := Subprg_Instance_First;
-         if Stack /= null then
-            if Stack.Prev /= null then
-               raise Internal_Error;
-            end if;
-            Stack.Prev := Subprg_Instance_Last;
+         if Has_Current_Subprg_Instance then
+            Vars.Inst_Type := Current_Subprg_Instance.Decl_Type;
+            Vars.Inter_Type := Current_Subprg_Instance.Ptr_Type;
+            New_Interface_Decl
+              (Interfaces, Vars.Inter,
+               Current_Subprg_Instance.Ident,
+               Current_Subprg_Instance.Ptr_Type);
+         else
+            Vars := Null_Subprg_Instance;
          end if;
-         Subprg_Instance_First := null;
-         Subprg_Instance_Last := null;
-      end Save_Subprg_Instance;
+      end Add_Subprg_Instance_Interfaces;
 
-      procedure Restore_Subprg_Instance (Stack : Subprg_Instance_Stack)
-      is
+      procedure Add_Subprg_Instance_Field (Field : out O_Fnode) is
       begin
-         if Subprg_Instance_First /= null then
-            --  Not matching with a save.
-            raise Internal_Error;
-         end if;
-         Subprg_Instance_First := Stack;
-         if Stack /= null then
-            Subprg_Instance_Last := Stack.Prev;
-            Stack.Prev := null;
+         if Has_Current_Subprg_Instance then
+            Field := Add_Instance_Factory_Field
+              (Current_Subprg_Instance.Ident,
+               Current_Subprg_Instance.Ptr_Type);
+         else
+            Field := O_Fnode_Null;
          end if;
-      end Restore_Subprg_Instance;
-
-      procedure Add_Subprg_Instance_Interfaces
-        (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Array)
-      is
-         El : Subprg_Instance_Stack;
-         I : Natural;
-      begin
-         El := Subprg_Instance_First;
-         I := Vars'First;
-         while El /= null loop
-            Vars (I).Inst_Type := El.Decl_Type;
-            Vars (I).Inter_Type := El.Ptr_Type;
-            New_Interface_Decl
-              (Interfaces, Vars (I).Inter, El.Ident, El.Ptr_Type);
-            I := I + 1;
-            El := El.Next;
-         end loop;
-         Vars (I .. Vars'Last) := (others => Null_Subprg_Instance_El);
-      end Add_Subprg_Instance_Interfaces;
+      end Add_Subprg_Instance_Field;
 
       procedure Add_Subprg_Instance_Assoc
-        (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Array)
+        (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type)
       is
          Val : O_Enode;
       begin
-         for I in Vars'Range loop
-            exit when Vars (I).Inter = O_Dnode_Null;
-            Val := New_Address (Get_Instance_Ref (Vars (I).Inst_Type),
-                                Vars (I).Inter_Type);
+         if Vars.Inter /= O_Dnode_Null then
+            Val := New_Address (Get_Instance_Ref (Vars.Inst_Type),
+                                Vars.Inter_Type);
             New_Association (Assocs, Val);
-         end loop;
+         end if;
       end Add_Subprg_Instance_Assoc;
 
-      procedure Add_Subprg_Instance_Assoc
-        (Assocs : in out O_Assoc_List;
-         Vars : Subprg_Instance_Array;
-         Inst1_Type : O_Tnode;
-         Inst1_Val : O_Enode)
+      procedure Set_Subprg_Instance_Field
+        (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type)
       is
-         Val : O_Enode;
       begin
-         for I in Vars'Range loop
-            exit when Vars (I).Inter = O_Dnode_Null;
-            if Vars (I).Inst_Type = Inst1_Type then
-               Val := Inst1_Val;
-            else
-               Val := New_Address (Get_Instance_Ref (Vars (I).Inst_Type),
-                                   Vars (I).Inter_Type);
-            end if;
-            New_Association (Assocs, Val);
-         end loop;
-      end Add_Subprg_Instance_Assoc;
+         if Vars.Inter /= O_Dnode_Null then
+            New_Assign_Stmt (New_Selected_Acc_Value (New_Obj (Var), Field),
+                             New_Obj_Value (Vars.Inter));
+         end if;
+      end Set_Subprg_Instance_Field;
 
-      procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Array)
-      is
+      procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is
       begin
-         for I in Vars'Range loop
-            exit when Vars (I).Inter = O_Dnode_Null;
-            Push_Scope (Vars (I).Inst_Type, Vars (I).Inter);
-         end loop;
+         if Vars.Inter /= O_Dnode_Null then
+            Push_Scope (Vars.Inst_Type, Vars.Inter);
+         end if;
       end Start_Subprg_Instance_Use;
 
-      procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Array)
-      is
+      procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is
       begin
-         for I in reverse Vars'Range loop
-            if Vars (I).Inter /= O_Dnode_Null then
-               Pop_Scope (Vars (I).Inst_Type);
-            end if;
-         end loop;
+         if Vars.Inter /= O_Dnode_Null then
+            Pop_Scope (Vars.Inst_Type);
+         end if;
       end Finish_Subprg_Instance_Use;
 
+      procedure Start_Prev_Subprg_Instance_Use_Via_Field
+        (Prev : Subprg_Instance_Stack; Field : O_Fnode) is
+      begin
+         if Field /= O_Fnode_Null then
+            Push_Scope_Via_Field_Ptr
+              (Prev.Decl_Type, Field, Current_Subprg_Instance.Decl_Type);
+         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
+      begin
+         if Field /= O_Fnode_Null then
+            Pop_Scope (Prev.Decl_Type);
+         end if;
+      end Finish_Prev_Subprg_Instance_Use_Via_Field;
+
       procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List;
                                         Subprg : Iir)
       is
@@ -6919,23 +6997,29 @@ package body Translation is
          Info : Type_Info_Acc;
          Inter_List : O_Inter_List;
          Mark : Id_Mark_Type;
+         Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack;
       begin
          Push_Identifier_Prefix
            (Mark, Get_Identifier (Get_Type_Declarator (Def)));
 
          Info := Get_Info (Def);
 
-         Chap2.Push_Subprg_Instance (Info.Ortho_Type (Mode_Value),
-                                     Info.Ortho_Ptr_Type (Mode_Value),
-                                     Wki_Obj);
-
          --  Init.
          Start_Procedure_Decl
            (Inter_List, Create_Identifier ("INIT"), Global_Storage);
          Chap2.Add_Subprg_Instance_Interfaces
            (Inter_List, Info.T.Prot_Init_Instance);
+         New_Interface_Decl
+           (Inter_List, Info.T.Prot_Init_Obj, Wki_Obj,
+            Info.Ortho_Ptr_Type (Mode_Value));
          Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Init_Node);
 
+         --  Use the object as instance.
+         Chap2.Push_Subprg_Instance (Info.Ortho_Type (Mode_Value),
+                                     Info.Ortho_Ptr_Type (Mode_Value),
+                                     Wki_Obj,
+                                     Prev_Subprg_Instance);
+
          --  Final.
          Start_Procedure_Decl
            (Inter_List, Create_Identifier ("FINI"), Global_Storage);
@@ -6959,7 +7043,7 @@ package body Translation is
             El := Get_Chain (El);
          end loop;
 
-         Chap2.Pop_Subprg_Instance (Wki_Obj);
+         Chap2.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance);
 
          Pop_Identifier_Prefix (Mark);
       end Translate_Protected_Type_Subprograms;
@@ -6969,16 +7053,19 @@ package body Translation is
          Decl : Iir_Protected_Type_Declaration;
          Mark : Id_Mark_Type;
          Info : Type_Info_Acc;
-         Lock_Field : O_Fnode;
-         pragma Unreferenced (Lock_Field);
       begin
          Decl := Get_Protected_Type_Declaration (Bod);
          Info := Get_Info (Decl);
 
          Push_Identifier_Prefix (Mark, Get_Identifier (Bod));
 
+         --  Create the object type
          Push_Instance_Factory (Info.Ortho_Type (Mode_Value));
-         Lock_Field := Add_Instance_Factory_Field
+         --  First, the previous instance.
+         Chap2.Add_Subprg_Instance_Field
+           (Info.T.Prot_Subprg_Instance_Field);
+         --  Then the object lock
+         Info.T.Prot_Lock_Field := Add_Instance_Factory_Field
            (Get_Identifier ("LOCK"), Ghdl_Ptr_Type);
 
          --  Translate declarations.
@@ -6986,6 +7073,7 @@ package body Translation is
 
          Pop_Instance_Factory (Info.Ortho_Type (Mode_Value));
          if Global_Storage /= O_Storage_External then
+            --  FIXME: the size may not be constant!
             Info.C.Size_Var (Mode_Value) := Create_Global_Const
               (Create_Identifier ("SIZE"), Ghdl_Index_Type,
                Global_Storage, New_Sizeof (Info.Ortho_Type (Mode_Value),
@@ -6995,6 +7083,7 @@ package body Translation is
          Pop_Identifier_Prefix (Mark);
       end Translate_Protected_Type_Body;
 
+      --  Call lock or unlock on a protected object.
       procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode)
       is
          Assoc : O_Assoc_List;
@@ -7005,7 +7094,10 @@ package body Translation is
          New_Association
            (Assoc,
             New_Unchecked_Address
-            (Get_Instance_Ref (Info.Ortho_Type (Mode_Value)), Ghdl_Ptr_Type));
+              (New_Selected_Element
+                 (Get_Instance_Ref (Info.Ortho_Type (Mode_Value)),
+                  Info.T.Prot_Lock_Field),
+               Ghdl_Ptr_Type));
          New_Procedure_Call (Assoc);
       end Call_Ghdl_Protected_Procedure;
 
@@ -7014,6 +7106,7 @@ package body Translation is
          Decl : Iir;
          Info : Type_Info_Acc;
          Final : Boolean;
+         Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack;
       begin
          Decl := Get_Protected_Type_Declaration (Bod);
          Info := Get_Info (Decl);
@@ -7021,46 +7114,60 @@ package body Translation is
          --  Subprograms of BOD.
          Chap2.Push_Subprg_Instance (Info.Ortho_Type (Mode_Value),
                                      Info.Ortho_Ptr_Type (Mode_Value),
-                                     Wki_Obj);
+                                     Wki_Obj,
+                                     Prev_Subprg_Instance);
+         Chap2.Start_Prev_Subprg_Instance_Use_Via_Field
+           (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field);
 
          Chap4.Translate_Declaration_Chain_Subprograms (Bod, Null_Iir);
 
-         Chap2.Pop_Subprg_Instance (Wki_Obj);
+         Chap2.Finish_Prev_Subprg_Instance_Use_Via_Field
+           (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field);
+         Chap2.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance);
 
          if Global_Storage = O_Storage_External then
             return;
          end if;
 
-         --  Init
-         Start_Subprogram_Body (Info.T.Prot_Init_Node);
-         Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Init_Instance);
+         --  Init subprogram
+         begin
+            Start_Subprogram_Body (Info.T.Prot_Init_Node);
+            Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Init_Instance);
+            Chap2.Set_Subprg_Instance_Field
+              (Info.T.Prot_Init_Obj, Info.T.Prot_Subprg_Instance_Field,
+               Info.T.Prot_Init_Instance);
+            Push_Scope (Info.Ortho_Type (Mode_Value), Info.T.Prot_Init_Obj);
 
-         --   Create lock.
-         Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Init);
+            --   Create lock.
+            Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Init);
 
-         --   Elaborate fields.
-         Open_Temp;
-         Chap4.Elab_Declaration_Chain (Bod, Final);
-         Close_Temp;
+            --   Elaborate fields.
+            Open_Temp;
+            Chap4.Elab_Declaration_Chain (Bod, Final);
+            Close_Temp;
 
-         Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Init_Instance);
-         Finish_Subprogram_Body;
+            Pop_Scope (Info.Ortho_Type (Mode_Value));
 
+            Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Init_Instance);
+            Finish_Subprogram_Body;
+         end;
 
-         --  Fini
-         Start_Subprogram_Body (Info.T.Prot_Final_Node);
-         Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Final_Instance);
+         --  Fini subprogram
+         begin
+            Start_Subprogram_Body (Info.T.Prot_Final_Node);
+            Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Final_Instance);
 
-         --   Deallocate fields.
-         if Final or True then
-            Chap4.Final_Declaration_Chain (Bod, True);
-         end if;
+            --   Deallocate fields.
+            if Final or True then
+               Chap4.Final_Declaration_Chain (Bod, True);
+            end if;
 
-         --   Destroy lock.
-         Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Fini);
+            --   Destroy lock.
+            Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Fini);
 
-         Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Final_Instance);
-         Finish_Subprogram_Body;
+            Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Final_Instance);
+            Finish_Subprogram_Body;
+         end;
       end Translate_Protected_Type_Body_Subprograms;
 
       ---------------
@@ -9292,9 +9399,8 @@ package body Translation is
          --  The object has already been allocated.
          --  Call the initializator.
          Start_Association (Assoc, Info.T.Prot_Init_Node);
-         Chap2.Add_Subprg_Instance_Assoc (Assoc, Info.T.Prot_Init_Instance,
-                                          Info.Ortho_Type (Mode_Value),
-                                          M2E (Obj));
+         Chap2.Add_Subprg_Instance_Assoc (Assoc, Info.T.Prot_Init_Instance);
+         New_Association (Assoc, M2E (Obj));
          New_Procedure_Call (Assoc);
       end Init_Protected_Object;
 
@@ -9309,9 +9415,7 @@ package body Translation is
          Obj := Chap6.Translate_Name (Decl);
          --  Call the Finalizator.
          Start_Association (Assoc, Info.T.Prot_Final_Node);
-         Chap2.Add_Subprg_Instance_Assoc (Assoc, Info.T.Prot_Final_Instance,
-                                          Info.Ortho_Type (Mode_Value),
-                                          M2E (Obj));
+         New_Association (Assoc, M2E (Obj));
          New_Procedure_Call (Assoc);
       end Fini_Protected_Object;
 
@@ -10532,7 +10636,7 @@ package body Translation is
                null;
 
             when Iir_Kind_Protected_Type_Body =>
-               Chap3.Translate_Protected_Type_Body (Decl);
+               null;
 
             --when Iir_Kind_Implicit_Function_Declaration =>
             --when Iir_Kind_Signal_Declaration
@@ -11034,6 +11138,7 @@ package body Translation is
                   Chap3.Translate_Type_Subprograms (El);
                   Chap7.Init_Implicit_Subprogram_Infos (Infos);
                when Iir_Kind_Protected_Type_Body =>
+                  Chap3.Translate_Protected_Type_Body (El);
                   Chap3.Translate_Protected_Type_Body_Subprograms (El);
                when Iir_Kind_Implicit_Function_Declaration
                  | Iir_Kind_Implicit_Procedure_Declaration =>
@@ -14295,15 +14400,7 @@ package body Translation is
 
          --  If the subprogram is a method, pass the protected object.
          if Obj /= Null_Iir then
-            declare
-               Prot_Info : Type_Info_Acc;
-            begin
-               Prot_Info := Get_Info (Get_Method_Type (Imp));
-               Chap2.Add_Subprg_Instance_Assoc
-                 (Constr, Info.Subprg_Instance,
-                  Prot_Info.Ortho_Type (Mode_Value),
-                  M2E (Chap6.Translate_Name (Obj)));
-            end;
+            New_Association (Constr, M2E (Chap6.Translate_Name (Obj)));
          else
             Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance);
          end if;
@@ -20285,15 +20382,7 @@ package body Translation is
 
          Obj := Get_Method_Object (Stmt);
          if Obj /= Null_Iir then
-            declare
-               Prot_Info : Type_Info_Acc;
-            begin
-               Prot_Info := Get_Info (Get_Method_Type (Imp));
-               Chap2.Add_Subprg_Instance_Assoc
-                 (Constr, Info.Subprg_Instance,
-                  Prot_Info.Ortho_Type (Mode_Value),
-                  M2E (Chap6.Translate_Name (Obj)));
-            end;
+            New_Association (Constr, M2E (Chap6.Translate_Name (Obj)));
          else
             Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance);
          end if;
@@ -22224,20 +22313,20 @@ package body Translation is
                when Iir_Kind_Generate_Statement =>
                   declare
                      Info : Block_Info_Acc;
-                     Prev_Instance : Chap2.Subprg_Instance_Stack;
+                     Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack;
                   begin
                      Info := Get_Info (Stmt);
-                     Chap2.Save_Subprg_Instance (Prev_Instance);
                      Chap2.Push_Subprg_Instance (Info.Block_Decls_Type,
                                                  Info.Block_Decls_Ptr_Type,
-                                                 Wki_Instance);
+                                                 Wki_Instance,
+                                                 Prev_Subprg_Instance);
                      Push_Scope_Via_Field_Ptr (Base_Info.Block_Decls_Type,
                                                Info.Block_Origin_Field,
                                                Info.Block_Decls_Type);
                      Translate_Block_Subprograms (Stmt, Stmt);
                      Pop_Scope (Base_Info.Block_Decls_Type);
-                     Chap2.Pop_Subprg_Instance (Wki_Instance);
-                     Chap2.Restore_Subprg_Instance (Prev_Instance);
+                     Chap2.Pop_Subprg_Instance
+                       (Wki_Instance, Prev_Subprg_Instance);
                   end;
                when others =>
                   Error_Kind ("translate_block_subprograms", Stmt);
@@ -28047,6 +28136,8 @@ package body Translation is
       Wki_Hi := Get_Identifier ("hi");
       Wki_Mid := Get_Identifier ("mid");
       Wki_Cmp := Get_Identifier ("cmp");
+      Wki_Upframe := Get_Identifier ("UPFRAME");
+      Wki_Frame := Get_Identifier ("FRAME");
 
       Sizetype := New_Unsigned_Type (32);
       New_Type_Decl (Get_Identifier ("__ghdl_size_type"), Sizetype);
diff --git a/translate/translation.ads b/translate/translation.ads
index f88bef4f5..bcaec623a 100644
--- a/translate/translation.ads
+++ b/translate/translation.ads
@@ -76,6 +76,9 @@ package Translation is
    --  If set, do not create identifiers (for in memory compilation).
    Flag_Discard_Identifiers : Boolean := False;
 
+   --  If true, do not create nested subprograms.
+   Flag_Unnest_Subprograms : Boolean := False;
+
    type Foreign_Kind_Type is (Foreign_Unknown,
                               Foreign_Vhpidirect,
                               Foreign_Intrinsic);