path: root/src/vhdl/translate/trans.adb

--  Iir to ortho translator.
--  Copyright (C) 2002-2014 Tristan Gingold
--
--  GHDL is free software; you can redistribute it and/or modify it under
--  the terms of the GNU General Public License as published by the Free
--  Software Foundation; either version 2, or (at your option) any later
--  version.
--
--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
--  for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with GCC; see the file COPYING.  If not, write to the Free
--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
--  02111-1307, USA.

with Name_Table; -- use Name_Table;
with Nodes;
with GNAT.Table;
with Trans_Decls; use Trans_Decls;

package body Trans is
   use Trans.Helpers;

   package body Subprgs is
      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 (Scope    : Var_Scope_Acc;
                                      Ptr_Type : O_Tnode;
                                      Ident    : O_Ident;
                                      Prev     : out Subprg_Instance_Stack)
      is
      begin
         Prev := Current_Subprg_Instance;
         Current_Subprg_Instance := (Scope => Scope,
                                     Ptr_Type => Ptr_Type,
                                     Ident => Ident);
      end Push_Subprg_Instance;

      function Has_Current_Subprg_Instance return Boolean is
      begin
         return Current_Subprg_Instance.Ptr_Type /= O_Tnode_Null;
      end Has_Current_Subprg_Instance;

      procedure Pop_Subprg_Instance (Ident : O_Ident;
                                     Prev  : Subprg_Instance_Stack)
      is
      begin
         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;
      end Pop_Subprg_Instance;

      procedure Add_Subprg_Instance_Interfaces
        (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Type)
      is
      begin
         if Has_Current_Subprg_Instance then
            Vars.Scope := Current_Subprg_Instance.Scope;
            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;
      end Add_Subprg_Instance_Interfaces;

      procedure Add_Subprg_Instance_Field (Field : out O_Fnode) is
      begin
         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 Add_Subprg_Instance_Field;

      function Has_Subprg_Instance (Vars : Subprg_Instance_Type)
                                    return Boolean is
      begin
         return Vars.Inter /= O_Dnode_Null;
      end Has_Subprg_Instance;

      function Get_Subprg_Instance (Vars : Subprg_Instance_Type)
                                    return O_Enode is
      begin
         pragma Assert (Has_Subprg_Instance (Vars));
         return New_Address (Get_Instance_Ref (Vars.Scope.all),
                             Vars.Inter_Type);
      end Get_Subprg_Instance;

      procedure Add_Subprg_Instance_Assoc
        (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type) is
      begin
         if Has_Subprg_Instance (Vars) then
            New_Association (Assocs, Get_Subprg_Instance (Vars));
         end if;
      end Add_Subprg_Instance_Assoc;

      procedure Set_Subprg_Instance_Field
        (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type)
      is
      begin
         if Has_Subprg_Instance (Vars) 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_Type) is
      begin
         if Has_Subprg_Instance (Vars) then
            Set_Scope_Via_Param_Ptr (Vars.Scope.all, Vars.Inter);
         end if;
      end Start_Subprg_Instance_Use;

      procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is
      begin
         if Has_Subprg_Instance (Vars) then
            Clear_Scope (Vars.Scope.all);
         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
            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
      begin
         if Field /= O_Fnode_Null then
            Clear_Scope (Prev.Scope.all);
         end if;
      end Finish_Prev_Subprg_Instance_Use_Via_Field;

      procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List;
                                        Subprg     : Iir)
      is
      begin
         Add_Subprg_Instance_Interfaces
           (Interfaces, Get_Info (Subprg).Subprg_Instance);
      end Create_Subprg_Instance;

      procedure Start_Subprg_Instance_Use (Subprg : Iir) is
      begin
         Start_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance);
      end Start_Subprg_Instance_Use;

      procedure Finish_Subprg_Instance_Use (Subprg : Iir) is
      begin
         Finish_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance);
      end Finish_Subprg_Instance_Use;

      function Instantiate_Subprg_Instance (Inst : Subprg_Instance_Type)
                                            return Subprg_Instance_Type is
      begin
         return Subprg_Instance_Type'
           (Inter => Inst.Inter,
            Inter_Type => Inst.Inter_Type,
            Scope => Instantiated_Var_Scope (Inst.Scope));
      end Instantiate_Subprg_Instance;
   end Subprgs;

   package body Chap10 is
      --  Identifiers.
      --  The following functions are helpers to create ortho identifiers.
      Identifier_Buffer : String (1 .. 512);
      Identifier_Len    : Natural := 0;
      Identifier_Start  : Natural := 1;
      Identifier_Local  : Local_Identifier_Type := 0;


      Inst_Build : Inst_Build_Acc := null;
      procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
        (Object => Inst_Build_Type, Name => Inst_Build_Acc);

      procedure Set_Global_Storage (Storage : O_Storage) is
      begin
         Global_Storage := Storage;
      end Set_Global_Storage;

      procedure Pop_Build_Instance
      is
         Old : Inst_Build_Acc;
      begin
         Old := Inst_Build;
         Identifier_Start := Old.Prev_Id_Start;
         Inst_Build := Old.Prev;
         Unchecked_Deallocation (Old);
      end Pop_Build_Instance;

      function Get_Scope_Type (Scope : Var_Scope_Type) return O_Tnode is
      begin
         pragma Assert (Scope.Scope_Type /= O_Tnode_Null);
         return Scope.Scope_Type;
      end Get_Scope_Type;

      function Get_Scope_Size (Scope : Var_Scope_Type) return O_Cnode is
      begin
         pragma Assert (Scope.Scope_Type /= O_Tnode_Null);
         return New_Sizeof (Scope.Scope_Type, Ghdl_Index_Type);
      end Get_Scope_Size;

      function Has_Scope_Type (Scope : Var_Scope_Type) return Boolean is
      begin
         return Scope.Scope_Type /= O_Tnode_Null;
      end Has_Scope_Type;

      procedure Predeclare_Scope_Type (Scope : Var_Scope_Acc; Name : O_Ident)
      is
      begin
         pragma Assert (Scope.Scope_Type = O_Tnode_Null);
         New_Uncomplete_Record_Type (Scope.Scope_Type);
         New_Type_Decl (Name, Scope.Scope_Type);
      end Predeclare_Scope_Type;

      procedure Declare_Scope_Acc
        (Scope : Var_Scope_Type; Name : O_Ident; Ptr_Type : out O_Tnode) is
      begin
         Ptr_Type := New_Access_Type (Get_Scope_Type (Scope));
         New_Type_Decl (Name, Ptr_Type);
      end Declare_Scope_Acc;

      procedure Push_Instance_Factory (Scope : Var_Scope_Acc)
      is
         Inst : Inst_Build_Acc;
      begin
         if Inst_Build /= null and then Inst_Build.Kind /= Instance then
            raise Internal_Error;
         end if;
         Inst := new Inst_Build_Type (Instance);
         Inst.Prev := Inst_Build;
         Inst.Prev_Id_Start := Identifier_Start;
         Inst.Scope := Scope;

         Identifier_Start := Identifier_Len + 1;

         if Scope.Scope_Type /= O_Tnode_Null then
            Start_Uncomplete_Record_Type (Scope.Scope_Type, Inst.Elements);
         else
            Start_Record_Type (Inst.Elements);
         end if;
         Inst_Build := Inst;
      end Push_Instance_Factory;

      function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode)
                                           return O_Fnode
      is
         Res : O_Fnode;
      begin
         New_Record_Field (Inst_Build.Elements, Res, Name, Ftype);
         return Res;
      end Add_Instance_Factory_Field;

      procedure Add_Scope_Field
        (Name : O_Ident; Child : in out Var_Scope_Type)
      is
         Field : O_Fnode;
      begin
         Field := Add_Instance_Factory_Field (Name, Get_Scope_Type (Child));
         Set_Scope_Via_Field (Child, Field, Inst_Build.Scope);
      end Add_Scope_Field;

      function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode)
                                 return O_Cnode is
      begin
         return New_Offsetof (Get_Scope_Type (Child.Up_Link.all),
                              Child.Field, Otype);
      end Get_Scope_Offset;

      procedure Pop_Instance_Factory (Scope : in Var_Scope_Acc)
      is
         Res : O_Tnode;
      begin
         if Inst_Build.Kind /= Instance then
            --  Not matching.
            raise Internal_Error;
         end if;
         Finish_Record_Type (Inst_Build.Elements, Res);
         Pop_Build_Instance;
         Scope.Scope_Type := Res;
      end Pop_Instance_Factory;

      procedure Push_Local_Factory
      is
         Inst : Inst_Build_Acc;
      begin
         if Inst_Build /= null
           and then (Inst_Build.Kind /= Global and Inst_Build.Kind /= Local)
         then
            --  Cannot create a local factory on an instance.
            raise Internal_Error;
         end if;
         Inst := new Inst_Build_Type (Kind => Local);
         Inst.Prev := Inst_Build;
         Inst.Prev_Global_Storage := Global_Storage;

         Inst.Prev_Id_Start := Identifier_Start;
         Identifier_Start := Identifier_Len + 1;

         Inst_Build := Inst;
         case Global_Storage is
            when O_Storage_Public =>
               Global_Storage := O_Storage_Private;
            when O_Storage_Private
               | O_Storage_External =>
               null;
            when O_Storage_Local =>
               raise Internal_Error;
         end case;
      end Push_Local_Factory;

      --  Return TRUE is the current scope is local.
      function Is_Local_Scope return Boolean is
      begin
         if Inst_Build = null then
            return False;
         end if;
         case Inst_Build.Kind is
            when Local
               | Instance =>
               return True;
            when Global =>
               return False;
         end case;
      end Is_Local_Scope;

      procedure Pop_Local_Factory is
      begin
         if Inst_Build.Kind /= Local then
            --  Not matching.
            raise Internal_Error;
         end if;
         Global_Storage := Inst_Build.Prev_Global_Storage;
         Pop_Build_Instance;
      end Pop_Local_Factory;

      procedure Set_Scope_Via_Field
        (Scope       : in out Var_Scope_Type;
         Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is
      begin
         pragma Assert (Scope.Kind = Var_Scope_None);
         Scope := (Scope_Type => Scope.Scope_Type,
                   Kind => Var_Scope_Field,
                   Field => Scope_Field, Up_Link => Scope_Parent);
      end Set_Scope_Via_Field;

      procedure Set_Scope_Via_Field_Ptr
        (Scope       : in out Var_Scope_Type;
         Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is
      begin
         pragma Assert (Scope.Kind = Var_Scope_None);
         Scope := (Scope_Type => Scope.Scope_Type,
                   Kind => Var_Scope_Field_Ptr,
                   Field => Scope_Field, Up_Link => Scope_Parent);
      end Set_Scope_Via_Field_Ptr;

      procedure Set_Scope_Via_Var_Ptr
        (Scope : in out Var_Scope_Type; Var : Var_Type) is
      begin
         pragma Assert (Scope.Kind = Var_Scope_None);
         pragma Assert (Var.Kind = Var_Scope);
         Scope := (Scope_Type => Scope.Scope_Type,
                   Kind => Var_Scope_Field_Ptr,
                   Field => Var.I_Field, Up_Link => Var.I_Scope);
      end Set_Scope_Via_Var_Ptr;

      procedure Set_Scope_Via_Param_Ptr
        (Scope : in out Var_Scope_Type; Scope_Param : O_Dnode) is
      begin
         pragma Assert (Scope.Kind = Var_Scope_None);
         Scope := (Scope_Type => Scope.Scope_Type,
                   Kind => Var_Scope_Ptr, D => Scope_Param);
      end Set_Scope_Via_Param_Ptr;

      procedure Set_Scope_Via_Decl
        (Scope : in out Var_Scope_Type; Decl : O_Dnode) is
      begin
         pragma Assert (Scope.Kind = Var_Scope_None);
         Scope := (Scope_Type => Scope.Scope_Type,
                   Kind => Var_Scope_Decl, D => Decl);
      end Set_Scope_Via_Decl;

      procedure Clear_Scope (Scope : in out Var_Scope_Type) is
      begin
         pragma Assert (Scope.Kind /= Var_Scope_None);
         Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_None);
      end Clear_Scope;

      function Create_Global_Var
        (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage)
         return Var_Type
      is
         Var : O_Dnode;
      begin
         New_Var_Decl (Var, Name, Storage, Vtype);
         return Var_Type'(Kind => Var_Global, E => Var);
      end Create_Global_Var;

      function Create_Global_Const
        (Name          : O_Ident;
         Vtype         : O_Tnode;
         Storage       : O_Storage;
         Initial_Value : O_Cnode)
         return Var_Type
      is
         Res : O_Dnode;
      begin
         New_Const_Decl (Res, Name, Storage, Vtype);
         if Storage /= O_Storage_External
           and then Initial_Value /= O_Cnode_Null
         then
            Start_Const_Value (Res);
            Finish_Const_Value (Res, Initial_Value);
         end if;
         return Var_Type'(Kind => Var_Global, E => Res);
      end Create_Global_Const;

      procedure Define_Global_Const (Const : in out Var_Type; Val : O_Cnode) is
      begin
         Start_Const_Value (Const.E);
         Finish_Const_Value (Const.E, Val);
      end Define_Global_Const;

      function Create_Var
        (Name    : Var_Ident_Type;
         Vtype   : O_Tnode;
         Storage : O_Storage := Global_Storage)
         return Var_Type
      is
         Res   : O_Dnode;
         Field : O_Fnode;
         K     : Inst_Build_Kind_Type;
      begin
         if Inst_Build = null then
            K := Global;
         else
            K := Inst_Build.Kind;
         end if;
         case K is
            when Global =>
               --  The global scope is in use...
               return Create_Global_Var (Name.Id, Vtype, Storage);
            when Local =>
               --  It is always possible to create a variable in a local scope.
               --  Create a var.
               New_Var_Decl (Res, Name.Id, O_Storage_Local, Vtype);
               return Var_Type'(Kind => Var_Local, E => Res);
            when Instance =>
               --  Create a field.
               New_Record_Field (Inst_Build.Elements, Field, Name.Id, Vtype);
               return Var_Type'(Kind => Var_Scope, I_Field => Field,
                                I_Scope => Inst_Build.Scope);
         end case;
      end Create_Var;

      --  Get a reference to scope STYPE. If IS_PTR is set, RES is an access
      --  to the scope, otherwise RES directly designates the scope.
      procedure Find_Scope (Scope  : Var_Scope_Type;
                            Res    : out O_Lnode;
                            Is_Ptr : out Boolean) is
      begin
         case Scope.Kind is
            when Var_Scope_None =>
               raise Internal_Error;
            when Var_Scope_Ptr
               | Var_Scope_Decl =>
               Res := New_Obj (Scope.D);
               Is_Ptr := Scope.Kind = Var_Scope_Ptr;
            when Var_Scope_Field
               | Var_Scope_Field_Ptr =>
               declare
                  Parent     : O_Lnode;
                  Parent_Ptr : Boolean;
               begin
                  Find_Scope (Scope.Up_Link.all, Parent, Parent_Ptr);
                  if Parent_Ptr then
                     Parent := New_Acc_Value (Parent);
                  end if;
                  Res := New_Selected_Element (Parent, Scope.Field);
                  Is_Ptr := Scope.Kind = Var_Scope_Field_Ptr;
               end;
         end case;
      end Find_Scope;

      procedure Check_Not_Building is
      begin
         --  Variables cannot be referenced if there is an instance being
         --  built.
         if Inst_Build /= null and then Inst_Build.Kind = Instance then
            raise Internal_Error;
         end if;
      end Check_Not_Building;

      function Get_Instance_Access (Block : Iir) return O_Enode
      is
         Info   : constant Block_Info_Acc := Get_Info (Block);
         Res    : O_Lnode;
         Is_Ptr : Boolean;
      begin
         Check_Not_Building;
         Find_Scope (Info.Block_Scope, Res, Is_Ptr);
         if Is_Ptr then
            return New_Value (Res);
         else
            return New_Address (Res, Info.Block_Decls_Ptr_Type);
         end if;
      end Get_Instance_Access;

      function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode
      is
         Res    : O_Lnode;
         Is_Ptr : Boolean;
      begin
         Check_Not_Building;
         Find_Scope (Scope, Res, Is_Ptr);
         if Is_Ptr then
            return New_Acc_Value (Res);
         else
            return Res;
         end if;
      end Get_Instance_Ref;

      function Get_Var (Var : Var_Type) return O_Lnode
      is
      begin
         case Var.Kind is
            when Var_None =>
               raise Internal_Error;
            when Var_Local
               | Var_Global =>
               return New_Obj (Var.E);
            when Var_Scope =>
               return New_Selected_Element
                 (Get_Instance_Ref (Var.I_Scope.all), Var.I_Field);
         end case;
      end Get_Var;

      function Get_Alloc_Kind_For_Var (Var : Var_Type)
                                       return Allocation_Kind is
      begin
         case Var.Kind is
            when Var_Local =>
               return Alloc_Stack;
            when Var_Global
               | Var_Scope =>
               return Alloc_System;
            when Var_None =>
               raise Internal_Error;
         end case;
      end Get_Alloc_Kind_For_Var;

      function Is_Var_Stable (Var : Var_Type) return Boolean is
      begin
         case Var.Kind is
            when Var_Local
               | Var_Global =>
               return True;
            when Var_Scope =>
               return False;
            when Var_None =>
               raise Internal_Error;
         end case;
      end Is_Var_Stable;

      function Is_Var_Field (Var : Var_Type) return Boolean is
      begin
         case Var.Kind is
            when Var_Local
               | Var_Global =>
               return False;
            when Var_Scope =>
               return True;
            when Var_None =>
               raise Internal_Error;
         end case;
      end Is_Var_Field;

      function Get_Var_Offset (Var : Var_Type; Otype : O_Tnode) return O_Cnode
      is
      begin
         return New_Offsetof (Get_Scope_Type (Var.I_Scope.all),
                              Var.I_Field, Otype);
      end Get_Var_Offset;

      function Get_Var_Label (Var : Var_Type) return O_Dnode is
      begin
         case Var.Kind is
            when Var_Local
               | Var_Global =>
               return Var.E;
            when Var_Scope
               | Var_None =>
               raise Internal_Error;
         end case;
      end Get_Var_Label;

      procedure Save_Local_Identifier (Id : out Local_Identifier_Type) is
      begin
         Id := Identifier_Local;
      end Save_Local_Identifier;

      procedure Restore_Local_Identifier (Id : Local_Identifier_Type) is
      begin
         if Identifier_Local > Id then
            --  If the value is restored with a smaller value, some identifiers
            --  will be reused.  This is certainly an internal error.
            raise Internal_Error;
         end if;
         Identifier_Local := Id;
      end Restore_Local_Identifier;

      --  Reset the identifier.
      procedure Reset_Identifier_Prefix is
      begin
         if Identifier_Len /= 0 or else Identifier_Local /= 0 then
            raise Internal_Error;
         end if;
      end Reset_Identifier_Prefix;

      procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type) is
      begin
         Identifier_Len := Mark.Len;
         Identifier_Local := Mark.Local_Id;
      end Pop_Identifier_Prefix;

      procedure Add_String (Len : in out Natural; Str : String) is
      begin
         Identifier_Buffer (Len + 1 .. Len + Str'Length) := Str;
         Len := Len + Str'Length;
      end Add_String;

      procedure Add_Nat (Len : in out Natural; Val : Natural)
      is
         Num : String (1 .. 10);
         V   : Natural;
         P   : Natural;
      begin
         P := Num'Last;
         V := Val;
         loop
            Num (P) := Character'Val (Character'Pos ('0') + V mod 10);
            V := V / 10;
            exit when V = 0;
            P := P - 1;
         end loop;
         Add_String (Len, Num (P .. Num'Last));
      end Add_Nat;

      --  Convert name_id NAME to a string stored to
      --  NAME_BUFFER (1 .. NAME_LENGTH).
      --
      --  This encodes extended identifiers.
      --
      --  Extended identifier encoding:
      --  They start with 'X'.
      --  Non extended character [0-9a-zA-Z] are left as is,
      --  others are encoded to _XX, where XX is the character position in hex.
      --  They finish with "__".
      procedure Name_Id_To_String (Name : Name_Id)
      is
         use Name_Table;

         type Bool_Array_Type is array (Character) of Boolean;
         pragma Pack (Bool_Array_Type);
         Is_Extended_Char : constant Bool_Array_Type :=
           ('0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' => False,
            others => True);

         N_Len : Natural;
         P     : Natural;
         C     : Character;
      begin
         if Is_Character (Name) then
            P := Character'Pos (Name_Table.Get_Character (Name));
            Name_Buffer (1) := 'C';
            Name_Buffer (2) := N2hex (P / 16);
            Name_Buffer (3) := N2hex (P mod 16);
            Name_Length := 3;
            return;
         else
            Image (Name);
         end if;
         if Name_Buffer (1) /= '\' then
            return;
         end if;
         --  Extended identifier.
         --  Supress trailing backslash.
         Name_Length := Name_Length - 1;

         --  Count number of characters in the extended string.
         N_Len := Name_Length;
         for I in 2 .. Name_Length loop
            if Is_Extended_Char (Name_Buffer (I)) then
               N_Len := N_Len + 2;
            end if;
         end loop;

         --  Convert.
         Name_Buffer (1) := 'X';
         P := N_Len;
         for J in reverse 2 .. Name_Length loop
            C := Name_Buffer (J);
            if Is_Extended_Char (C) then
               Name_Buffer (P - 0) := N2hex (Character'Pos (C) mod 16);
               Name_Buffer (P - 1) := N2hex (Character'Pos (C) / 16);
               Name_Buffer (P - 2) := '_';
               P := P - 3;
            else
               Name_Buffer (P) := C;
               P := P - 1;
            end if;
         end loop;
         Name_Buffer (N_Len + 1) := '_';
         Name_Buffer (N_Len + 2) := '_';
         Name_Length := N_Len + 2;
      end Name_Id_To_String;

      procedure Add_Name (Len : in out Natural; Name : Name_Id)
      is
         use Name_Table;
      begin
         Name_Id_To_String (Name);
         Add_String (Len, Name_Buffer (1 .. Name_Length));
      end Add_Name;

      procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type;
                                        Name : String;
                                        Val  : Iir_Int32 := 0)
      is
         P : Natural;
      begin
         Mark.Len := Identifier_Len;
         Mark.Local_Id := Identifier_Local;
         Identifier_Local := 0;
         P := Identifier_Len;
         Add_String (P, Name);
         if Val > 0 then
            Add_String (P, "O");
            Add_Nat (P, Natural (Val));
         end if;
         Add_String (P, "__");
         Identifier_Len := P;
      end Push_Identifier_Prefix;

      --  Add a suffix to the prefix (!!!).
      procedure Push_Identifier_Prefix
        (Mark : out Id_Mark_Type; Name : Name_Id; Val : Iir_Int32 := 0)
      is
         use Name_Table;
      begin
         Name_Id_To_String (Name);
         Push_Identifier_Prefix (Mark, Name_Buffer (1 .. Name_Length), Val);
      end Push_Identifier_Prefix;

      procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type)
      is
         Str : String := Local_Identifier_Type'Image (Identifier_Local);
      begin
         Identifier_Local := Identifier_Local + 1;
         Str (1) := 'U';
         Push_Identifier_Prefix (Mark, Str, 0);
      end Push_Identifier_Prefix_Uniq;

      procedure Add_Identifier (Len : in out Natural; Id : Name_Id) is
      begin
         if Id /= Null_Identifier then
            Add_Name (Len, Id);
         end if;
      end Add_Identifier;

      --  Create an identifier from IIR node ID without the prefix.
      function Create_Identifier_Without_Prefix (Id : Iir) return O_Ident
      is
         use Name_Table;
      begin
         Name_Id_To_String (Get_Identifier (Id));
         return Get_Identifier (Name_Buffer (1 .. Name_Length));
      end Create_Identifier_Without_Prefix;

      function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String)
                                                 return O_Ident
      is
         use Name_Table;
      begin
         Name_Id_To_String (Id);
         Name_Buffer (Name_Length + 1 .. Name_Length + Str'Length) := Str;
         return Get_Identifier (Name_Buffer (1 .. Name_Length + Str'Length));
      end Create_Identifier_Without_Prefix;

      --  Create an identifier from IIR node ID with prefix.
      function Create_Id (Id : Name_Id; Str : String; Is_Local : Boolean)
                          return O_Ident
      is
         L : Natural;
      begin
         L := Identifier_Len;
         Add_Identifier (L, Id);
         Add_String (L, Str);
         --Identifier_Buffer (L + Str'Length + 1) := Nul;
         if Is_Local then
            return Get_Identifier
              (Identifier_Buffer (Identifier_Start .. L));
         else
            return Get_Identifier (Identifier_Buffer (1 .. L));
         end if;
      end Create_Id;

      function Create_Identifier (Id : Name_Id; Str : String := "")
                                  return O_Ident
      is
      begin
         return Create_Id (Id, Str, False);
      end Create_Identifier;

      function Create_Identifier (Id : Iir; Str : String := "")
                                  return O_Ident
      is
      begin
         return Create_Id (Get_Identifier (Id), Str, False);
      end Create_Identifier;

      function Create_Identifier
        (Id : Iir; Val : Iir_Int32; Str : String := "")
         return O_Ident
      is
         Len : Natural;
      begin
         Len := Identifier_Len;
         Add_Identifier (Len, Get_Identifier (Id));

         if Val > 0 then
            Add_String (Len, "O");
            Add_Nat (Len, Natural (Val));
         end if;
         Add_String (Len, Str);
         return Get_Identifier (Identifier_Buffer (1 .. Len));
      end Create_Identifier;

      function Create_Identifier (Str : String)
                                  return O_Ident
      is
         Len : Natural;
      begin
         Len := Identifier_Len;
         Add_String (Len, Str);
         return Get_Identifier (Identifier_Buffer (1 .. Len));
      end Create_Identifier;

      function Create_Identifier return O_Ident
      is
      begin
         return Get_Identifier (Identifier_Buffer (1 .. Identifier_Len - 2));
      end Create_Identifier;

      function Create_Var_Identifier_From_Buffer (L : Natural)
                                                  return Var_Ident_Type
      is
         Start : Natural;
      begin
         if Is_Local_Scope then
            Start := Identifier_Start;
         else
            Start := 1;
         end if;
         return (Id => Get_Identifier (Identifier_Buffer (Start .. L)));
      end Create_Var_Identifier_From_Buffer;

      function Create_Var_Identifier (Id : Iir)
                                      return Var_Ident_Type
      is
         L : Natural := Identifier_Len;
      begin
         Add_Identifier (L, Get_Identifier (Id));
         return Create_Var_Identifier_From_Buffer (L);
      end Create_Var_Identifier;

      function Create_Var_Identifier (Id : String)
                                      return Var_Ident_Type
      is
         L : Natural := Identifier_Len;
      begin
         Add_String (L, Id);
         return Create_Var_Identifier_From_Buffer (L);
      end Create_Var_Identifier;

      function Create_Var_Identifier (Id : Iir; Str : String; Val : Natural)
                                      return Var_Ident_Type
      is
         L : Natural := Identifier_Len;
      begin
         Add_Identifier (L, Get_Identifier (Id));
         Add_String (L, Str);
         if Val > 0 then
            Add_String (L, "O");
            Add_Nat (L, Val);
         end if;
         return Create_Var_Identifier_From_Buffer (L);
      end Create_Var_Identifier;

      function Create_Uniq_Identifier return Var_Ident_Type
      is
         Res : Var_Ident_Type;
      begin
         Res.Id := Create_Uniq_Identifier;
         return Res;
      end Create_Uniq_Identifier;

      type Instantiate_Var_Stack;
      type Instantiate_Var_Stack_Acc is access Instantiate_Var_Stack;

      type Instantiate_Var_Stack is record
         Orig_Scope : Var_Scope_Acc;
         Inst_Scope : Var_Scope_Acc;
         Prev       : Instantiate_Var_Stack_Acc;
      end record;

      Top_Instantiate_Var_Stack  : Instantiate_Var_Stack_Acc := null;
      Free_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null;

      procedure Push_Instantiate_Var_Scope
        (Inst_Scope : Var_Scope_Acc; Orig_Scope : Var_Scope_Acc)
      is
         Inst : Instantiate_Var_Stack_Acc;
      begin
         if Free_Instantiate_Var_Stack = null then
            Inst := new Instantiate_Var_Stack;
         else
            Inst := Free_Instantiate_Var_Stack;
            Free_Instantiate_Var_Stack := Inst.Prev;
         end if;
         Inst.all := (Orig_Scope => Orig_Scope,
                      Inst_Scope => Inst_Scope,
                      Prev => Top_Instantiate_Var_Stack);
         Top_Instantiate_Var_Stack := Inst;
      end Push_Instantiate_Var_Scope;

      procedure Pop_Instantiate_Var_Scope (Inst_Scope : Var_Scope_Acc)
      is
         Item : constant Instantiate_Var_Stack_Acc :=
           Top_Instantiate_Var_Stack;
      begin
         pragma Assert (Item /= null);
         pragma Assert (Item.Inst_Scope = Inst_Scope);
         Top_Instantiate_Var_Stack := Item.Prev;
         Item.all := (Orig_Scope => null,
                      Inst_Scope => null,
                      Prev => Free_Instantiate_Var_Stack);
         Free_Instantiate_Var_Stack := Item;
      end Pop_Instantiate_Var_Scope;

      function Instantiated_Var_Scope (Scope : Var_Scope_Acc)
                                       return Var_Scope_Acc
      is
         Item : Instantiate_Var_Stack_Acc;
      begin
         if Scope = null then
            return null;
         end if;

         Item := Top_Instantiate_Var_Stack;
         loop
            pragma Assert (Item /= null);
            if Item.Orig_Scope = Scope then
               return Item.Inst_Scope;
            end if;
            Item := Item.Prev;
         end loop;
      end Instantiated_Var_Scope;

      function Instantiate_Var (Var : Var_Type) return Var_Type is
      begin
         case Var.Kind is
            when Var_None
               | Var_Global
               | Var_Local =>
               return Var;
            when Var_Scope =>
               return Var_Type'
                 (Kind => Var_Scope,
                  I_Field => Var.I_Field,
                  I_Scope => Instantiated_Var_Scope (Var.I_Scope));
         end case;
      end Instantiate_Var;

      function Instantiate_Var_Scope (Scope : Var_Scope_Type)
                                      return Var_Scope_Type is
      begin
         case Scope.Kind is
            when Var_Scope_None
               | Var_Scope_Ptr
               | Var_Scope_Decl =>
               return Scope;
            when Var_Scope_Field =>
               return Var_Scope_Type'
                 (Kind => Var_Scope_Field,
                  Scope_Type => Scope.Scope_Type,
                  Field => Scope.Field,
                  Up_Link => Instantiated_Var_Scope (Scope.Up_Link));
            when Var_Scope_Field_Ptr =>
               return Var_Scope_Type'
                 (Kind => Var_Scope_Field_Ptr,
                  Scope_Type => Scope.Scope_Type,
                  Field => Scope.Field,
                  Up_Link => Instantiated_Var_Scope (Scope.Up_Link));
         end case;
      end Instantiate_Var_Scope;
   end Chap10;

   function Get_Object_Kind (M : Mnode) return Object_Kind_Type is
   begin
      return M.M1.K;
   end Get_Object_Kind;

   function Get_Var
     (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type)
      return Mnode
   is
      L      : O_Lnode;
      D      : O_Dnode;
      Stable : Boolean;
   begin
      --  FIXME: there may be Vv2M and Vp2M.
      Stable := Is_Var_Stable (Var);
      if Stable then
         D := Get_Var_Label (Var);
      else
         L := Get_Var (Var);
      end if;
      case Vtype.Type_Mode is
         when Type_Mode_Scalar
            | Type_Mode_Acc
            | Type_Mode_File
            | Type_Mode_Fat_Array
            | Type_Mode_Fat_Acc =>
            if Stable then
               return Dv2M (D, Vtype, Mode);
            else
               return Lv2M (L, Vtype, Mode);
            end if;
         when Type_Mode_Array
            | Type_Mode_Record
            | Type_Mode_Protected =>
            if Is_Complex_Type (Vtype) then
               if Stable then
                  return Dp2M (D, Vtype, Mode);
               else
                  return Lp2M (L, Vtype, Mode);
               end if;
            else
               if Stable then
                  return Dv2M (D, Vtype, Mode);
               else
                  return Lv2M (L, Vtype, Mode);
               end if;
            end if;
         when Type_Mode_Unknown =>
            raise Internal_Error;
      end case;
   end Get_Var;

   function Stabilize (M : Mnode; Can_Copy : Boolean := False) return Mnode
   is
      K : constant Object_Kind_Type := M.M1.K;
      D : O_Dnode;
   begin
      case M.M1.State is
         when Mstate_E =>
            if Is_Composite (M.M1.T) then
               --  Create a pointer variable.
               D := Create_Temp_Init (M.M1.Ptype, M.M1.E);
               return Mnode'(M1 => (State => Mstate_Dp,
                                    K => K, T => M.M1.T, Dp => D,
                                    Vtype => M.M1.Vtype, Ptype => M.M1.Ptype));
            else
               --  Create a scalar variable.
               D := Create_Temp_Init (M.M1.Vtype, M.M1.E);
               return Mnode'(M1 => (State => Mstate_Dv,
                                    K => K, T => M.M1.T, Dv => D,
                                    Vtype => M.M1.Vtype, Ptype => M.M1.Ptype));
            end if;
         when Mstate_Lp =>
            D := Create_Temp_Init (M.M1.Ptype, New_Value (M.M1.Lp));
            return Mnode'(M1 => (State => Mstate_Dp,
                                 K => K, T => M.M1.T, Dp => D,
                                 Vtype => M.M1.Vtype, Ptype => M.M1.Ptype));
         when Mstate_Lv =>
            if M.M1.Ptype = O_Tnode_Null then
               if not Can_Copy then
                  raise Internal_Error;
               end if;
               D := Create_Temp_Init (M.M1.Vtype, New_Value (M.M1.Lv));
               return Mnode'(M1 => (State => Mstate_Dv,
                                    K => K, T => M.M1.T, Dv => D,
                                    Vtype => M.M1.Vtype, Ptype => M.M1.Ptype));

            else
               D := Create_Temp_Ptr (M.M1.Ptype, M.M1.Lv);
               return Mnode'(M1 => (State => Mstate_Dp,
                                    K => K, T => M.M1.T, Dp => D,
                                    Vtype => M.M1.Vtype, Ptype => M.M1.Ptype));
            end if;
         when Mstate_Dp
            | Mstate_Dv =>
            return M;
         when Mstate_Bad
            | Mstate_Null =>
            raise Internal_Error;
      end case;
   end Stabilize;

   procedure Stabilize (M : in out Mnode) is
   begin
      M := Stabilize (M);
   end Stabilize;

   function Stabilize_Value (M : Mnode) return Mnode
   is
      D : O_Dnode;
      E : O_Enode;
   begin
      --  M must be scalar or access.
      pragma Assert (not Is_Composite (M.M1.T));
      case M.M1.State is
         when Mstate_E =>
            E := M.M1.E;
         when Mstate_Lp =>
            E := New_Value (New_Acc_Value (M.M1.Lp));
         when Mstate_Lv =>
            E := New_Value (M.M1.Lv);
         when Mstate_Dp
            | Mstate_Dv =>
            return M;
         when Mstate_Bad
            | Mstate_Null =>
            raise Internal_Error;
      end case;

      D := Create_Temp_Init (M.M1.Vtype, E);
      return Mnode'(M1 => (State => Mstate_Dv,
                           K => M.M1.K, T => M.M1.T, Dv => D,
                           Vtype => M.M1.Vtype, Ptype => M.M1.Ptype));
   end Stabilize_Value;

   function Create_Temp (Info : Type_Info_Acc;
                         Kind : Object_Kind_Type := Mode_Value)
                         return Mnode is
   begin
      if Is_Complex_Type (Info)
        and then Info.Type_Mode /= Type_Mode_Fat_Array
      then
         --  For a complex and constrained object, we just allocate
         --  a pointer to the object.
         return Dp2M (Create_Temp (Info.Ortho_Ptr_Type (Kind)), Info, Kind);
      else
         return Dv2M (Create_Temp (Info.Ortho_Type (Kind)), Info, Kind);
      end if;
   end Create_Temp;

   function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode)
                                          return O_Enode is
   begin
      return New_Value
        (New_Selected_Element (New_Access_Element (New_Value (L)), Field));
   end New_Value_Selected_Acc_Value;

   function New_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode)
                                    return O_Lnode is
   begin
      return New_Selected_Element
        (New_Access_Element (New_Value (L)), Field);
   end New_Selected_Acc_Value;

   function New_Indexed_Acc_Value (L : O_Lnode; I : O_Enode) return O_Lnode
   is
   begin
      return New_Indexed_Element (New_Access_Element (New_Value (L)), I);
   end New_Indexed_Acc_Value;

   function New_Acc_Value (L : O_Lnode) return O_Lnode is
   begin
      return New_Access_Element (New_Value (L));
   end New_Acc_Value;

   package Node_Infos is new GNAT.Table
     (Table_Component_Type => Ortho_Info_Acc,
      Table_Index_Type => Iir,
      Table_Low_Bound => 0,
      Table_Initial => 1024,
      Table_Increment => 100);

   procedure Init_Node_Infos is
   begin
      --  Create the node extension for translate.
      Node_Infos.Init;
      Node_Infos.Set_Last (4);
      Node_Infos.Table (0 .. 4) := (others => null);
   end Init_Node_Infos;

   procedure Update_Node_Infos
   is
      use Nodes;
      F, L : Iir;
   begin
      F := Node_Infos.Last;
      L := Nodes.Get_Last_Node;
      Node_Infos.Set_Last (L);
      Node_Infos.Table (F + 1 .. L) := (others => null);
   end Update_Node_Infos;

   procedure Set_Info (Target : Iir; Info : Ortho_Info_Acc) is
   begin
      if Node_Infos.Table (Target) /= null then
         raise Internal_Error;
      end if;
      Node_Infos.Table (Target) := Info;
   end Set_Info;

   procedure Clear_Info (Target : Iir) is
   begin
      Node_Infos.Table (Target) := null;
   end Clear_Info;

   function Get_Info (Target : Iir) return Ortho_Info_Acc is
   begin
      return Node_Infos.Table (Target);
   end Get_Info;

   --  Create an ortho_info field of kind KIND for iir node TARGET, and
   --  return it.
   function Add_Info (Target : Iir; Kind : Ortho_Info_Kind)
                      return Ortho_Info_Acc
   is
      Res : Ortho_Info_Acc;
   begin
      Res := new Ortho_Info_Type (Kind);
      Set_Info (Target, Res);
      return Res;
   end Add_Info;

   procedure Free_Info (Target : Iir)
   is
      Info : Ortho_Info_Acc;
   begin
      Info := Get_Info (Target);
      if Info /= null then
         Unchecked_Deallocation (Info);
         Clear_Info (Target);
      end if;
   end Free_Info;

   procedure Free_Type_Info (Info : in out Type_Info_Acc) is
   begin
      if Info.C /= null then
         Free_Complex_Type_Info (Info.C);
      end if;
      Unchecked_Deallocation (Info);
   end Free_Type_Info;

   procedure Set_Ortho_Expr (Target : Iir; Expr : O_Cnode)
   is
      Info : Ortho_Info_Acc;
   begin
      Info := Add_Info (Target, Kind_Expr);
      Info.Expr_Node := Expr;
   end Set_Ortho_Expr;

   function Get_Ortho_Expr (Target : Iir) return O_Cnode is
   begin
      return Get_Info (Target).Expr_Node;
   end Get_Ortho_Expr;

   function Get_Ortho_Type (Target : Iir; Is_Sig : Object_Kind_Type)
                            return O_Tnode is
   begin
      return Get_Info (Target).Ortho_Type (Is_Sig);
   end Get_Ortho_Type;

   function Is_Composite (Info : Type_Info_Acc) return Boolean is
   begin
      return Info.Type_Mode in Type_Mode_Fat;
   end Is_Composite;

   function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean is
   begin
      return Tinfo.C /= null;
   end Is_Complex_Type;

   procedure Free_Node_Infos
   is
      Info      : Ortho_Info_Acc;
      Prev_Info : Ortho_Info_Acc;
   begin
      Prev_Info := null;
      for I in Node_Infos.First .. Node_Infos.Last loop
         Info := Get_Info (I);
         if Info /= null and then Info /= Prev_Info then
            case Get_Kind (I) is
               when Iir_Kind_Constant_Declaration =>
                  if Get_Deferred_Declaration_Flag (I) = False
                    and then Get_Deferred_Declaration (I) /= Null_Iir
                  then
                     --  Info are copied from incomplete constant declaration
                     --  to full constant declaration.
                     Clear_Info (I);
                  else
                     Free_Info (I);
                  end if;
               when Iir_Kind_Record_Subtype_Definition
                  | Iir_Kind_Access_Subtype_Definition =>
                  null;
               when Iir_Kind_Enumeration_Type_Definition
                  | Iir_Kind_Array_Type_Definition
                  | Iir_Kind_Integer_Subtype_Definition
                  | Iir_Kind_Floating_Subtype_Definition
                  | Iir_Kind_Physical_Subtype_Definition
                  | Iir_Kind_Enumeration_Subtype_Definition =>
                  Free_Type_Info (Info);
               when Iir_Kind_Array_Subtype_Definition =>
                  if Get_Index_Constraint_Flag (I) then
                     Info.T := Ortho_Info_Type_Array_Init;
                     Free_Type_Info (Info);
                  end if;
               when Iir_Kind_Implicit_Function_Declaration =>
                  case Get_Implicit_Definition (I) is
                     when Iir_Predefined_Bit_Array_Match_Equality
                        |  Iir_Predefined_Bit_Array_Match_Inequality =>
                        --  Not in sequence.
                        null;
                     when others =>
                        --  By default, info are not shared.
                        --  The exception is infos for implicit subprograms,
                        --  but they are always consecutive and not free twice
                        --  due to prev_info mechanism.
                        Free_Info (I);
                  end case;
               when others =>
                  --  By default, info are not shared.
                  Free_Info (I);
            end case;
            Prev_Info := Info;
         end if;
      end loop;
      Node_Infos.Free;
   end Free_Node_Infos;

   function Get_Type_Info (M : Mnode) return Type_Info_Acc is
   begin
      return M.M1.T;
   end Get_Type_Info;

   function E2M (E : O_Enode; T : Type_Info_Acc; Kind : Object_Kind_Type)
                 return Mnode is
   begin
      return Mnode'(M1 => (State => Mstate_E,
                           K => Kind, T => T, E => E,
                           Vtype => T.Ortho_Type (Kind),
                           Ptype => T.Ortho_Ptr_Type (Kind)));
   end E2M;

   function Lv2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type)
                  return Mnode is
   begin
      return Mnode'(M1 => (State => Mstate_Lv,
                           K => Kind, T => T, Lv => L,
                           Vtype => T.Ortho_Type (Kind),
                           Ptype => T.Ortho_Ptr_Type (Kind)));
   end Lv2M;

   function Lv2M (L     : O_Lnode;
                  T     : Type_Info_Acc;
                  Kind  : Object_Kind_Type;
                  Vtype : O_Tnode;
                  Ptype : O_Tnode)
                  return Mnode is
   begin
      return Mnode'(M1 => (State => Mstate_Lv,
                           K => Kind, T => T, Lv => L,
                           Vtype => Vtype, Ptype => Ptype));
   end Lv2M;

   function Lp2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type)
                  return Mnode is
   begin
      return Mnode'(M1 => (State => Mstate_Lp,
                           K => Kind, T => T, Lp => L,
                           Vtype => T.Ortho_Type (Kind),
                           Ptype => T.Ortho_Ptr_Type (Kind)));
   end Lp2M;

   function Lp2M (L     : O_Lnode;
                  T     : Type_Info_Acc;
                  Kind  : Object_Kind_Type;
                  Vtype : O_Tnode;
                  Ptype : O_Tnode)
                  return Mnode is
   begin
      return Mnode'(M1 => (State => Mstate_Lp,
                           K => Kind, T => T, Lp => L,
                           Vtype => Vtype, Ptype => Ptype));
   end Lp2M;

   function Dv2M (D    : O_Dnode;
                  T    : Type_Info_Acc;
                  Kind : Object_Kind_Type)
                  return Mnode is
   begin
      return Mnode'(M1 => (State => Mstate_Dv,
                           K => Kind, T => T, Dv => D,
                           Vtype => T.Ortho_Type (Kind),
                           Ptype => T.Ortho_Ptr_Type (Kind)));
   end Dv2M;

   function Dv2M (D     : O_Dnode;
                  T     : Type_Info_Acc;
                  Kind  : Object_Kind_Type;
                  Vtype : O_Tnode;
                  Ptype : O_Tnode)
                  return Mnode is
   begin
      return Mnode'(M1 => (State => Mstate_Dv,
                           K => Kind, T => T, Dv => D,
                           Vtype => Vtype,
                           Ptype => Ptype));
   end Dv2M;

   function Dp2M (D     : O_Dnode;
                  T     : Type_Info_Acc;
                  Kind  : Object_Kind_Type;
                  Vtype : O_Tnode;
                  Ptype : O_Tnode)
                  return Mnode is
   begin
      return Mnode'(M1 => (State => Mstate_Dp,
                           K => Kind, T => T, Dp => D,
                           Vtype => Vtype, Ptype => Ptype));
   end Dp2M;

   function Dp2M (D    : O_Dnode;
                  T    : Type_Info_Acc;
                  Kind : Object_Kind_Type)
                  return Mnode is
   begin
      return Mnode'(M1 => (State => Mstate_Dp,
                           K => Kind, T => T, Dp => D,
                           Vtype => T.Ortho_Type (Kind),
                           Ptype => T.Ortho_Ptr_Type (Kind)));
   end Dp2M;

   function M2Lv (M : Mnode) return O_Lnode is
   begin
      case M.M1.State is
         when Mstate_E =>
            case Get_Type_Info (M).Type_Mode is
               when Type_Mode_Thin =>
                  --  Scalar to var is not possible.
                  --  FIXME: This is not coherent with the fact that this
                  --  conversion is possible when M is stabilized.
                  raise Internal_Error;
               when Type_Mode_Fat =>
                  return New_Access_Element (M.M1.E);
               when Type_Mode_Unknown =>
                  raise Internal_Error;
            end case;
         when Mstate_Lp =>
            return New_Acc_Value (M.M1.Lp);
         when Mstate_Lv =>
            return M.M1.Lv;
         when Mstate_Dp =>
            return New_Acc_Value (New_Obj (M.M1.Dp));
         when Mstate_Dv =>
            return New_Obj (M.M1.Dv);
         when Mstate_Null
            | Mstate_Bad =>
            raise Internal_Error;
      end case;
   end M2Lv;

   function M2Lp (M : Mnode) return O_Lnode is
   begin
      case M.M1.State is
         when Mstate_E =>
            raise Internal_Error;
         when Mstate_Lp =>
            return M.M1.Lp;
         when Mstate_Dp =>
            return New_Obj (M.M1.Dp);
         when Mstate_Lv =>
            if Get_Type_Info (M).Type_Mode in Type_Mode_Fat then
               return New_Obj
                 (Create_Temp_Init (M.M1.Ptype,
                  New_Address (M.M1.Lv, M.M1.Ptype)));
            else
               raise Internal_Error;
            end if;
         when Mstate_Dv
            | Mstate_Null
            | Mstate_Bad =>
            raise Internal_Error;
      end case;
   end M2Lp;

   function M2Dp (M : Mnode) return O_Dnode is
   begin
      case M.M1.State is
         when Mstate_Dp =>
            return M.M1.Dp;
         when Mstate_Dv =>
            return Create_Temp_Init
              (M.M1.Ptype, New_Address (New_Obj (M.M1.Dv), M.M1.Ptype));

         when others =>
            raise Internal_Error;
      end case;
   end M2Dp;

   function M2Dv (M : Mnode) return O_Dnode is
   begin
      case M.M1.State is
         when Mstate_Dv =>
            return M.M1.Dv;
         when others =>
            raise Internal_Error;
      end case;
   end M2Dv;

   function T2M (Atype : Iir; Kind : Object_Kind_Type) return Mnode
   is
      T : Type_Info_Acc;
   begin
      T := Get_Info (Atype);
      return Mnode'(M1 => (State => Mstate_Null,
                           K => Kind, T => T,
                           Vtype => T.Ortho_Type (Kind),
                           Ptype => T.Ortho_Ptr_Type (Kind)));
   end T2M;

   function M2E (M : Mnode) return O_Enode is
   begin
      case M.M1.State is
         when Mstate_E =>
            return M.M1.E;
         when Mstate_Lp =>
            case M.M1.T.Type_Mode is
               when Type_Mode_Unknown =>
                  raise Internal_Error;
               when Type_Mode_Thin =>
                  return New_Value (New_Acc_Value (M.M1.Lp));
               when Type_Mode_Fat =>
                  return New_Value (M.M1.Lp);
            end case;
         when Mstate_Dp =>
            case M.M1.T.Type_Mode is
               when Type_Mode_Unknown =>
                  raise Internal_Error;
               when Type_Mode_Thin =>
                  return New_Value (New_Acc_Value (New_Obj (M.M1.Dp)));
               when Type_Mode_Fat =>
                  return New_Value (New_Obj (M.M1.Dp));
            end case;
         when Mstate_Lv =>
            case M.M1.T.Type_Mode is
               when Type_Mode_Unknown =>
                  raise Internal_Error;
               when Type_Mode_Thin =>
                  return New_Value (M.M1.Lv);
               when Type_Mode_Fat =>
                  return New_Address (M.M1.Lv, M.M1.Ptype);
            end case;
         when Mstate_Dv =>
            case M.M1.T.Type_Mode is
               when Type_Mode_Unknown =>
                  raise Internal_Error;
               when Type_Mode_Thin =>
                  return New_Value (New_Obj (M.M1.Dv));
               when Type_Mode_Fat =>
                  return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype);
            end case;
         when Mstate_Bad
            | Mstate_Null =>
            raise Internal_Error;
      end case;
   end M2E;

   function M2Addr (M : Mnode) return O_Enode is
   begin
      case M.M1.State is
         when Mstate_Lp =>
            return New_Value (M.M1.Lp);
         when Mstate_Dp =>
            return New_Value (New_Obj (M.M1.Dp));
         when Mstate_Lv =>
            return New_Address (M.M1.Lv, M.M1.Ptype);
         when Mstate_Dv =>
            return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype);
         when Mstate_E =>
            --  For scalar, M contains the value so there is no lvalue from
            --  which the address can be taken.
            pragma Assert (Is_Composite (M.M1.T));
            return M.M1.E;
         when Mstate_Bad
            | Mstate_Null =>
            raise Internal_Error;
      end case;
   end M2Addr;

   --    function Is_Null (M : Mnode) return Boolean is
   --    begin
   --       return M.M1.State = Mstate_Null;
   --    end Is_Null;

   function Is_Stable (M : Mnode) return Boolean is
   begin
      case M.M1.State is
         when Mstate_Dp
            | Mstate_Dv =>
            return True;
         when others =>
            return False;
      end case;
   end Is_Stable;

   --    function Varv2M
   --      (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type)
   --      return Mnode is
   --    begin
   --       return Lv2M (Get_Var (Var), Vtype, Mode);
   --    end Varv2M;

   function Varv2M (Var      : Var_Type;
                    Var_Type : Type_Info_Acc;
                    Mode     : Object_Kind_Type;
                    Vtype    : O_Tnode;
                    Ptype    : O_Tnode)
                    return Mnode is
   begin
      return Lv2M (Get_Var (Var), Var_Type, Mode, Vtype, Ptype);
   end Varv2M;

   --  Convert a Lnode for a sub object to an MNODE.
   function Lo2M (L : O_Lnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type)
                  return Mnode is
   begin
      case Vtype.Type_Mode is
         when Type_Mode_Scalar
            | Type_Mode_Acc
            | Type_Mode_File
            | Type_Mode_Fat_Array
            | Type_Mode_Fat_Acc =>
            return Lv2M (L, Vtype, Mode);
         when Type_Mode_Array
            | Type_Mode_Record
            | Type_Mode_Protected =>
            if Is_Complex_Type (Vtype) then
               return Lp2M (L, Vtype, Mode);
            else
               return Lv2M (L, Vtype, Mode);
            end if;
         when Type_Mode_Unknown =>
            raise Internal_Error;
      end case;
   end Lo2M;

   function Lo2M (D : O_Dnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type)
                  return Mnode is
   begin
      case Vtype.Type_Mode is
         when Type_Mode_Scalar
            | Type_Mode_Acc
            | Type_Mode_File
            | Type_Mode_Fat_Array
            | Type_Mode_Fat_Acc =>
            return Dv2M (D, Vtype, Mode);
         when Type_Mode_Array
            | Type_Mode_Record
            | Type_Mode_Protected =>
            if Is_Complex_Type (Vtype) then
               return Dp2M (D, Vtype, Mode);
            else
               return Dv2M (D, Vtype, Mode);
            end if;
         when Type_Mode_Unknown =>
            raise Internal_Error;
      end case;
   end Lo2M;

   package body Helpers is
      procedure Inc_Var (V : O_Dnode) is
      begin
         New_Assign_Stmt (New_Obj (V),
                          New_Dyadic_Op (ON_Add_Ov,
                            New_Obj_Value (V),
                            New_Lit (Ghdl_Index_1)));
      end Inc_Var;

      procedure Dec_Var (V : O_Dnode) is
      begin
         New_Assign_Stmt (New_Obj (V),
                          New_Dyadic_Op (ON_Sub_Ov,
                            New_Obj_Value (V),
                            New_Lit (Ghdl_Index_1)));
      end Dec_Var;

      procedure Init_Var (V : O_Dnode) is
      begin
         New_Assign_Stmt (New_Obj (V), New_Lit (Ghdl_Index_0));
      end Init_Var;

      procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode)
      is
         If_Blk : O_If_Block;
      begin
         Start_If_Stmt (If_Blk, Cond);
         New_Exit_Stmt (Label);
         Finish_If_Stmt (If_Blk);
      end Gen_Exit_When;

      --  Create a temporary variable.
      type Temp_Level_Type;
      type Temp_Level_Acc is access Temp_Level_Type;
      type Temp_Level_Type is record
         Prev            : Temp_Level_Acc;
         Level           : Natural;
         Id              : Natural;
         Emitted         : Boolean;
         Stack2_Mark     : O_Dnode;
         Transient_Types : Iir;
      end record;
      --  Current level.
      Temp_Level : Temp_Level_Acc := null;

      --  List of unused temp_level_type structures.  To be faster, they are
      --  never deallocated.
      Old_Level : Temp_Level_Acc := null;

      --  If set, emit comments for open_temp/close_temp.
      Flag_Debug_Temp : constant Boolean := False;

      procedure Open_Temp
      is
         L : Temp_Level_Acc;
      begin
         if Old_Level /= null then
            L := Old_Level;
            Old_Level := L.Prev;
         else
            L := new Temp_Level_Type;
         end if;
         L.all := (Prev => Temp_Level,
                   Level => 0,
                   Id => 0,
                   Emitted => False,
                   Stack2_Mark => O_Dnode_Null,
                   Transient_Types => Null_Iir);
         if Temp_Level /= null then
            L.Level := Temp_Level.Level + 1;
         end if;
         Temp_Level := L;
         if Flag_Debug_Temp then
            New_Debug_Comment_Stmt
              ("Open_Temp level " & Natural'Image (L.Level));
         end if;
      end Open_Temp;

      procedure Open_Local_Temp is
      begin
         Open_Temp;
         Temp_Level.Emitted := True;
      end Open_Local_Temp;

      procedure Add_Transient_Type_In_Temp (Atype : Iir)
      is
         Type_Info : Type_Info_Acc;
      begin
         Type_Info := Get_Info (Atype);
         Type_Info.Type_Transient_Chain := Temp_Level.Transient_Types;
         Temp_Level.Transient_Types := Atype;
      end Add_Transient_Type_In_Temp;

      --  Some expressions may be evaluated several times in different
      --  contexts.  Type info created for these expressions may not be
      --  shared between these contexts.
      procedure Destroy_Type_Info (Atype : Iir)
      is
         Type_Info : Type_Info_Acc;
      begin
         Type_Info := Get_Info (Atype);
         Free_Type_Info (Type_Info);
         Clear_Info (Atype);
      end Destroy_Type_Info;

      procedure Release_Transient_Types (Chain : in out Iir) is
         N_Atype : Iir;
      begin
         while Chain /= Null_Iir loop
            N_Atype := Get_Info (Chain).Type_Transient_Chain;
            Destroy_Type_Info (Chain);
            Chain := N_Atype;
         end loop;
      end Release_Transient_Types;

      procedure Destroy_Local_Transient_Types is
      begin
         Release_Transient_Types (Temp_Level.Transient_Types);
      end Destroy_Local_Transient_Types;

      function Has_Stack2_Mark return Boolean is
      begin
         return Temp_Level.Stack2_Mark /= O_Dnode_Null;
      end Has_Stack2_Mark;

      procedure Stack2_Release
      is
         Constr : O_Assoc_List;
      begin
         if Temp_Level.Stack2_Mark /= O_Dnode_Null then
            Start_Association (Constr, Ghdl_Stack2_Release);
            New_Association (Constr,
                             New_Value (New_Obj (Temp_Level.Stack2_Mark)));
            New_Procedure_Call (Constr);
            Temp_Level.Stack2_Mark := O_Dnode_Null;
         end if;
      end Stack2_Release;

      procedure Close_Temp
      is
         L : Temp_Level_Acc;
      begin
         if Temp_Level = null then
            --  OPEN_TEMP was not called.
            raise Internal_Error;
         end if;
         if Flag_Debug_Temp then
            New_Debug_Comment_Stmt
              ("Close_Temp level " & Natural'Image (Temp_Level.Level));
         end if;

         if Temp_Level.Stack2_Mark /= O_Dnode_Null then
            Stack2_Release;
         end if;
         if Temp_Level.Emitted then
            Finish_Declare_Stmt;
         end if;

         --  Destroy transcient types.
         Release_Transient_Types (Temp_Level.Transient_Types);

         --  Unlink temp_level.
         L := Temp_Level;
         Temp_Level := L.Prev;
         L.Prev := Old_Level;
         Old_Level := L;
      end Close_Temp;

      procedure Close_Local_Temp is
      begin
         Temp_Level.Emitted := False;
         Close_Temp;
      end Close_Local_Temp;

      procedure Free_Old_Temp
      is
         procedure Free is new Ada.Unchecked_Deallocation
           (Temp_Level_Type, Temp_Level_Acc);
         T : Temp_Level_Acc;
      begin
         if Temp_Level /= null then
            --  Missing Close_Temp.
            raise Internal_Error;
         end if;
         loop
            T := Old_Level;
            exit when T = null;
            Old_Level := Old_Level.Prev;
            Free (T);
         end loop;
      end Free_Old_Temp;

      procedure Create_Temp_Stack2_Mark
      is
         Constr : O_Assoc_List;
      begin
         if Temp_Level.Stack2_Mark /= O_Dnode_Null then
            --  Only the first mark in a region is registred.
            --  The release operation frees the memory allocated after the
            --  first mark.
            return;
         end if;
         Temp_Level.Stack2_Mark := Create_Temp (Ghdl_Ptr_Type);
         Start_Association (Constr, Ghdl_Stack2_Mark);
         New_Assign_Stmt (New_Obj (Temp_Level.Stack2_Mark),
                          New_Function_Call (Constr));
      end Create_Temp_Stack2_Mark;

      function Create_Temp (Atype : O_Tnode) return O_Dnode
      is
         Str : String (1 .. 12);
         Val : Natural;
         Res : O_Dnode;
         P   : Natural;
      begin
         if Temp_Level = null then
            --  OPEN_TEMP was never called.
            raise Internal_Error;
            --  This is an hack, just to allow array subtype to array type
            --  conversion.
            --New_Var_Decl
            --  (Res, Create_Uniq_Identifier, O_Storage_Private, Atype);
            --return Res;
         else
            if not Temp_Level.Emitted then
               Temp_Level.Emitted := True;
               Start_Declare_Stmt;
            end if;
         end if;
         Val := Temp_Level.Id;
         Temp_Level.Id := Temp_Level.Id + 1;
         P := Str'Last;
         loop
            Str (P) := Character'Val (Val mod 10 + Character'Pos ('0'));
            Val := Val / 10;
            P := P - 1;
            exit when Val = 0;
         end loop;
         Str (P) := '_';
         P := P - 1;
         Val := Temp_Level.Level;
         loop
            Str (P) := Character'Val (Val mod 10 + Character'Pos ('0'));
            Val := Val / 10;
            P := P - 1;
            exit when Val = 0;
         end loop;
         Str (P) := 'T';
         --Str (12) := Nul;
         New_Var_Decl
           (Res, Get_Identifier (Str (P .. Str'Last)), O_Storage_Local, Atype);
         return Res;
      end Create_Temp;

      function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode)
                                 return O_Dnode
      is
         Res : O_Dnode;
      begin
         Res := Create_Temp (Atype);
         New_Assign_Stmt (New_Obj (Res), Value);
         return Res;
      end Create_Temp_Init;

      function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode)
                                return O_Dnode is
      begin
         return Create_Temp_Init (Atype, New_Address (Name, Atype));
      end Create_Temp_Ptr;

      --  Return a ghdl_index_type literal for NUM.
      function New_Index_Lit (Num : Unsigned_64) return O_Cnode is
      begin
         return New_Unsigned_Literal (Ghdl_Index_Type, Num);
      end New_Index_Lit;

      Uniq_Id : Natural := 0;

      function Create_Uniq_Identifier return Uniq_Identifier_String
      is
         Str : Uniq_Identifier_String;
         Val : Natural;
      begin
         Str (1 .. 3) := "_UI";
         Val := Uniq_Id;
         Uniq_Id := Uniq_Id + 1;
         for I in reverse 4 .. 11 loop
            Str (I) := N2hex (Val mod 16);
            Val := Val / 16;
         end loop;
         return Str;
      end Create_Uniq_Identifier;

      function Create_Uniq_Identifier return O_Ident is
      begin
         return Get_Identifier (Create_Uniq_Identifier);
      end Create_Uniq_Identifier;

   end Helpers;

end Trans;