mcode code generator added

1 files changed, 1344 insertions, 0 deletions

diff --git a/ortho/mcode/ortho_code-dwarf.adb b/ortho/mcode/ortho_code-dwarf.adb
new file mode 100644
index 0000000..6f807d0
--- /dev/null
+++ b/ortho/mcode/ortho_code-dwarf.adb
@@ -0,0 +1,1344 @@
+--  Mcode back-end for ortho - Dwarf generator.
+--  Copyright (C) 2006 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 GNAT.Directory_Operations;
+with GNAT.Table;
+with Interfaces; use Interfaces;
+with Binary_File; use Binary_File;
+with Dwarf; use Dwarf;
+with Ada.Text_IO;
+with Ortho_Code.Decls;
+with Ortho_Code.Types;
+with Ortho_Code.Consts;
+with Ortho_Code.Flags;
+with Ortho_Ident;
+with Ortho_Code.Binary;
+with Binary_File; use Binary_File;
+
+package body Ortho_Code.Dwarf is
+   --  Dwarf debugging format.
+   --  Debugging.
+   Line1_Sect : Section_Acc := null;
+   Line_Last : Int32 := 0;
+   Line_Pc : Pc_Type := 0;
+
+   --  Constant.
+   Min_Insn_Len : constant := 1;
+   Line_Base : constant := 1;
+   Line_Range : constant := 4;
+   Line_Opcode_Base : constant := 13;
+   Line_Max_Addr : constant := (255 - Line_Opcode_Base) / Line_Range;
+   -- + Line_Base;
+
+   Cur_File : Natural := 0;
+   Last_File : Natural := 0;
+
+   Orig_Sym : Symbol;
+   End_Sym : Symbol;
+   Abbrev_Sym : Symbol;
+   Info_Sym : Symbol;
+   Line_Sym : Symbol;
+
+   Line_Sect : Section_Acc;
+   Abbrev_Sect : Section_Acc;
+   Info_Sect : Section_Acc;
+   Aranges_Sect : Section_Acc;
+
+   Abbrev_Last : Unsigned_32;
+
+--     procedure Gen_String (Str : String)
+--     is
+--     begin
+--        for I in Str'Range loop
+--           Gen_B8 (Character'Pos (Str (I)));
+--        end loop;
+--     end Gen_String;
+
+   procedure Gen_String_Nul (Str : String)
+   is
+   begin
+      Prealloc (Str'Length + 1);
+      for I in Str'Range loop
+         Gen_B8 (Character'Pos (Str (I)));
+      end loop;
+      Gen_B8 (0);
+   end Gen_String_Nul;
+
+   procedure Gen_Sleb128 (V : Int32)
+   is
+      V1 : Uns32 := To_Uns32 (V);
+      V2 : Uns32;
+      B : Byte;
+      function Shift_Right_Arithmetic (Value : Uns32; Amount : Natural)
+                                      return Uns32;
+      pragma Import (Intrinsic, Shift_Right_Arithmetic);
+   begin
+      loop
+         B := Byte (V1 and 16#7F#);
+         V2 := Shift_Right_Arithmetic (V1, 7);
+         if (V2 = 0 and (B and 16#40#) = 0)
+           or (V2 = -1 and (B and 16#40#) /= 0)
+         then
+            Gen_B8 (B);
+            exit;
+         else
+            Gen_B8 (B or 16#80#);
+            V1 := V2;
+         end if;
+      end loop;
+   end Gen_Sleb128;
+
+   procedure Gen_Uleb128 (V : Unsigned_32)
+   is
+      V1 : Unsigned_32 := V;
+      B : Byte;
+   begin
+      loop
+         B := Byte (V1 and 16#7f#);
+         V1 := Shift_Right (V1, 7);
+         if V1 /= 0 then
+            Gen_B8 (B or 16#80#);
+         else
+            Gen_B8 (B);
+            exit;
+         end if;
+      end loop;
+   end Gen_Uleb128;
+
+--     procedure New_Debug_Line_Decl (Line : Int32)
+--     is
+--     begin
+--        Line_Last := Line;
+--     end New_Debug_Line_Decl;
+
+   procedure Set_Line_Stmt (Line : Int32)
+   is
+      Pc : Pc_Type;
+      D_Pc : Pc_Type;
+      D_Ln : Int32;
+   begin
+      if Line = Line_Last then
+         return;
+      end if;
+      Pc := Get_Current_Pc;
+
+      D_Pc := (Pc - Line_Pc) / Min_Insn_Len;
+      D_Ln := Line - Line_Last;
+
+      --  Always emit line information, since missing info can distrub the
+      --  user.
+      --  As an optimization, we could try to emit the highest line for the
+      --  same PC, since GDB seems to handle this way.
+      if False and D_Pc = 0 then
+         return;
+      end if;
+
+      Set_Current_Section (Line1_Sect);
+      Prealloc (32);
+
+      if Cur_File /= Last_File then
+         Gen_B8 (Byte (DW_LNS_Set_File));
+         Gen_Uleb128 (Unsigned_32 (Cur_File));
+         Last_File := Cur_File;
+      elsif Cur_File = 0 then
+         return;
+      end if;
+
+      if D_Ln < Line_Base or D_Ln >= (Line_Base + Line_Range) then
+         --  Emit an advance line.
+         Gen_B8 (Byte (DW_LNS_Advance_Line));
+         Gen_Sleb128 (Int32 (D_Ln - Line_Base));
+         D_Ln := Line_Base;
+      end if;
+      if D_Pc >= Line_Max_Addr then
+         --  Emit an advance addr.
+         Gen_B8 (Byte (DW_LNS_Advance_Pc));
+         Gen_Uleb128 (Unsigned_32 (D_Pc));
+         D_Pc := 0;
+      end if;
+      Gen_B8 (Line_Opcode_Base
+              + Byte (D_Pc) * Line_Range
+              + Byte (D_Ln - Line_Base));
+
+      --Set_Current_Section (Text_Sect);
+      Line_Pc := Pc;
+      Line_Last := Line;
+   end Set_Line_Stmt;
+
+
+   type String_Acc is access constant String;
+
+   type Dir_Chain;
+   type Dir_Chain_Acc is access Dir_Chain;
+   type Dir_Chain is record
+      Name : String_Acc;
+      Next : Dir_Chain_Acc;
+   end record;
+
+   type File_Chain;
+   type File_Chain_Acc is access File_Chain;
+   type File_Chain is record
+      Name : String_Acc;
+      Dir : Natural;
+      Next : File_Chain_Acc;
+   end record;
+
+   Dirs : Dir_Chain_Acc := null;
+   Files : File_Chain_Acc := null;
+
+   procedure Set_Filename (Dir : String; File : String)
+   is
+      D : Natural;
+      F : Natural;
+      D_C : Dir_Chain_Acc;
+      F_C : File_Chain_Acc;
+   begin
+      --  Find directory.
+      if Dir = "" then
+         --  Current directory.
+         D := 0;
+      elsif Dirs = null then
+         --  First directory.
+         Dirs := new Dir_Chain'(Name => new String'(Dir),
+                                Next => null);
+         D := 1;
+      else
+         --  Find a directory.
+         D_C := Dirs;
+         D := 1;
+         loop
+            exit when D_C.Name.all = Dir;
+            D := D + 1;
+            if D_C.Next = null then
+               D_C.Next := new Dir_Chain'(Name => new String'(Dir),
+                                          Next => null);
+               exit;
+            else
+               D_C := D_C.Next;
+            end if;
+         end loop;
+      end if;
+
+      --  Find file.
+      F := 1;
+      if Files = null then
+         --  first file.
+         Files := new File_Chain'(Name => new String'(File),
+                                  Dir => D,
+                                  Next => null);
+      else
+         F_C := Files;
+         loop
+            exit when F_C.Name.all = File and F_C.Dir = D;
+            F := F + 1;
+            if F_C.Next = null then
+               F_C.Next := new File_Chain'(Name => new String'(File),
+                                           Dir => D,
+                                           Next => null);
+               exit;
+            else
+               F_C := F_C.Next;
+            end if;
+         end loop;
+      end if;
+      Cur_File := F;
+   end Set_Filename;
+
+   procedure Gen_Abbrev_Header (Tag : Unsigned_32; Child : Byte) is
+   begin
+      Gen_Uleb128 (Tag);
+      Gen_B8 (Child);
+   end Gen_Abbrev_Header;
+
+   procedure Gen_Abbrev_Tuple (Attr : Unsigned_32; Form : Unsigned_32) is
+   begin
+      Gen_Uleb128 (Attr);
+      Gen_Uleb128 (Form);
+   end Gen_Abbrev_Tuple;
+
+   procedure Init
+   is
+   begin
+      --  Generate type names.
+      Flags.Flag_Type_Name := True;
+
+
+      Orig_Sym := Create_Local_Symbol;
+      Set_Symbol_Pc (Orig_Sym, False);
+      End_Sym := Create_Local_Symbol;
+
+      Create_Section (Line1_Sect, ".debug_line-1", Section_None);
+      Set_Current_Section (Line1_Sect);
+
+      --  Write Address.
+      Gen_B8 (0); -- extended opcode
+      Gen_B8 (5); -- length: 1 + 4
+      Gen_B8 (Byte (DW_LNE_Set_Address));
+      Gen_Ua_32 (Orig_Sym, 0);
+
+      Line_Last := 1;
+
+      Create_Section (Line_Sect, ".debug_line", Section_None);
+      Set_Section_Info (Line_Sect, null, 0, 0);
+      Set_Current_Section (Line_Sect);
+      Line_Sym := Create_Local_Symbol;
+      Set_Symbol_Pc (Line_Sym, False);
+
+      --  Abbrevs.
+      Create_Section (Abbrev_Sect, ".debug_abbrev", Section_None);
+      Set_Section_Info (Abbrev_Sect, null, 0, 0);
+      Set_Current_Section (Abbrev_Sect);
+
+      Abbrev_Sym := Create_Local_Symbol;
+      Set_Symbol_Pc (Abbrev_Sym, False);
+
+      Gen_Uleb128 (1);
+      Gen_Abbrev_Header (DW_TAG_Compile_Unit, DW_CHILDREN_Yes);
+
+      Gen_Abbrev_Tuple (DW_AT_Stmt_List, DW_FORM_Data4);
+      Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr);
+      Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr);
+      Gen_Abbrev_Tuple (DW_AT_Producer, DW_FORM_String);
+      Gen_Abbrev_Tuple (DW_AT_Comp_Dir, DW_FORM_String);
+      Gen_Abbrev_Tuple (0, 0);
+
+      Abbrev_Last := 1;
+
+      --  Info.
+      Create_Section (Info_Sect, ".debug_info", Section_None);
+      Set_Section_Info (Info_Sect, null, 0, 0);
+      Set_Current_Section (Info_Sect);
+      Info_Sym := Create_Local_Symbol;
+      Set_Symbol_Pc (Info_Sym, False);
+
+      Gen_32 (7);  --  Length: to be patched.
+      Gen_16 (2);  --  version
+      Gen_Ua_32 (Abbrev_Sym, 0); --  Abbrev offset
+      Gen_B8 (4);  --  Ptr size.
+
+      --  Compile_unit.
+      Gen_Uleb128 (1);
+      Gen_Ua_32 (Line_Sym, 0);
+      Gen_Ua_32 (Orig_Sym, 0);
+      Gen_Ua_32 (End_Sym, 0);
+      Gen_String_Nul ("T.Gingold ortho_mcode (2004)");
+      declare
+         Dir : String := GNAT.Directory_Operations.Get_Current_Dir;
+      begin
+         Gen_String_Nul (Dir);
+      end;
+   end Init;
+
+   procedure Emit_Decl (Decl : O_Dnode);
+
+   Last_Decl : O_Dnode := O_Dnode_First;
+
+   procedure Emit_Decls_Until (Last : O_Dnode)
+   is
+      use Ortho_Code.Decls;
+   begin
+      while Last_Decl <= Last loop
+         Emit_Decl (Last_Decl);
+         Last_Decl := Get_Decl_Chain (Last_Decl);
+      end loop;
+   end Emit_Decls_Until;
+
+   procedure Finish
+   is
+      Length : Pc_Type;
+   begin
+      Set_Symbol_Pc (End_Sym, False);
+      Length := Get_Current_Pc;
+
+      Emit_Decls_Until (Decls.Get_Decl_Last);
+
+      --  Finish abbrevs.
+      Set_Current_Section (Abbrev_Sect);
+      Gen_Uleb128 (0);
+
+      --  Emit header.
+      Set_Current_Section (Line_Sect);
+
+      --  Unit_Length (to be patched).
+      Gen_32 (0);
+      --  version
+      Gen_16 (2);
+      --  header_length (to be patched).
+      Gen_32 (5 + 12 + 1);
+      --  minimum_instruction_length.
+      Gen_B8 (Min_Insn_Len);
+      --  default_is_stmt
+      Gen_B8 (1);
+      --  line base
+      Gen_B8 (Line_Base);
+      --  line range
+      Gen_B8 (Line_Range);
+      --  opcode base
+      Gen_B8 (Line_Opcode_Base);
+      --  standard_opcode_length.
+      Gen_B8 (0); --  copy
+      Gen_B8 (1); --  advance pc
+      Gen_B8 (1); --  advance line
+      Gen_B8 (1); --  set file
+      Gen_B8 (1); --  set column
+      Gen_B8 (0); --  negate stmt
+      Gen_B8 (0); --  set basic block
+      Gen_B8 (0); --  const add pc
+      Gen_B8 (1); --  fixed advance pc
+      Gen_B8 (0); --  set prologue end
+      Gen_B8 (0); --  set epilogue begin
+      Gen_B8 (1); --  set isa
+      --if Line_Opcode_Base /= 13 then
+      --   raise Program_Error;
+      --end if;
+
+      --  include directories
+      declare
+         D : Dir_Chain_Acc;
+      begin
+         D := Dirs;
+         while D /= null loop
+            Gen_String_Nul (D.Name.all);
+            D := D.Next;
+         end loop;
+         Gen_B8 (0); -- last entry.
+      end;
+
+      --  file_names.
+      declare
+         F : File_Chain_Acc;
+      begin
+         F := Files;
+         while F /= null loop
+            Gen_String_Nul (F.Name.all);
+            Gen_Uleb128 (Unsigned_32 (F.Dir));
+            Gen_B8 (0);  --  time
+            Gen_B8 (0);  --  length
+            F := F.Next;
+         end loop;
+         Gen_B8 (0);  --  last entry.
+      end;
+
+      --  Set prolog length
+      Patch_32 (6, Unsigned_32 (Get_Current_Pc - 6));
+
+      Merge_Section (Line_Sect, Line1_Sect);
+
+      --  Emit end of sequence.
+      Gen_B8 (0); -- extended opcode
+      Gen_B8 (1); -- length: 1
+      Gen_B8 (Byte (DW_LNE_End_Sequence));
+
+      --  Set total length.
+      Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4));
+
+      --  Info.
+      Set_Current_Section (Info_Sect);
+      --  Finish child.
+      Gen_Uleb128 (0);
+      --  Set total length.
+      Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4));
+
+      --  Aranges
+      Create_Section (Aranges_Sect, ".debug_aranges", Section_None);
+      Set_Section_Info (Aranges_Sect, null, 0, 0);
+      Set_Current_Section (Aranges_Sect);
+
+      Gen_32 (28);  --  Length.
+      Gen_16 (2);  --  version
+      Gen_Ua_32 (Info_Sym, 0); --  info offset
+      Gen_B8 (4);  --  Ptr size.
+      Gen_B8 (0);  --  seg desc size.
+      Gen_32 (0);  --  pad
+      Gen_Ua_32 (Orig_Sym, 0); --  text offset
+      Gen_32 (Unsigned_32 (Length));
+      Gen_32 (0); --  End
+      Gen_32 (0);
+   end Finish;
+
+   procedure Generate_Abbrev (Abbrev : out Unsigned_32) is
+   begin
+      Abbrev_Last := Abbrev_Last + 1;
+      Abbrev := Abbrev_Last;
+
+      Set_Current_Section (Abbrev_Sect);
+      --  FIXME: should be enough ?
+      Prealloc (128);
+      Gen_Uleb128 (Abbrev);
+   end Generate_Abbrev;
+
+   procedure Gen_Info_Header (Abbrev : Unsigned_32) is
+   begin
+      Set_Current_Section (Info_Sect);
+      Gen_Uleb128 (Abbrev);
+   end Gen_Info_Header;
+
+   function Gen_Info_Sibling return Pc_Type
+   is
+      Pc : Pc_Type;
+   begin
+      Pc := Get_Current_Pc;
+      Gen_32 (0);
+      return Pc;
+   end Gen_Info_Sibling;
+
+   procedure Patch_Info_Sibling (Pc : Pc_Type) is
+   begin
+      Patch_32 (Pc, Unsigned_32 (Get_Current_Pc));
+   end Patch_Info_Sibling;
+
+   Abbrev_Base_Type : Unsigned_32 := 0;
+   Abbrev_Base_Type_Name : Unsigned_32 := 0;
+   Abbrev_Pointer : Unsigned_32 := 0;
+   Abbrev_Pointer_Name : Unsigned_32 := 0;
+   Abbrev_Uncomplete_Pointer : Unsigned_32 := 0;
+   Abbrev_Uncomplete_Pointer_Name : Unsigned_32 := 0;
+   Abbrev_Ucarray : Unsigned_32 := 0;
+   Abbrev_Ucarray_Name : Unsigned_32 := 0;
+   Abbrev_Uc_Subrange : Unsigned_32 := 0;
+   Abbrev_Subarray : Unsigned_32 := 0;
+   Abbrev_Subarray_Name : Unsigned_32 := 0;
+   Abbrev_Subrange : Unsigned_32 := 0;
+   Abbrev_Struct : Unsigned_32 := 0;
+   Abbrev_Struct_Name : Unsigned_32 := 0;
+   Abbrev_Union : Unsigned_32 := 0;
+   Abbrev_Union_Name : Unsigned_32 := 0;
+   Abbrev_Member : Unsigned_32 := 0;
+   Abbrev_Enum : Unsigned_32 := 0;
+   Abbrev_Enum_Name : Unsigned_32 := 0;
+   Abbrev_Enumerator : Unsigned_32 := 0;
+
+   package TOnodes is new GNAT.Table
+     (Table_Component_Type => Pc_Type,
+      Table_Index_Type => O_Tnode,
+      Table_Low_Bound => O_Tnode_First,
+      Table_Initial => 16,
+      Table_Increment => 100);
+
+   procedure Emit_Type_Ref (Atype : O_Tnode)
+   is
+      Off : Pc_Type;
+   begin
+      Off := TOnodes.Table (Atype);
+      if Off = Null_Pc then
+         raise Program_Error;
+      end if;
+      Gen_32 (Unsigned_32 (Off));
+   end Emit_Type_Ref;
+
+   procedure Emit_Ident (Id : O_Ident)
+   is
+      use Ortho_Ident;
+      L : Natural;
+   begin
+      L := Get_String_Length (Id);
+      Prealloc (Pc_Type (L) + 128);
+      Gen_String_Nul (Get_String (Id));
+   end Emit_Ident;
+
+   procedure Add_Type_Ref (Atype : O_Tnode; Pc : Pc_Type)
+   is
+      Prev : O_Tnode;
+   begin
+      if Atype > TOnodes.Last then
+         --  Expand.
+         Prev := TOnodes.Last;
+         TOnodes.Set_Last (Atype);
+         TOnodes.Table (Prev + 1 .. Atype - 1) := (others => Null_Pc);
+      end if;
+      TOnodes.Table (Atype) := Pc;
+   end Add_Type_Ref;
+
+   procedure Emit_Decl_Ident (Decl : O_Dnode)
+   is
+      use Ortho_Code.Decls;
+   begin
+      Emit_Ident (Get_Decl_Ident (Decl));
+   end Emit_Decl_Ident;
+
+   procedure Emit_Decl_Ident_If_Set (Decl : O_Dnode)
+   is
+      use Ortho_Code.Decls;
+   begin
+      if Decl /= O_Dnode_Null then
+         Emit_Ident (Get_Decl_Ident (Decl));
+      end if;
+   end Emit_Decl_Ident_If_Set;
+
+   procedure Emit_Type (Atype : O_Tnode);
+
+   procedure Emit_Base_Type (Atype : O_Tnode; Decl : O_Dnode)
+   is
+      use Ortho_Code.Types;
+      procedure Finish_Gen_Abbrev is
+      begin
+         Gen_Abbrev_Tuple (DW_AT_Encoding, DW_FORM_Data1);
+         Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1);
+         Gen_Abbrev_Tuple (0, 0);
+      end Finish_Gen_Abbrev;
+   begin
+      if Decl = O_Dnode_Null then
+         if Abbrev_Base_Type = 0 then
+            Generate_Abbrev (Abbrev_Base_Type);
+            Gen_Abbrev_Header (DW_TAG_Base_Type, DW_CHILDREN_No);
+            Finish_Gen_Abbrev;
+         end if;
+         Gen_Info_Header (Abbrev_Base_Type);
+      else
+         if Abbrev_Base_Type_Name = 0 then
+            Generate_Abbrev (Abbrev_Base_Type_Name);
+            Gen_Abbrev_Header (DW_TAG_Base_Type, DW_CHILDREN_No);
+            Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+            Finish_Gen_Abbrev;
+         end if;
+         Gen_Info_Header (Abbrev_Base_Type_Name);
+         Emit_Decl_Ident (Decl);
+      end if;
+
+      case Get_Type_Kind (Atype) is
+         when OT_Signed =>
+            Gen_B8 (DW_ATE_Signed);
+         when OT_Unsigned =>
+            Gen_B8 (DW_ATE_Unsigned);
+         when OT_Float =>
+            Gen_B8 (DW_ATE_Float);
+         when others =>
+            raise Program_Error;
+      end case;
+      Gen_B8 (Byte (Get_Type_Size (Atype)));
+   end Emit_Base_Type;
+
+   procedure Emit_Access_Type (Atype : O_Tnode; Decl : O_Dnode)
+   is
+      use Ortho_Code.Types;
+      procedure Finish_Gen_Abbrev is
+      begin
+         Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1);
+         Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+         Gen_Abbrev_Tuple (0, 0);
+      end Finish_Gen_Abbrev;
+
+      procedure Finish_Gen_Abbrev_Uncomplete is
+      begin
+         Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1);
+         Gen_Abbrev_Tuple (0, 0);
+      end Finish_Gen_Abbrev_Uncomplete;
+
+      Dtype : O_Tnode;
+      D_Pc : Pc_Type;
+   begin
+      Dtype := Get_Type_Access_Type (Atype);
+
+      if Dtype = O_Tnode_Null then
+         if Decl = O_Dnode_Null then
+            if Abbrev_Uncomplete_Pointer = 0 then
+               Generate_Abbrev (Abbrev_Uncomplete_Pointer);
+               Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No);
+               Finish_Gen_Abbrev_Uncomplete;
+            end if;
+            Gen_Info_Header (Abbrev_Uncomplete_Pointer);
+         else
+            if Abbrev_Uncomplete_Pointer_Name = 0 then
+               Generate_Abbrev (Abbrev_Uncomplete_Pointer_Name);
+               Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No);
+               Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+               Finish_Gen_Abbrev_Uncomplete;
+            end if;
+            Gen_Info_Header (Abbrev_Uncomplete_Pointer_Name);
+            Emit_Decl_Ident (Decl);
+         end if;
+         Gen_B8 (Byte (Get_Type_Size (Atype)));
+      else
+         if Decl = O_Dnode_Null then
+            if Abbrev_Pointer = 0 then
+               Generate_Abbrev (Abbrev_Pointer);
+               Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No);
+               Finish_Gen_Abbrev;
+            end if;
+            Gen_Info_Header (Abbrev_Pointer);
+         else
+            if Abbrev_Pointer_Name = 0 then
+               Generate_Abbrev (Abbrev_Pointer_Name);
+               Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No);
+               Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+               Finish_Gen_Abbrev;
+            end if;
+            Gen_Info_Header (Abbrev_Pointer_Name);
+            Emit_Decl_Ident (Decl);
+         end if;
+         Gen_B8 (Byte (Get_Type_Size (Atype)));
+         --  Break possible loops: generate the access entry...
+         D_Pc := Get_Current_Pc;
+         Gen_32 (0);
+         --  ... generate the designated type ...
+         Emit_Type (Dtype);
+         --  ... and write its reference.
+         Patch_32 (D_Pc, Unsigned_32 (TOnodes.Table (Dtype)));
+      end if;
+   end Emit_Access_Type;
+
+   procedure Emit_Ucarray_Type (Atype : O_Tnode; Decl : O_Dnode)
+   is
+      use Ortho_Code.Types;
+
+      procedure Finish_Gen_Abbrev is
+      begin
+         Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+         Gen_Abbrev_Tuple (0, 0);
+      end Finish_Gen_Abbrev;
+   begin
+      if Decl = O_Dnode_Null then
+         if Abbrev_Ucarray = 0 then
+            Generate_Abbrev (Abbrev_Ucarray);
+            Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes);
+            Finish_Gen_Abbrev;
+         end if;
+         Gen_Info_Header (Abbrev_Ucarray);
+      else
+         if Abbrev_Ucarray_Name = 0 then
+            Generate_Abbrev (Abbrev_Ucarray_Name);
+            Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes);
+            Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+            Finish_Gen_Abbrev;
+         end if;
+         Gen_Info_Header (Abbrev_Ucarray_Name);
+         Emit_Decl_Ident (Decl);
+      end if;
+      Emit_Type_Ref (Get_Type_Ucarray_Element (Atype));
+
+      if Abbrev_Uc_Subrange = 0 then
+         Generate_Abbrev (Abbrev_Uc_Subrange);
+         Gen_Abbrev_Header (DW_TAG_Subrange_Type, DW_CHILDREN_No);
+
+         Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+         Gen_Abbrev_Tuple (0, 0);
+      end if;
+
+      Gen_Info_Header (Abbrev_Uc_Subrange);
+      Emit_Type_Ref (Get_Type_Ucarray_Index (Atype));
+
+      Gen_Uleb128 (0);
+   end Emit_Ucarray_Type;
+
+   procedure Emit_Subarray_Type (Atype : O_Tnode; Decl : O_Dnode)
+   is
+      use Ortho_Code.Types;
+      procedure Finish_Gen_Abbrev is
+      begin
+         Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+         Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata);
+         Gen_Abbrev_Tuple (0, 0);
+      end Finish_Gen_Abbrev;
+
+      Base : O_Tnode;
+   begin
+      if Decl = O_Dnode_Null then
+         if Abbrev_Subarray = 0 then
+            Generate_Abbrev (Abbrev_Subarray);
+            Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes);
+            Finish_Gen_Abbrev;
+         end if;
+         Gen_Info_Header (Abbrev_Subarray);
+      else
+         if Abbrev_Subarray_Name = 0 then
+            Generate_Abbrev (Abbrev_Subarray_Name);
+            Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes);
+            Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+            Finish_Gen_Abbrev;
+         end if;
+         Gen_Info_Header (Abbrev_Subarray_Name);
+         Emit_Decl_Ident (Decl);
+      end if;
+
+      Base := Get_Type_Subarray_Base (Atype);
+
+      Emit_Type_Ref (Get_Type_Ucarray_Element (Base));
+      Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype)));
+
+      if Abbrev_Subrange = 0 then
+         Generate_Abbrev (Abbrev_Subrange);
+         Gen_Abbrev_Header (DW_TAG_Subrange_Type, DW_CHILDREN_No);
+
+         Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+         Gen_Abbrev_Tuple (DW_AT_Lower_Bound, DW_FORM_Data1);
+         Gen_Abbrev_Tuple (DW_AT_Count, DW_FORM_Udata);
+         Gen_Abbrev_Tuple (0, 0);
+      end if;
+
+      Gen_Info_Header (Abbrev_Subrange);
+      Emit_Type_Ref (Get_Type_Ucarray_Index (Base));
+      Gen_B8 (0);
+      Gen_Uleb128 (Unsigned_32 (Get_Type_Subarray_Length (Atype)));
+
+      Gen_Uleb128 (0);
+   end Emit_Subarray_Type;
+
+   procedure Emit_Members (Atype : O_Tnode; Decl : O_Dnode)
+   is
+      use Ortho_Code.Types;
+      Nbr : Uns32;
+      F : O_Fnode;
+      Loc_Pc : Pc_Type;
+      Sibling_Pc : Pc_Type;
+   begin
+      if Abbrev_Member = 0 then
+         Generate_Abbrev (Abbrev_Member);
+
+         Gen_Abbrev_Header (DW_TAG_Member, DW_CHILDREN_No);
+
+         Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+         Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+         Gen_Abbrev_Tuple (DW_AT_Data_Member_Location, DW_FORM_Block1);
+         Gen_Abbrev_Tuple (0, 0);
+      end if;
+
+      Set_Current_Section (Info_Sect);
+      Sibling_Pc := Gen_Info_Sibling;
+      Emit_Decl_Ident_If_Set (Decl);
+      Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype)));
+
+      Nbr := Get_Type_Record_Nbr_Fields (Atype);
+      F := Get_Type_Record_Fields (Atype);
+      while Nbr > 0 loop
+         Gen_Uleb128 (Abbrev_Member);
+         Emit_Ident (Get_Field_Ident (F));
+         Emit_Type_Ref (Get_Field_Type (F));
+
+         --  Location.
+         Loc_Pc := Get_Current_Pc;
+         Gen_B8 (3);
+         Gen_B8 (DW_OP_Plus_Uconst);
+         Gen_Uleb128 (Unsigned_32 (Get_Field_Offset (F)));
+         Patch_B8 (Loc_Pc, Unsigned_8 (Get_Current_Pc - (Loc_Pc + 1)));
+
+         F := Get_Field_Chain (F);
+         Nbr := Nbr - 1;
+      end loop;
+
+      --  end of children.
+      Gen_Uleb128 (0);
+      Patch_Info_Sibling (Sibling_Pc);
+   end Emit_Members;
+
+   procedure Emit_Record_Type (Atype : O_Tnode; Decl : O_Dnode)
+   is
+      use Ortho_Code.Types;
+      procedure Finish_Gen_Abbrev is
+      begin
+         Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata);
+         Gen_Abbrev_Tuple (0, 0);
+      end Finish_Gen_Abbrev;
+   begin
+      if Decl = O_Dnode_Null then
+         if Abbrev_Struct = 0 then
+            Generate_Abbrev (Abbrev_Struct);
+
+            Gen_Abbrev_Header (DW_TAG_Structure_Type, DW_CHILDREN_Yes);
+            Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+            Finish_Gen_Abbrev;
+         end if;
+         Gen_Info_Header (Abbrev_Struct);
+      else
+         if Abbrev_Struct_Name = 0 then
+            Generate_Abbrev (Abbrev_Struct_Name);
+
+            Gen_Abbrev_Header (DW_TAG_Structure_Type, DW_CHILDREN_Yes);
+            Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+            Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+            Finish_Gen_Abbrev;
+         end if;
+         Gen_Info_Header (Abbrev_Struct_Name);
+      end if;
+      Emit_Members (Atype, Decl);
+   end Emit_Record_Type;
+
+   procedure Emit_Union_Type (Atype : O_Tnode; Decl : O_Dnode)
+   is
+      use Ortho_Code.Types;
+      procedure Finish_Gen_Abbrev is
+      begin
+         Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata);
+         Gen_Abbrev_Tuple (0, 0);
+      end Finish_Gen_Abbrev;
+   begin
+      if Decl = O_Dnode_Null then
+         if Abbrev_Union = 0 then
+            Generate_Abbrev (Abbrev_Union);
+
+            Gen_Abbrev_Header (DW_TAG_Union_Type, DW_CHILDREN_Yes);
+            Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+            Finish_Gen_Abbrev;
+         end if;
+         Gen_Info_Header (Abbrev_Union);
+      else
+         if Abbrev_Union_Name = 0 then
+            Generate_Abbrev (Abbrev_Union_Name);
+
+            Gen_Abbrev_Header (DW_TAG_Union_Type, DW_CHILDREN_Yes);
+            Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+            Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+            Finish_Gen_Abbrev;
+         end if;
+         Gen_Info_Header (Abbrev_Union_Name);
+      end if;
+      Emit_Members (Atype, Decl);
+   end Emit_Union_Type;
+
+   procedure Emit_Enum_Type (Atype : O_Tnode; Decl : O_Dnode)
+   is
+      use Ortho_Code.Types;
+      use Ortho_Code.Consts;
+      procedure Finish_Gen_Abbrev is
+      begin
+         Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1);
+         Gen_Abbrev_Tuple (0, 0);
+      end Finish_Gen_Abbrev;
+
+      procedure Emit_Enumerator (L : O_Cnode) is
+      begin
+         Gen_Uleb128 (Abbrev_Enumerator);
+         Emit_Ident (Get_Lit_Ident (L));
+         Gen_Uleb128 (Unsigned_32 (Get_Lit_Value (L)));
+      end Emit_Enumerator;
+
+      Nbr : Uns32;
+      L : O_Cnode;
+      Sibling_Pc : Pc_Type;
+   begin
+      if Abbrev_Enumerator = 0 then
+         Generate_Abbrev (Abbrev_Enumerator);
+
+         Gen_Abbrev_Header (DW_TAG_Enumerator, DW_CHILDREN_No);
+
+         Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+         Gen_Abbrev_Tuple (DW_AT_Const_Value, DW_FORM_Udata);
+         Gen_Abbrev_Tuple (0, 0);
+      end if;
+      if Decl = O_Dnode_Null then
+         if Abbrev_Enum = 0 then
+            Generate_Abbrev (Abbrev_Enum);
+            Gen_Abbrev_Header (DW_TAG_Enumeration_Type, DW_CHILDREN_Yes);
+            Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+            Finish_Gen_Abbrev;
+         end if;
+         Gen_Info_Header (Abbrev_Enum);
+      else
+         if Abbrev_Enum_Name = 0 then
+            Generate_Abbrev (Abbrev_Enum_Name);
+            Gen_Abbrev_Header (DW_TAG_Enumeration_Type, DW_CHILDREN_Yes);
+            Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+            Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+            Finish_Gen_Abbrev;
+         end if;
+         Gen_Info_Header (Abbrev_Enum_Name);
+      end if;
+
+      Sibling_Pc := Gen_Info_Sibling;
+      Emit_Decl_Ident_If_Set (Decl);
+      Gen_B8 (Byte (Get_Type_Size (Atype)));
+      case Get_Type_Kind (Atype) is
+         when OT_Enum =>
+            Nbr := Get_Type_Enum_Nbr_Lits (Atype);
+            L := Get_Type_Enum_Lits (Atype);
+            while Nbr > 0 loop
+               Emit_Enumerator (L);
+
+               L := Get_Lit_Chain (L);
+               Nbr := Nbr - 1;
+            end loop;
+         when OT_Boolean =>
+            Emit_Enumerator (Get_Type_Bool_False (Atype));
+            Emit_Enumerator (Get_Type_Bool_True (Atype));
+         when others =>
+            raise Program_Error;
+      end case;
+
+      --  End of children.
+      Gen_Uleb128 (0);
+      Patch_Info_Sibling (Sibling_Pc);
+   end Emit_Enum_Type;
+
+   procedure Emit_Type (Atype : O_Tnode)
+   is
+      use Ortho_Code.Types;
+      use Ada.Text_IO;
+      Kind : OT_Kind;
+      Decl : O_Dnode;
+   begin
+      --  If already emitted, then return.
+      if Atype <= TOnodes.Last
+        and then TOnodes.Table (Atype) /= Null_Pc
+      then
+         return;
+      end if;
+
+      Kind := Get_Type_Kind (Atype);
+
+      --  First step: emit inner types (if any).
+      case Kind is
+         when OT_Signed
+           | OT_Unsigned
+           | OT_Float
+           | OT_Boolean
+           | OT_Enum =>
+            null;
+         when OT_Access =>
+            null;
+         when OT_Ucarray =>
+            Emit_Type (Get_Type_Ucarray_Index (Atype));
+            Emit_Type (Get_Type_Ucarray_Element (Atype));
+         when OT_Subarray =>
+            Emit_Type (Get_Type_Subarray_Base (Atype));
+         when OT_Record
+           | OT_Union =>
+            declare
+               Nbr : Uns32;
+               F : O_Fnode;
+            begin
+               Nbr := Get_Type_Record_Nbr_Fields (Atype);
+               F := Get_Type_Record_Fields (Atype);
+               while Nbr > 0 loop
+                  Emit_Type (Get_Field_Type (F));
+                  F := Get_Field_Chain (F);
+                  Nbr := Nbr - 1;
+               end loop;
+            end;
+      end case;
+
+      Set_Current_Section (Info_Sect);
+      Add_Type_Ref (Atype, Get_Current_Pc);
+
+      Decl := Decls.Get_Type_Decl (Atype);
+
+      --  Second step: emit info.
+      case Kind is
+         when OT_Signed
+           | OT_Unsigned
+           | OT_Float =>
+            Emit_Base_Type (Atype, Decl);
+            -- base types.
+         when OT_Access =>
+            Emit_Access_Type (Atype, Decl);
+         when OT_Ucarray =>
+            Emit_Ucarray_Type (Atype, Decl);
+         when OT_Subarray =>
+            Emit_Subarray_Type (Atype, Decl);
+         when OT_Record =>
+            Emit_Record_Type (Atype, Decl);
+         when OT_Union =>
+            Emit_Union_Type (Atype, Decl);
+         when OT_Enum
+           | OT_Boolean =>
+            Emit_Enum_Type (Atype, Decl);
+      end case;
+   end Emit_Type;
+
+   procedure Emit_Decl_Type (Decl : O_Dnode)
+   is
+      use Ortho_Code.Decls;
+   begin
+      Emit_Type_Ref (Get_Decl_Type (Decl));
+   end Emit_Decl_Type;
+
+   Abbrev_Variable : Unsigned_32 := 0;
+   Abbrev_Const : Unsigned_32 := 0;
+
+   procedure Emit_Local_Location (Decl : O_Dnode)
+   is
+      use Ortho_Code.Decls;
+      Pc : Pc_Type;
+   begin
+      Pc := Get_Current_Pc;
+      Gen_B8 (2);
+      Gen_B8 (DW_OP_Fbreg);
+      Gen_Sleb128 (Int32 (Get_Decl_Info (Decl)));
+      Patch_B8 (Pc, Unsigned_8 (Get_Current_Pc - (Pc + 1)));
+   end Emit_Local_Location;
+
+   procedure Emit_Global_Location (Decl : O_Dnode)
+   is
+      use Ortho_Code.Binary;
+   begin
+      Gen_B8 (5);
+      Gen_B8 (DW_OP_Addr);
+      Gen_Ua_32 (Get_Decl_Symbol (Decl), 0);
+   end Emit_Global_Location;
+
+   procedure Emit_Variable (Decl : O_Dnode)
+   is
+      use Ortho_Code.Decls;
+      Dtype : O_Tnode;
+   begin
+      if Get_Decl_Ident (Decl) = O_Ident_Nul then
+         return;
+      end if;
+
+      if Abbrev_Variable = 0 then
+         Generate_Abbrev (Abbrev_Variable);
+         Gen_Abbrev_Header (DW_TAG_Variable, DW_CHILDREN_No);
+
+         Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+         Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+         Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1);
+         Gen_Abbrev_Tuple (0, 0);
+      end if;
+
+      Dtype := Get_Decl_Type (Decl);
+      Emit_Type (Dtype);
+
+      Gen_Info_Header (Abbrev_Variable);
+      Emit_Decl_Ident (Decl);
+      Emit_Type_Ref (Dtype);
+      case Get_Decl_Kind (Decl) is
+         when OD_Local =>
+            Emit_Local_Location (Decl);
+         when OD_Var =>
+            Emit_Global_Location (Decl);
+         when others =>
+            raise Program_Error;
+      end case;
+   end Emit_Variable;
+
+   procedure Emit_Const (Decl : O_Dnode)
+   is
+      use Ortho_Code.Decls;
+      Dtype : O_Tnode;
+   begin
+      if Abbrev_Const = 0 then
+         Generate_Abbrev (Abbrev_Const);
+         --  FIXME: should be a TAG_Constant, however, GDB does not support it.
+         --  work-around: could use a const_type.
+         Gen_Abbrev_Header (DW_TAG_Variable, DW_CHILDREN_No);
+
+         Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+         Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+         Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1);
+         Gen_Abbrev_Tuple (0, 0);
+      end if;
+
+      Dtype := Get_Decl_Type (Decl);
+      Emit_Type (Dtype);
+      Gen_Info_Header (Abbrev_Const);
+      Emit_Decl_Ident (Decl);
+      Emit_Type_Ref (Dtype);
+      Emit_Global_Location (Decl);
+   end Emit_Const;
+
+   procedure Emit_Type_Decl (Decl : O_Dnode)
+   is
+      use Ortho_Code.Decls;
+   begin
+      Emit_Type (Get_Decl_Type (Decl));
+   end Emit_Type_Decl;
+
+   Subprg_Sym : Symbol;
+
+   Abbrev_Block : Unsigned_32 := 0;
+
+   procedure Emit_Block_Decl (Decl : O_Dnode)
+   is
+      use Ortho_Code.Decls;
+      Last : O_Dnode;
+      Sdecl : O_Dnode;
+      Sibling_Pc : Pc_Type;
+   begin
+      if Abbrev_Block = 0 then
+         Generate_Abbrev (Abbrev_Block);
+
+         Gen_Abbrev_Header (DW_TAG_Lexical_Block, DW_CHILDREN_Yes);
+         Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+         Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr);
+         Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr);
+         Gen_Abbrev_Tuple (0, 0);
+      end if;
+
+      Gen_Info_Header (Abbrev_Block);
+      Sibling_Pc := Gen_Info_Sibling;
+
+      Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info1 (Decl)));
+      Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info2 (Decl)));
+
+      --  Emit decls for children.
+      Last := Get_Block_Last (Decl);
+      Sdecl := Decl + 1;
+      while Sdecl <= Last loop
+         Emit_Decl (Sdecl);
+         Sdecl := Get_Decl_Chain (Sdecl);
+      end loop;
+
+      --  End of children.
+      Set_Current_Section (Info_Sect);
+      Gen_Uleb128 (0);
+
+      Patch_Info_Sibling (Sibling_Pc);
+   end Emit_Block_Decl;
+
+   Abbrev_Function : Unsigned_32 := 0;
+   Abbrev_Procedure : Unsigned_32 := 0;
+   Abbrev_Interface : Unsigned_32 := 0;
+
+   procedure Emit_Subprg_Body (Bod : O_Dnode)
+   is
+      use Ortho_Code.Decls;
+      Kind : OD_Kind;
+      Decl : O_Dnode;
+      Idecl : O_Dnode;
+      Prev_Subprg_Sym : Symbol;
+      Sibling_Pc : Pc_Type;
+   begin
+      Decl := Get_Body_Decl (Bod);
+      Kind := Get_Decl_Kind (Decl);
+
+      --  Emit interfaces type.
+      Idecl := Get_Subprg_Interfaces (Decl);
+      while Idecl /= O_Dnode_Null loop
+         Emit_Type (Get_Decl_Type (Idecl));
+         Idecl := Get_Interface_Chain (Idecl);
+      end loop;
+
+      if Kind = OD_Function then
+         Emit_Type (Get_Decl_Type (Decl));
+         if Abbrev_Function = 0 then
+            Generate_Abbrev (Abbrev_Function);
+
+            Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes);
+            Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+
+            Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+            Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+            Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr);
+            Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr);
+            Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1);
+            --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1);
+            Gen_Abbrev_Tuple (0, 0);
+         end if;
+         Gen_Info_Header (Abbrev_Function);
+      else
+         if Abbrev_Procedure = 0 then
+            Generate_Abbrev (Abbrev_Procedure);
+
+            Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes);
+            Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+
+            Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+            Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr);
+            Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr);
+            Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1);
+            --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1);
+            Gen_Abbrev_Tuple (0, 0);
+         end if;
+         Gen_Info_Header (Abbrev_Procedure);
+      end if;
+
+      Sibling_Pc := Gen_Info_Sibling;
+
+      if Kind = OD_Function then
+         Emit_Decl_Type (Decl);
+      end if;
+
+      Emit_Decl_Ident (Decl);
+      Prev_Subprg_Sym := Subprg_Sym;
+      Subprg_Sym := Binary.Get_Decl_Symbol (Decl);
+      Gen_Ua_32 (Subprg_Sym, 0);
+      Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Body_Info (Bod)));
+
+      --  Frame base.
+      Gen_B8 (1);
+      Gen_B8 (DW_OP_Reg5);
+
+      --  Interfaces.
+      Idecl := Get_Subprg_Interfaces (Decl);
+      if Idecl /= O_Dnode_Null then
+         if Abbrev_Interface = 0 then
+            Generate_Abbrev (Abbrev_Interface);
+
+            Gen_Abbrev_Header (DW_TAG_Formal_Parameter, DW_CHILDREN_No);
+            Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+            Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+            Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1);
+            Gen_Abbrev_Tuple (0, 0);
+         end if;
+
+         loop
+            Gen_Info_Header (Abbrev_Interface);
+            Emit_Decl_Type (Idecl);
+            Emit_Decl_Ident (Idecl);
+
+            Emit_Local_Location (Idecl);
+
+            Idecl := Get_Interface_Chain (Idecl);
+            exit when Idecl = O_Dnode_Null;
+         end loop;
+      end if;
+
+      --  Internal declarations.
+      Emit_Block_Decl (Bod + 1);
+
+      --  End of children.
+      Gen_Uleb128 (0);
+
+      Patch_Info_Sibling (Sibling_Pc);
+
+      Subprg_Sym := Prev_Subprg_Sym;
+   end Emit_Subprg_Body;
+
+   procedure Emit_Decl (Decl : O_Dnode)
+   is
+      use Ada.Text_IO;
+      use Ortho_Code.Decls;
+   begin
+      case Get_Decl_Kind (Decl) is
+         when OD_Type =>
+            Emit_Type_Decl (Decl);
+         when OD_Local
+           | OD_Var =>
+            Emit_Variable (Decl);
+         when OD_Const =>
+            Emit_Const (Decl);
+         when OD_Function
+           | OD_Procedure
+           | OD_Interface =>
+            null;
+         when OD_Body =>
+            Emit_Subprg_Body (Decl);
+         when OD_Block =>
+            Emit_Block_Decl (Decl);
+         when others =>
+            Put_Line ("dwarf.emit_decl: emit "
+                      & OD_Kind'Image (Get_Decl_Kind (Decl)));
+      end case;
+   end Emit_Decl;
+
+   procedure Emit_Subprg (Bod : O_Dnode) is
+   begin
+      Emit_Decls_Until (Bod);
+   end Emit_Subprg;
+
+   procedure Mark (M : out Mark_Type) is
+   begin
+      M.Last_Decl := Last_Decl;
+      M.Last_Tnode := TOnodes.Last;
+   end Mark;
+
+   procedure Release (M : Mark_Type) is
+   begin
+      Last_Decl := M.Last_Decl;
+      TOnodes.Set_Last (M.Last_Tnode);
+   end Release;
+
+end Ortho_Code.Dwarf;
+