Split translation into child packages.

author: Tristan Gingold <tgingold@free.fr> 2014-11-09 18:31:54 +0100
committer: Tristan Gingold <tgingold@free.fr> 2014-11-09 18:31:54 +0100
commit: fe94cb3cc3fd4517271faa9046c74b0c455aeb79 (patch)
tree: 17ba28586cb5eb22d530c568d917931f309d871f /src/vhdl/translate/trans-chap2.adb
parent: 3c9a77e9e6f3b8047080f7d8c11bb9881cabf968 (diff)
download: ghdl-fe94cb3cc3fd4517271faa9046c74b0c455aeb79.tar.gz
ghdl-fe94cb3cc3fd4517271faa9046c74b0c455aeb79.tar.bz2
ghdl-fe94cb3cc3fd4517271faa9046c74b0c455aeb79.zip
1 files changed, 1263 insertions, 0 deletions
diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb
new file mode 100644
index 000000000..c4845a0e8
--- /dev/null
+++ b/src/vhdl/translate/trans-chap2.adb
@@ -0,0 +1,1263 @@
+--  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;
+with Std_Names;
+with Std_Package; use Std_Package;
+with Errorout; use Errorout;
+with Sem_Inst;
+with Nodes_Meta;
+with Iirs_Utils; use Iirs_Utils;
+with Trans.Chap3;
+with Trans.Chap4;
+with Trans.Chap5;
+with Trans.Chap6;
+with Trans.Chap8;
+with Trans.Rtis;
+with Trans_Decls; use Trans_Decls;
+with Translation; use Translation;
+
+package body Trans.Chap2 is
+   use Trans.Subprgs;
+   use Trans.Helpers;
+
+   procedure Elab_Package (Spec : Iir_Package_Declaration);
+
+   type Name_String_Xlat_Array is array (Name_Id range <>) of
+     String (1 .. 4);
+   Operator_String_Xlat : constant
+     Name_String_Xlat_Array (Std_Names.Name_Id_Operators) :=
+     (Std_Names.Name_Op_Equality => "OPEq",
+      Std_Names.Name_Op_Inequality => "OPNe",
+      Std_Names.Name_Op_Less => "OPLt",
+      Std_Names.Name_Op_Less_Equal => "OPLe",
+      Std_Names.Name_Op_Greater => "OPGt",
+      Std_Names.Name_Op_Greater_Equal => "OPGe",
+      Std_Names.Name_Op_Plus => "OPPl",
+      Std_Names.Name_Op_Minus => "OPMi",
+      Std_Names.Name_Op_Mul => "OPMu",
+      Std_Names.Name_Op_Div => "OPDi",
+      Std_Names.Name_Op_Exp => "OPEx",
+      Std_Names.Name_Op_Concatenation => "OPCc",
+      Std_Names.Name_Op_Condition => "OPCd",
+      Std_Names.Name_Op_Match_Equality => "OPQe",
+      Std_Names.Name_Op_Match_Inequality => "OPQi",
+      Std_Names.Name_Op_Match_Less => "OPQL",
+      Std_Names.Name_Op_Match_Less_Equal => "OPQl",
+      Std_Names.Name_Op_Match_Greater => "OPQG",
+      Std_Names.Name_Op_Match_Greater_Equal => "OPQg");
+
+   --  Set the identifier prefix with the subprogram identifier and
+   --  overload number if any.
+   procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type)
+   is
+      Id : Name_Id;
+   begin
+      --  FIXME: name_shift_operators, name_logical_operators,
+      --   name_word_operators, name_mod, name_rem
+      Id := Get_Identifier (Spec);
+      if Id in Std_Names.Name_Id_Operators then
+         Push_Identifier_Prefix
+           (Mark, Operator_String_Xlat (Id), Get_Overload_Number (Spec));
+      else
+         Push_Identifier_Prefix (Mark, Id, Get_Overload_Number (Spec));
+      end if;
+   end Push_Subprg_Identifier;
+
+   procedure Translate_Subprogram_Interfaces (Spec : Iir)
+   is
+      Inter : Iir;
+      Mark  : Id_Mark_Type;
+   begin
+      --  Set the identifier prefix with the subprogram identifier and
+      --  overload number if any.
+      Push_Subprg_Identifier (Spec, Mark);
+
+      --  Translate interface types.
+      Inter := Get_Interface_Declaration_Chain (Spec);
+      while Inter /= Null_Iir loop
+         Chap3.Translate_Object_Subtype (Inter);
+         Inter := Get_Chain (Inter);
+      end loop;
+      Pop_Identifier_Prefix (Mark);
+   end Translate_Subprogram_Interfaces;
+
+   procedure Elab_Subprogram_Interfaces (Spec : Iir)
+   is
+      Inter : Iir;
+   begin
+      --  Translate interface types.
+      Inter := Get_Interface_Declaration_Chain (Spec);
+      while Inter /= Null_Iir loop
+         Chap3.Elab_Object_Subtype (Get_Type (Inter));
+         Inter := Get_Chain (Inter);
+      end loop;
+   end Elab_Subprogram_Interfaces;
+
+
+   --  Return the type of a subprogram interface.
+   --  Return O_Tnode_Null if the parameter is passed through the
+   --  interface record.
+   function Translate_Interface_Type (Inter : Iir) return O_Tnode
+   is
+      Mode  : Object_Kind_Type;
+      Tinfo : constant Type_Info_Acc := Get_Info (Get_Type (Inter));
+   begin
+      case Get_Kind (Inter) is
+         when Iir_Kind_Interface_Constant_Declaration
+            | Iir_Kind_Interface_Variable_Declaration
+            | Iir_Kind_Interface_File_Declaration =>
+            Mode := Mode_Value;
+         when Iir_Kind_Interface_Signal_Declaration =>
+            Mode := Mode_Signal;
+         when others =>
+            Error_Kind ("translate_interface_type", Inter);
+      end case;
+      case Tinfo.Type_Mode is
+         when Type_Mode_Unknown =>
+            raise Internal_Error;
+         when Type_Mode_By_Value =>
+            return Tinfo.Ortho_Type (Mode);
+         when Type_Mode_By_Copy
+            | Type_Mode_By_Ref =>
+            return Tinfo.Ortho_Ptr_Type (Mode);
+      end case;
+   end Translate_Interface_Type;
+
+   procedure Translate_Subprogram_Declaration (Spec : Iir)
+   is
+      Info              : constant Subprg_Info_Acc := Get_Info (Spec);
+      Is_Func           : constant Boolean :=
+        Get_Kind (Spec) = Iir_Kind_Function_Declaration;
+      Inter             : Iir;
+      Inter_Type        : Iir;
+      Arg_Info          : Ortho_Info_Acc;
+      Tinfo             : Type_Info_Acc;
+      Interface_List    : O_Inter_List;
+      Has_Result_Record : Boolean;
+      El_List           : O_Element_List;
+      Mark              : Id_Mark_Type;
+      Rtype             : Iir;
+      Id                : O_Ident;
+      Storage           : O_Storage;
+      Foreign           : Foreign_Info_Type := Foreign_Bad;
+   begin
+      --  Set the identifier prefix with the subprogram identifier and
+      --  overload number if any.
+      Push_Subprg_Identifier (Spec, Mark);
+
+      if Get_Foreign_Flag (Spec) then
+         --  Special handling for foreign subprograms.
+         Foreign := Translate_Foreign_Id (Spec);
+         case Foreign.Kind is
+            when Foreign_Unknown =>
+               Id := Create_Identifier;
+            when Foreign_Intrinsic =>
+               Id := Create_Identifier;
+            when Foreign_Vhpidirect =>
+               Id := Get_Identifier
+                 (Name_Table.Name_Buffer (Foreign.Subprg_First
+                  .. Foreign.Subprg_Last));
+         end case;
+         Storage := O_Storage_External;
+      else
+         Id := Create_Identifier;
+         Storage := Global_Storage;
+      end if;
+
+      if Is_Func then
+         --  If the result of a function is a composite type for ortho,
+         --  the result is allocated by the caller and an access to it is
+         --  given to the function.
+         Rtype := Get_Return_Type (Spec);
+         Info.Use_Stack2 := False;
+         Tinfo := Get_Info (Rtype);
+
+         if Is_Composite (Tinfo) then
+            Start_Procedure_Decl (Interface_List, Id, Storage);
+            New_Interface_Decl
+              (Interface_List, Info.Res_Interface,
+               Get_Identifier ("RESULT"),
+               Tinfo.Ortho_Ptr_Type (Mode_Value));
+            --  Furthermore, if the result type is unconstrained, the
+            --  function will allocate it on a secondary stack.
+            if not Is_Fully_Constrained_Type (Rtype) then
+               Info.Use_Stack2 := True;
+            end if;
+         else
+            --  Normal function.
+            Start_Function_Decl
+              (Interface_List, Id, Storage, Tinfo.Ortho_Type (Mode_Value));
+            Info.Res_Interface := O_Dnode_Null;
+         end if;
+      else
+         --  Create info for each interface of the procedure.
+         --  For parameters passed via copy and that needs a copy-out,
+         --  gather them in a record.  An access to the record is then
+         --  passed to the procedure.
+         Has_Result_Record := False;
+         Inter := Get_Interface_Declaration_Chain (Spec);
+         while Inter /= Null_Iir loop
+            Arg_Info := Add_Info (Inter, Kind_Interface);
+            Inter_Type := Get_Type (Inter);
+            Tinfo := Get_Info (Inter_Type);
+            if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration
+              and then Get_Mode (Inter) in Iir_Out_Modes
+              and then Tinfo.Type_Mode not in Type_Mode_By_Ref
+              and then Tinfo.Type_Mode /= Type_Mode_File
+            then
+               --  This interface is done via the result record.
+               --  Note: file passed through variables are vhdl87 files,
+               --        which are initialized at elaboration and thus
+               --        behave like an IN parameter.
+               if not Has_Result_Record then
+                  --  Create the record.
+                  Start_Record_Type (El_List);
+                  Has_Result_Record := True;
+               end if;
+               --  Add a field to the record.
+               New_Record_Field (El_List, Arg_Info.Interface_Field,
+                                 Create_Identifier_Without_Prefix (Inter),
+                                 Tinfo.Ortho_Type (Mode_Value));
+            else
+               Arg_Info.Interface_Field := O_Fnode_Null;
+            end if;
+            Inter := Get_Chain (Inter);
+         end loop;
+         if Has_Result_Record then
+            --  Declare the record type and an access to the record.
+            Finish_Record_Type (El_List, Info.Res_Record_Type);
+            New_Type_Decl (Create_Identifier ("RESTYPE"),
+                           Info.Res_Record_Type);
+            Info.Res_Record_Ptr := New_Access_Type (Info.Res_Record_Type);
+            New_Type_Decl (Create_Identifier ("RESPTR"),
+                           Info.Res_Record_Ptr);
+         else
+            Info.Res_Interface := O_Dnode_Null;
+         end if;
+
+         Start_Procedure_Decl (Interface_List, Id, Storage);
+
+         if Has_Result_Record then
+            --  Add the record parameter.
+            New_Interface_Decl (Interface_List, Info.Res_Interface,
+                                Get_Identifier ("RESULT"),
+                                Info.Res_Record_Ptr);
+         end if;
+      end if;
+
+      --  Instance parameter if any.
+      if not Get_Foreign_Flag (Spec) then
+         Subprgs.Create_Subprg_Instance (Interface_List, Spec);
+      end if;
+
+      --  Translate interfaces.
+      Inter := Get_Interface_Declaration_Chain (Spec);
+      while Inter /= Null_Iir loop
+         if Is_Func then
+            --  Create the info.
+            Arg_Info := Add_Info (Inter, Kind_Interface);
+            Arg_Info.Interface_Field := O_Fnode_Null;
+         else
+            --  The info was already created (just above)
+            Arg_Info := Get_Info (Inter);
+         end if;
+
+         if Arg_Info.Interface_Field = O_Fnode_Null then
+            --  Not via the RESULT parameter.
+            Arg_Info.Interface_Type := Translate_Interface_Type (Inter);
+            New_Interface_Decl
+              (Interface_List, Arg_Info.Interface_Node,
+               Create_Identifier_Without_Prefix (Inter),
+               Arg_Info.Interface_Type);
+         end if;
+         Inter := Get_Chain (Inter);
+      end loop;
+      Finish_Subprogram_Decl (Interface_List, Info.Ortho_Func);
+
+      --  Call the hook for foreign subprograms.
+      if Get_Foreign_Flag (Spec) and then Foreign_Hook /= null then
+         Foreign_Hook.all (Spec, Foreign, Info.Ortho_Func);
+      end if;
+
+      Save_Local_Identifier (Info.Subprg_Local_Id);
+      Pop_Identifier_Prefix (Mark);
+   end Translate_Subprogram_Declaration;
+
+   --  Return TRUE iff subprogram specification SPEC is translated in an
+   --  ortho function.
+   function Is_Subprogram_Ortho_Function (Spec : Iir) return Boolean
+   is
+   begin
+      if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then
+         return False;
+      end if;
+      if Get_Info (Spec).Res_Interface /= O_Dnode_Null then
+         return False;
+      end if;
+      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_Definition (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 : constant Iir := Get_Subprogram_Specification (Subprg);
+      Info : constant Ortho_Info_Acc := Get_Info (Spec);
+
+      Old_Subprogram : Iir;
+      Mark           : Id_Mark_Type;
+      Final          : Boolean;
+      Is_Ortho_Func  : Boolean;
+
+      --  Set for a public method.  In this case, the lock must be acquired
+      --  and retained.
+      Is_Prot : Boolean := False;
+
+      --  True if the body has local (nested) subprograms.
+      Has_Nested : Boolean;
+
+      Frame_Ptr_Type : O_Tnode;
+      Upframe_Field  : O_Fnode;
+
+      Frame     : O_Dnode;
+      Frame_Ptr : O_Dnode;
+
+      Has_Return : Boolean;
+
+      Prev_Subprg_Instances : Subprgs.Subprg_Instance_Stack;
+   begin
+      --  Do not translate body for foreign subprograms.
+      if Get_Foreign_Flag (Spec) then
+         return;
+      end if;
+
+      --  Check if there are nested subprograms to unnest.  In that case,
+      --  a frame record is created, which is less efficient than the
+      --  use of local variables.
+      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 (Info.Subprg_Frame_Scope'Access);
+         Add_Subprg_Instance_Field (Upframe_Field);
+
+         if Info.Res_Record_Ptr /= O_Tnode_Null then
+            Info.Res_Record_Var :=
+              Create_Var (Create_Var_Identifier ("RESULT"),
+                          Info.Res_Record_Ptr);
+         end if;
+
+         --  Create fields for parameters.
+         --  FIXME: do it only if they are referenced in nested
+         --  subprograms.
+         declare
+            Inter      : Iir;
+            Inter_Info : Inter_Info_Acc;
+         begin
+            Inter := Get_Interface_Declaration_Chain (Spec);
+            while Inter /= Null_Iir loop
+               Inter_Info := Get_Info (Inter);
+               if Inter_Info.Interface_Node /= O_Dnode_Null then
+                  Inter_Info.Interface_Field :=
+                    Add_Instance_Factory_Field
+                      (Create_Identifier_Without_Prefix (Inter),
+                       Inter_Info.Interface_Type);
+               end if;
+               Inter := Get_Chain (Inter);
+            end loop;
+         end;
+
+         Chap4.Translate_Declaration_Chain (Subprg);
+         Pop_Instance_Factory (Info.Subprg_Frame_Scope'Access);
+
+         New_Type_Decl (Create_Identifier ("_FRAMETYPE"),
+                        Get_Scope_Type (Info.Subprg_Frame_Scope));
+         Declare_Scope_Acc
+           (Info.Subprg_Frame_Scope,
+            Create_Identifier ("_FRAMEPTR"), Frame_Ptr_Type);
+
+         Rtis.Generate_Subprogram_Body (Subprg);
+
+         --  Local frame
+         Subprgs.Push_Subprg_Instance
+           (Info.Subprg_Frame_Scope'Access, Frame_Ptr_Type,
+            Wki_Upframe, Prev_Subprg_Instances);
+         --  Link to previous frame
+         Subprgs.Start_Prev_Subprg_Instance_Use_Via_Field
+           (Prev_Subprg_Instances, Upframe_Field);
+
+         Chap4.Translate_Declaration_Chain_Subprograms (Subprg);
+
+         --  Link to previous frame
+         Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field
+           (Prev_Subprg_Instances, Upframe_Field);
+         --  Local frame
+         Subprgs.Pop_Subprg_Instance (Wki_Upframe, Prev_Subprg_Instances);
+      end if;
+
+      --  Create the body
+
+      Start_Subprogram_Body (Info.Ortho_Func);
+
+      Start_Subprg_Instance_Use (Spec);
+
+      --  Variables will be created on the stack.
+      Push_Local_Factory;
+
+      --  Code has access to local (and outer) variables.
+      --  FIXME: this is not necessary if Has_Nested is set
+      Subprgs.Clear_Subprg_Instance (Prev_Subprg_Instances);
+
+      --  There is a local scope for temporaries.
+      Open_Local_Temp;
+
+      if not Has_Nested then
+         Chap4.Translate_Declaration_Chain (Subprg);
+         Rtis.Generate_Subprogram_Body (Subprg);
+         Chap4.Translate_Declaration_Chain_Subprograms (Subprg);
+      else
+         New_Var_Decl (Frame, Wki_Frame, O_Storage_Local,
+                       Get_Scope_Type (Info.Subprg_Frame_Scope));
+
+         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));
+
+         --  FIXME: use direct reference (ie Frame instead of Frame_Ptr)
+         Set_Scope_Via_Param_Ptr (Info.Subprg_Frame_Scope, Frame_Ptr);
+
+         --  Set UPFRAME.
+         Subprgs.Set_Subprg_Instance_Field
+           (Frame_Ptr, Upframe_Field, Info.Subprg_Instance);
+
+         if Info.Res_Record_Type /= O_Tnode_Null then
+            --  Initialize the RESULT field
+            New_Assign_Stmt (Get_Var (Info.Res_Record_Var),
+                             New_Obj_Value (Info.Res_Interface));
+            --  Do not reference the RESULT field in the subprogram body,
+            --  directly reference the RESULT parameter.
+            --  FIXME: has a flag (see below for parameters).
+            Info.Res_Record_Var := Null_Var;
+         end if;
+
+         --  Copy parameters to FRAME.
+         declare
+            Inter      : Iir;
+            Inter_Info : Inter_Info_Acc;
+         begin
+            Inter := Get_Interface_Declaration_Chain (Spec);
+            while Inter /= Null_Iir loop
+               Inter_Info := Get_Info (Inter);
+               if Inter_Info.Interface_Node /= O_Dnode_Null then
+                  New_Assign_Stmt
+                    (New_Selected_Element (New_Obj (Frame),
+                     Inter_Info.Interface_Field),
+                     New_Obj_Value (Inter_Info.Interface_Node));
+
+                  --  Forget the reference to the field in FRAME, so that
+                  --  this subprogram will directly reference the parameter
+                  --  (and not its copy in the FRAME).
+                  Inter_Info.Interface_Field := O_Fnode_Null;
+               end if;
+               Inter := Get_Chain (Inter);
+            end loop;
+         end;
+      end if;
+
+      --  Init out parameters passed by value/copy.
+      declare
+         Inter      : Iir;
+         Inter_Type : Iir;
+         Type_Info  : Type_Info_Acc;
+      begin
+         Inter := Get_Interface_Declaration_Chain (Spec);
+         while Inter /= Null_Iir loop
+            if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration
+              and then Get_Mode (Inter) = Iir_Out_Mode
+            then
+               Inter_Type := Get_Type (Inter);
+               Type_Info := Get_Info (Inter_Type);
+               if (Type_Info.Type_Mode in Type_Mode_By_Value
+                   or Type_Info.Type_Mode in Type_Mode_By_Copy)
+                 and then Type_Info.Type_Mode /= Type_Mode_File
+               then
+                  Chap4.Init_Object
+                    (Chap6.Translate_Name (Inter), Inter_Type);
+               end if;
+            end if;
+            Inter := Get_Chain (Inter);
+         end loop;
+      end;
+
+      Chap4.Elab_Declaration_Chain (Subprg, Final);
+
+      --  If finalization is required, create a dummy loop around the
+      --  body and convert returns into exit out of this loop.
+      --  If the subprogram is a function, also create a variable for the
+      --  result.
+      Is_Prot := Is_Subprogram_Method (Spec);
+      if Final or Is_Prot then
+         if Is_Prot then
+            --  Lock the object.
+            Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec),
+                                                 Ghdl_Protected_Enter);
+         end if;
+         Is_Ortho_Func := Is_Subprogram_Ortho_Function (Spec);
+         if Is_Ortho_Func then
+            New_Var_Decl
+              (Info.Subprg_Result, Get_Identifier ("RESULT"),
+               O_Storage_Local,
+               Get_Ortho_Type (Get_Return_Type (Spec), Mode_Value));
+         end if;
+         Start_Loop_Stmt (Info.Subprg_Exit);
+      end if;
+
+      Old_Subprogram := Current_Subprogram;
+      Current_Subprogram := Spec;
+      Has_Return := Chap8.Translate_Statements_Chain_Has_Return
+        (Get_Sequential_Statement_Chain (Subprg));
+      Current_Subprogram := Old_Subprogram;
+
+      if Final or Is_Prot then
+         --  Create a barrier to catch missing return statement.
+         if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then
+            New_Exit_Stmt (Info.Subprg_Exit);
+         else
+            if not Has_Return then
+               --  Missing return
+               Chap6.Gen_Program_Error
+                 (Subprg, Chap6.Prg_Err_Missing_Return);
+            end if;
+         end if;
+         Finish_Loop_Stmt (Info.Subprg_Exit);
+         Chap4.Final_Declaration_Chain (Subprg, False);
+
+         if Is_Prot then
+            --  Unlock the object.
+            Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec),
+                                                 Ghdl_Protected_Leave);
+         end if;
+         if Is_Ortho_Func then
+            New_Return_Stmt (New_Obj_Value (Info.Subprg_Result));
+         end if;
+      else
+         if Get_Kind (Spec) = Iir_Kind_Function_Declaration
+           and then not Has_Return
+         then
+            --  Missing return
+            Chap6.Gen_Program_Error
+              (Subprg, Chap6.Prg_Err_Missing_Return);
+         end if;
+      end if;
+
+      if Has_Nested then
+         Clear_Scope (Info.Subprg_Frame_Scope);
+      end if;
+
+      Subprgs.Pop_Subprg_Instance (O_Ident_Nul, Prev_Subprg_Instances);
+      Close_Local_Temp;
+      Pop_Local_Factory;
+
+      Finish_Subprg_Instance_Use (Spec);
+
+      Finish_Subprogram_Body;
+
+      Pop_Identifier_Prefix (Mark);
+   end Translate_Subprogram_Body;
+
+   procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration)
+   is
+      Header               : constant Iir := Get_Package_Header (Decl);
+      Info                 : Ortho_Info_Acc;
+      Interface_List       : O_Inter_List;
+      Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack;
+   begin
+      Info := Add_Info (Decl, Kind_Package);
+
+      --  Translate declarations.
+      if Is_Uninstantiated_Package (Decl) then
+         --  Create an instance for the spec.
+         Push_Instance_Factory (Info.Package_Spec_Scope'Access);
+         Chap4.Translate_Generic_Chain (Header);
+         Chap4.Translate_Declaration_Chain (Decl);
+         Info.Package_Elab_Var := Create_Var
+           (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type);
+         Pop_Instance_Factory (Info.Package_Spec_Scope'Access);
+
+         --  Name the spec instance and create a pointer.
+         New_Type_Decl (Create_Identifier ("SPECINSTTYPE"),
+                        Get_Scope_Type (Info.Package_Spec_Scope));
+         Declare_Scope_Acc (Info.Package_Spec_Scope,
+                            Create_Identifier ("SPECINSTPTR"),
+                            Info.Package_Spec_Ptr_Type);
+
+         --  Create an instance and its pointer for the body.
+         Chap2.Declare_Inst_Type_And_Ptr
+           (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type);
+
+         --  Each subprogram has a body instance argument.
+         Subprgs.Push_Subprg_Instance
+           (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type,
+            Wki_Instance, Prev_Subprg_Instance);
+      else
+         Chap4.Translate_Declaration_Chain (Decl);
+         Info.Package_Elab_Var := Create_Var
+           (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type);
+      end if;
+
+      --  Translate subprograms declarations.
+      Chap4.Translate_Declaration_Chain_Subprograms (Decl);
+
+      --  Declare elaborator for the body.
+      Start_Procedure_Decl
+        (Interface_List, Create_Identifier ("ELAB_BODY"), Global_Storage);
+      Subprgs.Add_Subprg_Instance_Interfaces
+        (Interface_List, Info.Package_Elab_Body_Instance);
+      Finish_Subprogram_Decl
+        (Interface_List, Info.Package_Elab_Body_Subprg);
+
+      if Is_Uninstantiated_Package (Decl) then
+         Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
+
+         --  The spec elaborator has a spec instance argument.
+         Subprgs.Push_Subprg_Instance
+           (Info.Package_Spec_Scope'Access, Info.Package_Spec_Ptr_Type,
+            Wki_Instance, Prev_Subprg_Instance);
+      end if;
+
+      Start_Procedure_Decl
+        (Interface_List, Create_Identifier ("ELAB_SPEC"), Global_Storage);
+      Subprgs.Add_Subprg_Instance_Interfaces
+        (Interface_List, Info.Package_Elab_Spec_Instance);
+      Finish_Subprogram_Decl
+        (Interface_List, Info.Package_Elab_Spec_Subprg);
+
+      if Flag_Rti then
+         --  Generate RTI.
+         Rtis.Generate_Unit (Decl);
+      end if;
+
+      if Global_Storage = O_Storage_Public then
+         --  Create elaboration procedure for the spec
+         Elab_Package (Decl);
+      end if;
+
+      if Is_Uninstantiated_Package (Decl) then
+         Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
+      end if;
+      Save_Local_Identifier (Info.Package_Local_Id);
+   end Translate_Package_Declaration;
+
+   procedure Translate_Package_Body (Decl : Iir_Package_Body)
+   is
+      Spec : constant Iir_Package_Declaration := Get_Package (Decl);
+      Info : constant Ortho_Info_Acc := Get_Info (Spec);
+      Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack;
+   begin
+      --  Translate declarations.
+      if Is_Uninstantiated_Package (Spec) then
+         Push_Instance_Factory (Info.Package_Body_Scope'Access);
+         Info.Package_Spec_Field := Add_Instance_Factory_Field
+           (Get_Identifier ("SPEC"),
+            Get_Scope_Type (Info.Package_Spec_Scope));
+
+         Chap4.Translate_Declaration_Chain (Decl);
+
+         Pop_Instance_Factory (Info.Package_Body_Scope'Access);
+
+         if Global_Storage = O_Storage_External then
+            return;
+         end if;
+      else
+         --  May be called during elaboration to generate RTI.
+         if Global_Storage = O_Storage_External then
+            return;
+         end if;
+
+         Restore_Local_Identifier (Get_Info (Spec).Package_Local_Id);
+
+         Chap4.Translate_Declaration_Chain (Decl);
+      end if;
+
+      if Flag_Rti then
+         Rtis.Generate_Unit (Decl);
+      end if;
+
+      if Is_Uninstantiated_Package (Spec) then
+         Subprgs.Push_Subprg_Instance
+           (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type,
+            Wki_Instance, Prev_Subprg_Instance);
+         Set_Scope_Via_Field (Info.Package_Spec_Scope,
+                              Info.Package_Spec_Field,
+                              Info.Package_Body_Scope'Access);
+      end if;
+
+      Chap4.Translate_Declaration_Chain_Subprograms (Decl);
+
+      if Is_Uninstantiated_Package (Spec) then
+         Clear_Scope (Info.Package_Spec_Scope);
+         Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
+      end if;
+
+      Elab_Package_Body (Spec, Decl);
+   end Translate_Package_Body;
+
+   procedure Elab_Package (Spec : Iir_Package_Declaration)
+   is
+      Info   : constant Ortho_Info_Acc := Get_Info (Spec);
+      Final  : Boolean;
+      Constr : O_Assoc_List;
+      pragma Unreferenced (Final);
+   begin
+      Start_Subprogram_Body (Info.Package_Elab_Spec_Subprg);
+      Push_Local_Factory;
+      Subprgs.Start_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance);
+
+      Elab_Dependence (Get_Design_Unit (Spec));
+
+      if not Is_Uninstantiated_Package (Spec)
+        and then Get_Kind (Get_Parent (Spec)) = Iir_Kind_Design_Unit
+      then
+         --  Register the top level package.  This is done dynamically, as
+         --  we know only during elaboration that the design depends on a
+         --  package (a package maybe referenced by an entity which is never
+         --  instantiated due to generate statements).
+         Start_Association (Constr, Ghdl_Rti_Add_Package);
+         New_Association
+           (Constr,
+            New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const)));
+         New_Procedure_Call (Constr);
+      end if;
+
+      Open_Temp;
+      Chap4.Elab_Declaration_Chain (Spec, Final);
+      Close_Temp;
+
+      Subprgs.Finish_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance);
+      Pop_Local_Factory;
+      Finish_Subprogram_Body;
+   end Elab_Package;
+
+   procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir)
+   is
+      Info   : constant Ortho_Info_Acc := Get_Info (Spec);
+      If_Blk : O_If_Block;
+      Constr : O_Assoc_List;
+      Final  : Boolean;
+   begin
+      Start_Subprogram_Body (Info.Package_Elab_Body_Subprg);
+      Push_Local_Factory;
+      Subprgs.Start_Subprg_Instance_Use (Info.Package_Elab_Body_Instance);
+
+      if Is_Uninstantiated_Package (Spec) then
+         Set_Scope_Via_Field (Info.Package_Spec_Scope,
+                              Info.Package_Spec_Field,
+                              Info.Package_Body_Scope'Access);
+      end if;
+
+      --  If the package was already elaborated, return now,
+      --  else mark the package as elaborated.
+      Start_If_Stmt (If_Blk, New_Value (Get_Var (Info.Package_Elab_Var)));
+      New_Return_Stmt;
+      New_Else_Stmt (If_Blk);
+      New_Assign_Stmt (Get_Var (Info.Package_Elab_Var),
+                       New_Lit (Ghdl_Bool_True_Node));
+      Finish_If_Stmt (If_Blk);
+
+      --  Elab Spec.
+      Start_Association (Constr, Info.Package_Elab_Spec_Subprg);
+      Add_Subprg_Instance_Assoc (Constr, Info.Package_Elab_Spec_Instance);
+      New_Procedure_Call (Constr);
+
+      if Bod /= Null_Iir then
+         Elab_Dependence (Get_Design_Unit (Bod));
+         Open_Temp;
+         Chap4.Elab_Declaration_Chain (Bod, Final);
+         Close_Temp;
+      end if;
+
+      if Is_Uninstantiated_Package (Spec) then
+         Clear_Scope (Info.Package_Spec_Scope);
+      end if;
+
+      Subprgs.Finish_Subprg_Instance_Use (Info.Package_Elab_Body_Instance);
+      Pop_Local_Factory;
+      Finish_Subprogram_Body;
+   end Elab_Package_Body;
+
+   procedure Instantiate_Iir_Info (N : Iir);
+
+   procedure Instantiate_Iir_Chain_Info (Chain : Iir)
+   is
+      N : Iir;
+   begin
+      N := Chain;
+      while N /= Null_Iir loop
+         Instantiate_Iir_Info (N);
+         N := Get_Chain (N);
+      end loop;
+   end Instantiate_Iir_Chain_Info;
+
+   procedure Instantiate_Iir_List_Info (L : Iir_List)
+   is
+      El : Iir;
+   begin
+      case L is
+         when Null_Iir_List
+            | Iir_List_All
+            | Iir_List_Others =>
+            return;
+         when others =>
+            for I in Natural loop
+               El := Get_Nth_Element (L, I);
+               exit when El = Null_Iir;
+               Instantiate_Iir_Info (El);
+            end loop;
+      end case;
+   end Instantiate_Iir_List_Info;
+
+   procedure Copy_Info (Dest : Ortho_Info_Acc; Src : Ortho_Info_Acc) is
+   begin
+      case Src.Kind is
+         when Kind_Type =>
+            Dest.all := (Kind => Kind_Type,
+                         Type_Mode => Src.Type_Mode,
+                         Type_Incomplete => Src.Type_Incomplete,
+                         Type_Locally_Constrained =>
+                            Src.Type_Locally_Constrained,
+                         C => null,
+                         Ortho_Type => Src.Ortho_Type,
+                         Ortho_Ptr_Type => Src.Ortho_Ptr_Type,
+                         Type_Transient_Chain => Null_Iir,
+                         T => Src.T,
+                         Type_Rti => Src.Type_Rti);
+            pragma Assert (Src.C = null);
+            pragma Assert (Src.Type_Transient_Chain = Null_Iir);
+         when Kind_Object =>
+            pragma Assert (Src.Object_Driver = Null_Var);
+            pragma Assert (Src.Object_Function = O_Dnode_Null);
+            Dest.all :=
+              (Kind => Kind_Object,
+               Object_Static => Src.Object_Static,
+               Object_Var => Instantiate_Var (Src.Object_Var),
+               Object_Driver => Null_Var,
+               Object_Rti => Src.Object_Rti,
+               Object_Function => O_Dnode_Null);
+         when Kind_Subprg =>
+            Dest.Subprg_Frame_Scope :=
+              Instantiate_Var_Scope (Src.Subprg_Frame_Scope);
+            Dest.all :=
+              (Kind => Kind_Subprg,
+               Use_Stack2 => Src.Use_Stack2,
+               Ortho_Func => Src.Ortho_Func,
+               Res_Interface => Src.Res_Interface,
+               Res_Record_Var => Instantiate_Var (Src.Res_Record_Var),
+               Res_Record_Type => Src.Res_Record_Type,
+               Res_Record_Ptr => Src.Res_Record_Ptr,
+               Subprg_Frame_Scope => Dest.Subprg_Frame_Scope,
+               Subprg_Instance => Instantiate_Subprg_Instance
+                 (Src.Subprg_Instance),
+               Subprg_Resolv => null,
+               Subprg_Local_Id => Src.Subprg_Local_Id,
+               Subprg_Exit => Src.Subprg_Exit,
+               Subprg_Result => Src.Subprg_Result);
+         when Kind_Interface =>
+            Dest.all := (Kind => Kind_Interface,
+                         Interface_Node => Src.Interface_Node,
+                         Interface_Field => Src.Interface_Field,
+                         Interface_Type => Src.Interface_Type);
+         when Kind_Index =>
+            Dest.all := (Kind => Kind_Index,
+                         Index_Field => Src.Index_Field);
+         when Kind_Expr =>
+            Dest.all := (Kind => Kind_Expr,
+                         Expr_Node => Src.Expr_Node);
+         when others =>
+            raise Internal_Error;
+      end case;
+   end Copy_Info;
+
+   procedure Instantiate_Iir_Info (N : Iir) is
+   begin
+      --  Nothing to do for null node.
+      if N = Null_Iir then
+         return;
+      end if;
+
+      declare
+         use Nodes_Meta;
+         Kind      : constant Iir_Kind := Get_Kind (N);
+         Fields    : constant Fields_Array := Get_Fields (Kind);
+         F         : Fields_Enum;
+         Orig      : constant Iir := Sem_Inst.Get_Origin (N);
+         pragma Assert (Orig /= Null_Iir);
+         Orig_Info : constant Ortho_Info_Acc := Get_Info (Orig);
+         Info      : Ortho_Info_Acc;
+      begin
+         if Orig_Info /= null then
+            Info := Add_Info (N, Orig_Info.Kind);
+
+            Copy_Info (Info, Orig_Info);
+
+            case Info.Kind is
+               when Kind_Subprg =>
+                  Push_Instantiate_Var_Scope
+                    (Info.Subprg_Frame_Scope'Access,
+                     Orig_Info.Subprg_Frame_Scope'Access);
+               when others =>
+                  null;
+            end case;
+         end if;
+
+         for I in Fields'Range loop
+            F := Fields (I);
+            case Get_Field_Type (F) is
+               when Type_Iir =>
+                  case Get_Field_Attribute (F) is
+                     when Attr_None =>
+                        Instantiate_Iir_Info (Get_Iir (N, F));
+                     when Attr_Ref =>
+                        null;
+                     when Attr_Maybe_Ref =>
+                        if not Get_Is_Ref (N) then
+                           Instantiate_Iir_Info (Get_Iir (N, F));
+                        end if;
+                     when Attr_Chain =>
+                        Instantiate_Iir_Chain_Info (Get_Iir (N, F));
+                     when Attr_Chain_Next =>
+                        null;
+                     when Attr_Of_Ref =>
+                        raise Internal_Error;
+                  end case;
+               when Type_Iir_List =>
+                  case Get_Field_Attribute (F) is
+                     when Attr_None =>
+                        Instantiate_Iir_List_Info (Get_Iir_List (N, F));
+                     when Attr_Ref
+                        | Attr_Of_Ref =>
+                        null;
+                     when others =>
+                        raise Internal_Error;
+                  end case;
+               when Type_PSL_NFA
+                  | Type_PSL_Node =>
+                  --  TODO
+                  raise Internal_Error;
+               when Type_Date_Type
+                  | Type_Date_State_Type
+                  | Type_Time_Stamp_Id =>
+                  --  Can this happen ?
+                  raise Internal_Error;
+               when Type_String_Id
+                  | Type_Source_Ptr
+                  | Type_Base_Type
+                  | Type_Iir_Constraint
+                  | Type_Iir_Mode
+                  | Type_Iir_Index32
+                  | Type_Iir_Int64
+                  | Type_Boolean
+                  | Type_Iir_Staticness
+                  | Type_Iir_All_Sensitized
+                  | Type_Iir_Signal_Kind
+                  | Type_Tri_State_Type
+                  | Type_Iir_Pure_State
+                  | Type_Iir_Delay_Mechanism
+                  | Type_Iir_Lexical_Layout_Type
+                  | Type_Iir_Predefined_Functions
+                  | Type_Iir_Direction
+                  | Type_Location_Type
+                  | Type_Iir_Int32
+                  | Type_Int32
+                  | Type_Iir_Fp64
+                  | Type_Token_Type
+                  | Type_Name_Id =>
+                  null;
+            end case;
+         end loop;
+
+         if Info /= null then
+            case Info.Kind is
+               when Kind_Subprg =>
+                  Pop_Instantiate_Var_Scope
+                    (Info.Subprg_Frame_Scope'Access);
+               when others =>
+                  null;
+            end case;
+         end if;
+      end;
+   end Instantiate_Iir_Info;
+
+   procedure Instantiate_Iir_Generic_Chain_Info (Chain : Iir)
+   is
+      Inter     : Iir;
+      Orig      : Iir;
+      Orig_Info : Ortho_Info_Acc;
+      Info      : Ortho_Info_Acc;
+   begin
+      Inter := Chain;
+      while Inter /= Null_Iir loop
+         case Get_Kind (Inter) is
+            when Iir_Kind_Interface_Constant_Declaration =>
+               Orig := Sem_Inst.Get_Origin (Inter);
+               Orig_Info := Get_Info (Orig);
+
+               Info := Add_Info (Inter, Orig_Info.Kind);
+               Copy_Info (Info, Orig_Info);
+
+            when Iir_Kind_Interface_Package_Declaration =>
+               null;
+
+            when others =>
+               raise Internal_Error;
+         end case;
+
+         Inter := Get_Chain (Inter);
+      end loop;
+   end Instantiate_Iir_Generic_Chain_Info;
+
+   --  Add info for an interface_package_declaration or a
+   --  package_instantiation_declaration
+   procedure Instantiate_Info_Package (Inst : Iir)
+   is
+      Spec     : constant Iir :=
+        Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst));
+      Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec);
+      Info     : Ortho_Info_Acc;
+   begin
+      Info := Add_Info (Inst, Kind_Package_Instance);
+
+      --  Create the info instances.
+      Push_Instantiate_Var_Scope
+        (Info.Package_Instance_Spec_Scope'Access,
+         Pkg_Info.Package_Spec_Scope'Access);
+      Push_Instantiate_Var_Scope
+        (Info.Package_Instance_Body_Scope'Access,
+         Pkg_Info.Package_Body_Scope'Access);
+      Instantiate_Iir_Generic_Chain_Info (Get_Generic_Chain (Inst));
+      Instantiate_Iir_Chain_Info (Get_Declaration_Chain (Inst));
+      Pop_Instantiate_Var_Scope
+        (Info.Package_Instance_Body_Scope'Access);
+      Pop_Instantiate_Var_Scope
+        (Info.Package_Instance_Spec_Scope'Access);
+   end Instantiate_Info_Package;
+
+   procedure Translate_Package_Instantiation_Declaration (Inst : Iir)
+   is
+      Spec           : constant Iir :=
+        Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst));
+      Pkg_Info       : constant Ortho_Info_Acc := Get_Info (Spec);
+      Info           : Ortho_Info_Acc;
+      Interface_List : O_Inter_List;
+      Constr         : O_Assoc_List;
+   begin
+      Instantiate_Info_Package (Inst);
+      Info := Get_Info (Inst);
+
+      --  FIXME: if the instantiation occurs within a package declaration,
+      --  the variable must be declared extern (and public in the body).
+      Info.Package_Instance_Body_Var := Create_Var
+        (Create_Var_Identifier (Inst),
+         Get_Scope_Type (Pkg_Info.Package_Body_Scope));
+
+      --  FIXME: this is correct only for global instantiation, and only if
+      --  there is only one.
+      Set_Scope_Via_Decl (Info.Package_Instance_Body_Scope,
+                          Get_Var_Label (Info.Package_Instance_Body_Var));
+      Set_Scope_Via_Field (Info.Package_Instance_Spec_Scope,
+                           Pkg_Info.Package_Spec_Field,
+                           Info.Package_Instance_Body_Scope'Access);
+
+      --  Declare elaboration procedure
+      Start_Procedure_Decl
+        (Interface_List, Create_Identifier ("ELAB"), Global_Storage);
+      --  Chap2.Add_Subprg_Instance_Interfaces
+      --   (Interface_List, Info.Package_Instance_Elab_Instance);
+      Finish_Subprogram_Decl
+        (Interface_List, Info.Package_Instance_Elab_Subprg);
+
+      if Global_Storage /= O_Storage_Public then
+         return;
+      end if;
+
+      --  Elaborator:
+      Start_Subprogram_Body (Info.Package_Instance_Elab_Subprg);
+      --  Chap2.Start_Subprg_Instance_Use
+      --    (Info.Package_Instance_Elab_Instance);
+
+      Elab_Dependence (Get_Design_Unit (Inst));
+
+      Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope,
+                          Get_Var_Label (Info.Package_Instance_Body_Var));
+      Set_Scope_Via_Field (Pkg_Info.Package_Spec_Scope,
+                           Pkg_Info.Package_Spec_Field,
+                           Pkg_Info.Package_Body_Scope'Access);
+      Chap5.Elab_Generic_Map_Aspect (Inst);
+      Clear_Scope (Pkg_Info.Package_Spec_Scope);
+      Clear_Scope (Pkg_Info.Package_Body_Scope);
+
+      --  Call the elaborator of the generic.  The generic must be
+      --  temporary associated with the instance variable.
+      Start_Association (Constr, Pkg_Info.Package_Elab_Body_Subprg);
+      Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope,
+                          Get_Var_Label (Info.Package_Instance_Body_Var));
+      Add_Subprg_Instance_Assoc
+        (Constr, Pkg_Info.Package_Elab_Body_Instance);
+      Clear_Scope (Pkg_Info.Package_Body_Scope);
+      New_Procedure_Call (Constr);
+
+      --  Chap2.Finish_Subprg_Instance_Use
+      --    (Info.Package_Instance_Elab_Instance);
+      Finish_Subprogram_Body;
+   end Translate_Package_Instantiation_Declaration;
+
+   procedure Elab_Dependence_Package (Pkg : Iir_Package_Declaration)
+   is
+      Info   : Ortho_Info_Acc;
+      If_Blk : O_If_Block;
+      Constr : O_Assoc_List;
+   begin
+      --  Std.Standard is pre-elaborated.
+      if Pkg = Standard_Package then
+         return;
+      end if;
+
+      --  Nothing to do for uninstantiated package.
+      if Is_Uninstantiated_Package (Pkg) then
+         return;
+      end if;
+
+      --  Call the package elaborator only if not already elaborated.
+      Info := Get_Info (Pkg);
+      Start_If_Stmt
+        (If_Blk,
+         New_Monadic_Op (ON_Not,
+           New_Value (Get_Var (Info.Package_Elab_Var))));
+      -- Elaborates only non-elaborated packages.
+      Start_Association (Constr, Info.Package_Elab_Body_Subprg);
+      New_Procedure_Call (Constr);
+      Finish_If_Stmt (If_Blk);
+   end Elab_Dependence_Package;
+
+   procedure Elab_Dependence_Package_Instantiation (Pkg : Iir)
+   is
+      Info   : constant Ortho_Info_Acc := Get_Info (Pkg);
+      Constr : O_Assoc_List;
+   begin
+      Start_Association (Constr, Info.Package_Instance_Elab_Subprg);
+      New_Procedure_Call (Constr);
+   end Elab_Dependence_Package_Instantiation;
+
+   procedure Elab_Dependence (Design_Unit: Iir_Design_Unit)
+   is
+      Depend_List : Iir_Design_Unit_List;
+      Design      : Iir;
+      Library_Unit: Iir;
+   begin
+      Depend_List := Get_Dependence_List (Design_Unit);
+
+      for I in Natural loop
+         Design := Get_Nth_Element (Depend_List, I);
+         exit when Design = Null_Iir;
+         if Get_Kind (Design) = Iir_Kind_Design_Unit then
+            Library_Unit := Get_Library_Unit (Design);
+            case Get_Kind (Library_Unit) is
+               when Iir_Kind_Package_Declaration =>
+                  Elab_Dependence_Package (Library_Unit);
+               when Iir_Kind_Package_Instantiation_Declaration =>
+                  Elab_Dependence_Package_Instantiation (Library_Unit);
+               when Iir_Kind_Entity_Declaration =>
+                  --  FIXME: architecture already elaborates its entity.
+                  null;
+               when Iir_Kind_Configuration_Declaration =>
+                  null;
+               when Iir_Kind_Architecture_Body =>
+                  null;
+               when Iir_Kind_Package_Body =>
+                  --  A package instantiation depends on the body.
+                  null;
+               when others =>
+                  Error_Kind ("elab_dependence", Library_Unit);
+            end case;
+         end if;
+      end loop;
+   end Elab_Dependence;
+
+   procedure Declare_Inst_Type_And_Ptr (Scope    : Var_Scope_Acc;
+                                        Ptr_Type : out O_Tnode) is
+   begin
+      Predeclare_Scope_Type (Scope, Create_Identifier ("INSTTYPE"));
+      Declare_Scope_Acc
+        (Scope.all, Create_Identifier ("INSTPTR"), Ptr_Type);
+   end Declare_Inst_Type_And_Ptr;
+
+end Trans.Chap2;
author	Tristan Gingold <tgingold@free.fr>	2014-11-09 18:31:54 +0100
committer	Tristan Gingold <tgingold@free.fr>	2014-11-09 18:31:54 +0100
commit	fe94cb3cc3fd4517271faa9046c74b0c455aeb79 (patch)
tree	17ba28586cb5eb22d530c568d917931f309d871f /src/vhdl/translate/trans-chap2.adb
parent	3c9a77e9e6f3b8047080f7d8c11bb9881cabf968 (diff)
download	ghdl-fe94cb3cc3fd4517271faa9046c74b0c455aeb79.tar.gz ghdl-fe94cb3cc3fd4517271faa9046c74b0c455aeb79.tar.bz2 ghdl-fe94cb3cc3fd4517271faa9046c74b0c455aeb79.zip