path: root/ortho/llvm/ortho_llvm.adb

--  LLVM back-end for ortho.
--  Copyright (C) 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 Ortho_LLVM.Main; use Ortho_LLVM.Main;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with LLVM.Target; use LLVM.Target;

package body Ortho_LLVM is

   --  Target_Data : TargetDataRef;
   Cur_Func : ValueRef;
   Cur_Func_Decl : O_Dnode;
   Unreach : Boolean;

   type Declare_Block_Type;
   type Declare_Block_Acc is access Declare_Block_Type;

   type Declare_Block_Type is record
      Stmt_Bb : BasicBlockRef;

      Dbg_Scope : ValueRef;
      Prev : Declare_Block_Acc;
   end record;

   Cur_Declare_Block : Declare_Block_Acc;
   Old_Declare_Block : Declare_Block_Acc;

   --  For debugging

   DW_Version : constant := 16#c_0000#;
   DW_TAG_Array_Type       : constant := DW_Version + 16#01#;
   DW_TAG_Enumeration_Type : constant := DW_Version + 16#04#;
   DW_TAG_Lexical_Block    : constant := DW_Version + 16#0b#;
   DW_TAG_Member           : constant := DW_Version + 16#0d#;
   DW_TAG_Pointer_Type     : constant := DW_Version + 16#0f#;
   DW_TAG_Compile_Unit     : constant := DW_Version + 16#11#;
   DW_TAG_Structure_Type   : constant := DW_Version + 16#13#;
   DW_TAG_Subroutine_Type  : constant := DW_Version + 16#15#;
   DW_TAG_Subrange_Type    : constant := DW_Version + 16#21#;
   DW_TAG_Base_Type        : constant := DW_Version + 16#24#;
   DW_TAG_Enumerator       : constant := DW_Version + 16#28#;
   DW_TAG_File_Type        : constant := DW_Version + 16#29#;
   DW_TAG_Subprogram       : constant := DW_Version + 16#2e#;
   DW_TAG_Variable         : constant := DW_Version + 16#34#;

   DW_TAG_Auto_Variable    : constant := DW_Version + 16#100#;
   DW_TAG_Arg_Variable     : constant := DW_Version + 16#101#;

   DW_ATE_address  : constant := 16#01#;
   DW_ATE_boolean  : constant := 16#02#;
   DW_ATE_float    : constant := 16#04#;
   DW_ATE_signed   : constant := 16#05#;
   DW_ATE_unsigned : constant := 16#07#;
   pragma Unreferenced (DW_ATE_address, DW_ATE_boolean);

   --  File + Dir metadata
   Dbg_Current_Filedir : ValueRef;
   Dbg_Current_File : ValueRef; -- The DW_TAG_File_Type

   Dbg_Current_Line : unsigned := 0;

   Dbg_Current_Scope : ValueRef;
   Scope_Uniq_Id : Unsigned_64 := 0;

   --  Metadata for the instruction
   Dbg_Insn_MD : ValueRef;
   Dbg_Insn_MD_Line : unsigned := 0;

   procedure Free is new Ada.Unchecked_Deallocation
     (ValueRefArray, ValueRefArray_Acc);

   package Dbg_Utils is
      type Dyn_MDNode is private;

      procedure Append (D : in out Dyn_MDNode; Val : ValueRef);
      function Get_Value (D : Dyn_MDNode) return ValueRef;

      --  Reset D.  FIXME: should be done automatically within Get_Value.
      procedure Clear (D : out Dyn_MDNode);
   private
      Chunk_Length : constant unsigned := 32;
      type MD_Chunk;
      type MD_Chunk_Acc is access MD_Chunk;

      type MD_Chunk is record
         Vals : ValueRefArray (1 .. Chunk_Length);
         Next : MD_Chunk_Acc;
      end record;

      type Dyn_MDNode is record
         First : MD_Chunk_Acc;
         Last : MD_Chunk_Acc;
         Nbr : unsigned := 0;
      end record;
   end Dbg_Utils;

   package body Dbg_Utils is
      procedure Append (D : in out Dyn_MDNode; Val : ValueRef) is
         Chunk : MD_Chunk_Acc;
         Pos : constant unsigned := D.Nbr rem Chunk_Length;
      begin
         if Pos = 0 then
            Chunk := new MD_Chunk;
            if D.First = null then
               D.First := Chunk;
            else
               D.Last.Next := Chunk;
            end if;
            D.Last := Chunk;
         else
            Chunk := D.Last;
         end if;
         Chunk.Vals (Pos + 1) := Val;
         D.Nbr := D.Nbr + 1;
      end Append;

      procedure Free is new Ada.Unchecked_Deallocation
        (MD_Chunk, MD_Chunk_Acc);

      function Get_Value (D : Dyn_MDNode) return ValueRef
      is
         Vals : ValueRefArray (1 .. D.Nbr);
         Pos : unsigned;
         Chunk : MD_Chunk_Acc := D.First;
         Next_Chunk : MD_Chunk_Acc;
         Nbr : constant unsigned := D.Nbr;
      begin
         Pos := 0;
         --  Copy by chunks
         while Pos + Chunk_Length < Nbr loop
            Vals (Pos + 1 .. Pos + Chunk_Length) := Chunk.Vals;
            Pos := Pos + Chunk_Length;
            Next_Chunk := Chunk.Next;
            Free (Chunk);
            Chunk := Next_Chunk;
         end loop;
         --  Last chunk
         if Pos < Nbr then
            Vals (Pos + 1 .. Pos + Nbr - Pos) := Chunk.Vals (1 .. Nbr - Pos);
            Free (Chunk);
         end if;
         return MDNode (Vals, Vals'Length);
      end Get_Value;

      procedure Clear (D : out Dyn_MDNode) is
      begin
         D := (null, null, 0);
      end Clear;
   end Dbg_Utils;

   use Dbg_Utils;

   --  List of debug info for subprograms.
   Subprg_Nodes: Dyn_MDNode;

   --  List of literals for enumerated type
   Enum_Nodes : Dyn_MDNode;

   --  List of global variables
   Global_Nodes : Dyn_MDNode;

   --  Create a MDString from an Ada string.
   function MDString (Str : String) return ValueRef is
   begin
      return MDString (Str'Address, Str'Length);
   end MDString;

   function MDString (Id : O_Ident) return ValueRef is
   begin
      return MDString (Get_Cstring (Id), unsigned (Get_String_Length (Id)));
   end MDString;

   function Dbg_Size (Atype : TypeRef) return ValueRef is
   begin
      return ConstInt (Int64Type, 8 * ABISizeOfType (Target_Data, Atype), 0);
   end Dbg_Size;

   function Dbg_Align (Atype : TypeRef) return ValueRef is
   begin
      return ConstInt
        (Int64Type,
         Unsigned_64 (8 * ABIAlignmentOfType (Target_Data, Atype)), 0);
   end Dbg_Align;

   function Dbg_Line return ValueRef is
   begin
      return ConstInt (Int32Type, Unsigned_64 (Dbg_Current_Line), 0);
   end Dbg_Line;

   --  Set debug metadata on instruction INSN.
   --  FIXME: check if INSN is really an instruction
   procedure Set_Insn_Dbg (Insn : ValueRef) is
   begin
      if Flag_Debug then
         if Dbg_Current_Line /= Dbg_Insn_MD_Line then
            declare
               Vals : ValueRefArray (0 .. 3);
            begin
               Vals := (Dbg_Line,
                        ConstInt (Int32Type, 0, 0), --  col
                        Dbg_Current_Scope,          --  context
                        Null_ValueRef);             --  inline
               Dbg_Insn_MD := MDNode (Vals, Vals'Length);
               Dbg_Insn_MD_Line := Dbg_Current_Line;
            end;
         end if;
         SetMetadata (Insn, Debug_ID, Dbg_Insn_MD);
      end if;
   end Set_Insn_Dbg;

   procedure Dbg_Create_Variable (Tag : Unsigned_32;
                                  Ident : O_Ident;
                                  Vtype : O_Tnode;
                                  Argno : Natural;
                                  Addr : ValueRef)
   is
      Vals : ValueRefArray (0 .. 7);
      Str : constant ValueRef := MDString (Ident);
      Call_Vals : ValueRefArray (0 .. 1);
      Call : ValueRef;
   begin
      Vals := (ConstInt (Int32Type, Unsigned_64 (Tag), 0),
               Dbg_Current_Scope,
               Str,
               Dbg_Current_File,
               ConstInt (Int32Type,
                         Unsigned_64 (Dbg_Current_Line)
                           + Unsigned_64 (Argno) * 2 ** 24, 0),
               Vtype.Dbg,
               ConstInt (Int32Type, 0, 0), --  flags
               ConstInt (Int32Type, 0, 0));

      Call_Vals := (MDNode ((0 => Addr), 1),
                    MDNode (Vals, Vals'Length));
      Call := BuildCall (Decl_Builder, Llvm_Dbg_Declare,
                         Call_Vals, Call_Vals'Length, Empty_Cstring);
      Set_Insn_Dbg (Call);
   end Dbg_Create_Variable;

   procedure Create_Declare_Block
   is
      Res : Declare_Block_Acc;
   begin
      if Old_Declare_Block /= null then
         Res := Old_Declare_Block;
         Old_Declare_Block := Res.Prev;
      else
         Res := new Declare_Block_Type;
      end if;

      Res.Prev := Cur_Declare_Block;
      Cur_Declare_Block := Res;

      if not Unreach then
         Res.Stmt_Bb := AppendBasicBlock (Cur_Func, Empty_Cstring);
      end if;
   end Create_Declare_Block;

   procedure Destroy_Declare_Block
   is
      Blk : constant Declare_Block_Acc := Cur_Declare_Block;
   begin
      Cur_Declare_Block := Blk.Prev;
      Blk.Prev := Old_Declare_Block;
      Old_Declare_Block := Blk;
   end Destroy_Declare_Block;

   -----------------------
   -- Start_Record_Type --
   -----------------------

   procedure Start_Record_Type (Elements : out O_Element_List) is
   begin
      Elements := (Nbr_Elements => 0,
                   Rec_Type => O_Tnode_Null,
                   Size => 0,
                   Align => 0,
                   Align_Type => Null_TypeRef,
                   First_Elem => null,
                   Last_Elem => null);
   end Start_Record_Type;

   ----------------------
   -- New_Record_Field --
   ----------------------

   procedure New_Record_Field
     (Elements : in out O_Element_List;
      El : out O_Fnode;
      Ident : O_Ident;
      Etype : O_Tnode)
   is
      O_El : O_Element_Acc;
   begin
      El := (Kind => OF_Record,
             Index => Elements.Nbr_Elements,
             Ftype => Etype);
      Elements.Nbr_Elements := Elements.Nbr_Elements + 1;
      O_El := new O_Element'(Next => null,
                             Etype => Etype,
                             Ident => Ident);
      if Elements.First_Elem = null then
         Elements.First_Elem := O_El;
      else
         Elements.Last_Elem.Next := O_El;
      end if;
      Elements.Last_Elem := O_El;
   end New_Record_Field;

   ------------------------
   -- Finish_Record_Type --
   ------------------------

   procedure Finish_Record_Type
     (Elements : in out O_Element_List;
      Res : out O_Tnode)
   is
      procedure Free is new Ada.Unchecked_Deallocation
        (O_Element, O_Element_Acc);

      Count : constant unsigned := unsigned (Elements.Nbr_Elements);
      El : O_Element_Acc;
      Next_El : O_Element_Acc;
      Types : TypeRefArray (1 .. Count);
   begin
      El := Elements.First_Elem;
      for I in Types'Range loop
         Types (I) := Get_LLVM_Type (El.Etype);
         El := El.Next;
      end loop;

      if Elements.Rec_Type /= null then
         --  Completion
         StructSetBody (Elements.Rec_Type.LLVM, Types, Count, 0);
         Res := Elements.Rec_Type;
      else
         Res := new O_Tnode_Type'(Kind => ON_Record_Type,
                                  LLVM => StructType (Types, Count, 0),
                                  Dbg => Null_ValueRef);
      end if;

      if Flag_Debug then
         declare
            Fields : ValueRefArray (1 .. Count);
            Vals : ValueRefArray (0 .. 9);
            Ftype : TypeRef;
            Fields_Arr : ValueRef;
         begin
            El := Elements.First_Elem;
            for I in Fields'Range loop
               Ftype := Get_LLVM_Type (El.Etype);
               Vals :=
                 (ConstInt (Int32Type, DW_TAG_Member, 0),
                  Dbg_Current_File,
                  Null_ValueRef,
                  MDString (El.Ident),
                  ConstInt (Int32Type, 0, 0),    -- linenum
                  Dbg_Size (Ftype),
                  Dbg_Align (Ftype),
                  ConstInt
                    (Int32Type,
                     8 * OffsetOfElement (Target_Data,
                                          Res.LLVM, Unsigned_32 (I - 1)), 0),
                  ConstInt (Int32Type, 0, 0),    --  Flags
                  El.Etype.Dbg);
               Fields (I) := MDNode (Vals, Vals'Length);
               El := El.Next;
            end loop;
            Fields_Arr := MDNode (Fields, Fields'Length);
            if Elements.Rec_Type /= null then
               --  Completion
               MDNodeReplaceOperandWith (Res.Dbg, 10, Fields_Arr);
               MDNodeReplaceOperandWith (Res.Dbg, 5, Dbg_Size (Res.LLVM));
               MDNodeReplaceOperandWith (Res.Dbg, 6, Dbg_Align (Res.LLVM));
            else
               --  Temporary borrowed.
               Res.Dbg := Fields_Arr;
            end if;
         end;
      end if;

      --  Free elements
      El := Elements.First_Elem;
      for I in Types'Range loop
         Next_El := El.Next;
         Free (El);
         El := Next_El;
      end loop;
   end Finish_Record_Type;

   --------------------------------
   -- New_Uncomplete_Record_Type --
   --------------------------------

   procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is
   begin
      --  LLVM type will be created when the type is declared.
      Res := new O_Tnode_Type'(Kind => ON_Incomplete_Record_Type,
                               LLVM => Null_TypeRef,
                               Dbg => Null_ValueRef);
   end New_Uncomplete_Record_Type;

   ----------------------------------
   -- Start_Uncomplete_Record_Type --
   ----------------------------------

   procedure Start_Uncomplete_Record_Type
     (Res : O_Tnode;
      Elements : out O_Element_List)
   is
   begin
      if Res.Kind /= ON_Incomplete_Record_Type then
         raise Program_Error;
      end if;
      Elements := (Nbr_Elements => 0,
                   Rec_Type => Res,
                   Size => 0,
                   Align => 0,
                   Align_Type => Null_TypeRef,
                   First_Elem => null,
                   Last_Elem => null);
   end Start_Uncomplete_Record_Type;

   ----------------------
   -- Start_Union_Type --
   ----------------------

   procedure Start_Union_Type (Elements : out O_Element_List) is
   begin
      Elements := (Nbr_Elements => 0,
                   Rec_Type => O_Tnode_Null,
                   Size => 0,
                   Align => 0,
                   Align_Type => Null_TypeRef,
                   First_Elem => null,
                   Last_Elem => null);
   end Start_Union_Type;

   ---------------------
   -- New_Union_Field --
   ---------------------

   procedure New_Union_Field
     (Elements : in out O_Element_List;
      El : out O_Fnode;
      Ident : O_Ident;
      Etype : O_Tnode)
   is
      pragma Unreferenced (Ident);

      El_Type : constant TypeRef := Get_LLVM_Type (Etype);
      Size : constant unsigned :=
        unsigned (ABISizeOfType (Target_Data, El_Type));
      Align : constant Unsigned_32 :=
        ABIAlignmentOfType (Target_Data, El_Type);
   begin
      El := (Kind => OF_Union, Utype => El_Type, Ftype => Etype);
      if Size > Elements.Size then
         Elements.Size := Size;
      end if;
      if Elements.Align_Type = Null_TypeRef or else Align > Elements.Align then
         Elements.Align := Align;
         Elements.Align_Type := El_Type;
      end if;
   end New_Union_Field;

   -----------------------
   -- Finish_Union_Type --
   -----------------------

   procedure Finish_Union_Type
     (Elements : in out O_Element_List;
      Res : out O_Tnode)
   is
      Count : unsigned;
      Types : TypeRefArray (1 .. 2);
      Pad : unsigned;
   begin
      if Elements.Align_Type = Null_TypeRef then
         --  An empty union.  Is it allowed ?
         Count := 0;
      else
         --  The first element is the field with the biggest alignment
         Types (1) := Elements.Align_Type;
         --  Possibly complete with an array of bytes.
         Pad := Elements.Size
           - unsigned (ABISizeOfType (Target_Data, Elements.Align_Type));
         if Pad /= 0 then
            Types (2) := ArrayType (Int8Type, Pad);
            Count := 2;
         else
            Count := 1;
         end if;
      end if;
      Res := new O_Tnode_Type'(Kind => ON_Union_Type,
                               LLVM => StructType (Types, Count, 0),
                               Dbg => Null_ValueRef,
                               Un_Size => Elements.Size,
                               Un_Main_Field => Elements.Align_Type);
   end Finish_Union_Type;

   ---------------------
   -- New_Access_Type --
   ---------------------

   function New_Access_Type (Dtype : O_Tnode) return O_Tnode is
   begin
      if Dtype = O_Tnode_Null then
         --  LLVM type will be built by New_Type_Decl, so that the name
         --  can be used for the structure.
         return new O_Tnode_Type'(Kind => ON_Incomplete_Access_Type,
                                  LLVM => Null_TypeRef,
                                  Dbg => Null_ValueRef,
                                  Acc_Type => O_Tnode_Null);
      else
         return new O_Tnode_Type'(Kind => ON_Access_Type,
                                  LLVM => PointerType (Get_LLVM_Type (Dtype)),
                                  Dbg => Null_ValueRef,
                                  Acc_Type => Dtype);
      end if;
   end New_Access_Type;

   ------------------------
   -- Finish_Access_Type --
   ------------------------

   procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode)
   is
      Types : TypeRefArray (1 .. 1);
   begin
      if Atype.Kind /= ON_Incomplete_Access_Type then
         --  Not an incomplete access type.
         raise Program_Error;
      end if;
      if Atype.Acc_Type /= O_Tnode_Null then
         --  Already completed.
         raise Program_Error;
      end if;
      --  Completion
      Types (1) := Get_LLVM_Type (Dtype);
      StructSetBody (GetElementType (Atype.LLVM), Types, Types'Length, 0);
      Atype.Acc_Type := Dtype;

      --  Debug.
      --  FIXME.
   end Finish_Access_Type;

   --------------------
   -- New_Array_Type --
   --------------------

   function Dbg_Array (El_Type : O_Tnode; Len : ValueRef; Atype : O_Tnode)
                      return ValueRef
   is
      Rng : ValueRefArray (0 .. 2);
      Rng_Arr : ValueRefArray (0 .. 0);
      Vals : ValueRefArray (0 .. 14);
   begin
      Rng := (ConstInt (Int32Type, DW_TAG_Subrange_Type, 0),
              ConstInt (Int64Type, 0, 0), -- Lo
              Len); -- Count
      Rng_Arr := (0 => MDNode (Rng, Rng'Length));
      Vals := (ConstInt (Int32Type, DW_TAG_Array_Type, 0),
               Null_ValueRef,
               Null_ValueRef,           --  context
               Null_ValueRef,
               ConstInt (Int32Type, 0, 0), -- line
               Dbg_Size (Atype.LLVM),
               Dbg_Align (Atype.LLVM),
               ConstInt (Int32Type, 0, 0),    --  Offset
               ConstInt (Int32Type, 0, 0),    --  Flags
               El_Type.Dbg, --  element type
               MDNode (Rng_Arr, Rng_Arr'Length), -- subscript
               ConstInt (Int32Type, 0, 0),
               Null_ValueRef,
               Null_ValueRef,
               Null_ValueRef); --  Runtime lang
      return MDNode (Vals, Vals'Length);
   end Dbg_Array;

   function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
                           return O_Tnode
   is
      pragma Unreferenced (Index_Type);
      Res : O_Tnode;
   begin
      Res := new O_Tnode_Type'
        (Kind => ON_Array_Type,
         LLVM => ArrayType (Get_LLVM_Type (El_Type), 0),
         Dbg => Null_ValueRef,
         Arr_El_Type => El_Type);

      if Flag_Debug then
         Res.Dbg := Dbg_Array
           (El_Type, ConstInt (Int64Type, Unsigned_64'Last, 1), Res);
      end if;

      return Res;
   end New_Array_Type;

   --------------------------------
   -- New_Constrained_Array_Type --
   --------------------------------

   function New_Constrained_Array_Type
     (Atype : O_Tnode; Length : O_Cnode) return O_Tnode
   is
      Res : O_Tnode;
      Len : constant unsigned := unsigned (ConstIntGetZExtValue (Length.LLVM));
   begin
      Res := new O_Tnode_Type'
        (Kind => ON_Array_Sub_Type,
         LLVM => ArrayType (GetElementType (Get_LLVM_Type (Atype)), Len),
         Dbg => Null_ValueRef,
         Arr_El_Type => Atype.Arr_El_Type);

      if Flag_Debug then
         Res.Dbg := Dbg_Array
           (Atype.Arr_El_Type,
            ConstInt (Int64Type, Unsigned_64 (Len), 0), Res);
      end if;

      return Res;
   end New_Constrained_Array_Type;

   -----------------------
   -- New_Unsigned_Type --
   -----------------------

   function Size_To_Llvm (Size : Natural) return TypeRef is
      Llvm : TypeRef;
   begin
      case Size is
         when 8 =>
            Llvm := Int8Type;
         when 32 =>
            Llvm := Int32Type;
         when 64 =>
            Llvm := Int64Type;
         when others =>
            raise Program_Error;
      end case;
      return Llvm;
   end Size_To_Llvm;

   function New_Unsigned_Type (Size : Natural) return O_Tnode is
   begin
      return new O_Tnode_Type'(Kind => ON_Unsigned_Type,
                               LLVM => Size_To_Llvm (Size),
                               Dbg => Null_ValueRef,
                               Scal_Size => Size);
   end New_Unsigned_Type;

   ---------------------
   -- New_Signed_Type --
   ---------------------

   function New_Signed_Type (Size : Natural) return O_Tnode is
   begin
      return new O_Tnode_Type'(Kind => ON_Signed_Type,
                               LLVM => Size_To_Llvm (Size),
                               Dbg => Null_ValueRef,
                               Scal_Size => Size);
   end New_Signed_Type;

   --------------------
   -- New_Float_Type --
   --------------------

   function New_Float_Type return O_Tnode is
   begin
      return new O_Tnode_Type'(Kind => ON_Float_Type,
                               LLVM => DoubleType,
                               Dbg => Null_ValueRef,
                               Scal_Size => 64);
   end New_Float_Type;

   procedure Dbg_Add_Enumeration (Id : O_Ident; Val : Unsigned_64) is
      Vals : ValueRefArray (0 .. 2);
   begin
      Vals := (ConstInt (Int32Type, DW_TAG_Enumerator, 0),
               MDString (Id),
               ConstInt (Int64Type, Val, 0));
      --  FIXME: make it local to List ?
      Append (Enum_Nodes, MDNode (Vals, Vals'Length));
   end Dbg_Add_Enumeration;


   ----------------------
   -- New_Boolean_Type --
   ----------------------

   procedure New_Boolean_Type
     (Res : out O_Tnode;
      False_Id : O_Ident; False_E : out O_Cnode;
      True_Id : O_Ident; True_E : out O_Cnode)
   is
   begin
      Res := new O_Tnode_Type'(Kind => ON_Boolean_Type,
                               LLVM => Int1Type,
                               Dbg => Null_ValueRef,
                               Scal_Size => 1);
      False_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 0, 0),
                          Ctype => Res);
      True_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 1, 0),
                         Ctype => Res);
      if Flag_Debug then
         Dbg_Add_Enumeration (False_Id, 0);
         Dbg_Add_Enumeration (True_Id, 1);
      end if;
   end New_Boolean_Type;

   ---------------------
   -- Start_Enum_Type --
   ---------------------

   procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural)
   is
      LLVM : constant TypeRef := Size_To_Llvm (Size);
   begin
      List := (LLVM => LLVM,
               Num => 0,
               Etype => new O_Tnode_Type'(Kind => ON_Enum_Type,
                                          LLVM => LLVM,
                                          Scal_Size => Size,
                                          Dbg => Null_ValueRef));

   end Start_Enum_Type;

   ----------------------
   -- New_Enum_Literal --
   ----------------------

   procedure New_Enum_Literal
     (List : in out O_Enum_List; Ident : O_Ident; Res : out O_Cnode)
   is
   begin
      Res := O_Cnode'(LLVM => ConstInt (List.LLVM, Unsigned_64 (List.Num), 0),
                      Ctype => List.Etype);
      if Flag_Debug then
         Dbg_Add_Enumeration (Ident, Unsigned_64 (List.Num));
      end if;

      List.Num := List.Num + 1;
   end New_Enum_Literal;

   ----------------------
   -- Finish_Enum_Type --
   ----------------------

   procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is
   begin
      Res := List.Etype;
   end Finish_Enum_Type;

   ------------------------
   -- New_Signed_Literal --
   ------------------------

   function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
                               return O_Cnode
   is
      function To_Unsigned_64 is new Ada.Unchecked_Conversion
        (Integer_64, Unsigned_64);
   begin
      return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype),
                                        To_Unsigned_64 (Value), 1),
                     Ctype => Ltype);
   end New_Signed_Literal;

   --------------------------
   -- New_Unsigned_Literal --
   --------------------------

   function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
                                 return O_Cnode is
   begin
      return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype), Value, 0),
                      Ctype => Ltype);
   end New_Unsigned_Literal;

   -----------------------
   -- New_Float_Literal --
   -----------------------

   function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
                              return O_Cnode is
   begin
      return O_Cnode'(LLVM => ConstReal (Get_LLVM_Type (Ltype),
                                         Interfaces.C.double (Value)),
                      Ctype => Ltype);
   end New_Float_Literal;

   ---------------------
   -- New_Null_Access --
   ---------------------

   function New_Null_Access (Ltype : O_Tnode) return O_Cnode is
   begin
      return O_Cnode'(LLVM => ConstNull (Get_LLVM_Type (Ltype)),
                      Ctype => Ltype);
   end New_Null_Access;

   -----------------------
   -- Start_Record_Aggr --
   -----------------------

   procedure Start_Record_Aggr
     (List : out O_Record_Aggr_List;
      Atype : O_Tnode)
   is
      Llvm : constant TypeRef := Get_LLVM_Type (Atype);
   begin
      List :=
        (Len => 0,
         Vals => new ValueRefArray (1 .. CountStructElementTypes (Llvm)),
         Atype => Atype);
   end Start_Record_Aggr;

   ------------------------
   -- New_Record_Aggr_El --
   ------------------------

   procedure New_Record_Aggr_El
     (List : in out O_Record_Aggr_List; Value : O_Cnode)
   is
   begin
      List.Len := List.Len + 1;
      List.Vals (List.Len) := Value.LLVM;
   end New_Record_Aggr_El;

   ------------------------
   -- Finish_Record_Aggr --
   ------------------------

   procedure Finish_Record_Aggr
     (List : in out O_Record_Aggr_List;
      Res : out O_Cnode)
   is
   begin
      Res := (LLVM => ConstStruct (List.Vals.all, List.Len, 0),
              Ctype => List.Atype);
      Free (List.Vals);
   end Finish_Record_Aggr;

   ----------------------
   -- Start_Array_Aggr --
   ----------------------

   procedure Start_Array_Aggr
     (List : out O_Array_Aggr_List;
      Atype : O_Tnode)
   is
      Llvm : constant TypeRef := Get_LLVM_Type (Atype);
   begin
      List := (Len => 0,
               Vals => new ValueRefArray (1 .. GetArrayLength (Llvm)),
               El_Type => GetElementType (Llvm),
               Atype => Atype);
   end Start_Array_Aggr;

   -----------------------
   -- New_Array_Aggr_El --
   -----------------------

   procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
                                Value : O_Cnode)
   is
   begin
      List.Len := List.Len + 1;
      List.Vals (List.Len) := Value.LLVM;
   end New_Array_Aggr_El;

   -----------------------
   -- Finish_Array_Aggr --
   -----------------------

   procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List;
                                Res : out O_Cnode)
   is
   begin
      Res := (LLVM => ConstArray (List.El_Type,
                                  List.Vals.all, List.Len),
             Ctype => List.Atype);
      Free (List.Vals);
   end Finish_Array_Aggr;

   --------------------
   -- New_Union_Aggr --
   --------------------

   function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
                           return O_Cnode
   is
      Values : ValueRefArray (1 .. 2);
      Count : unsigned;
      Size : constant unsigned :=
        unsigned (ABISizeOfType (Target_Data, Field.Utype));

   begin
      Values (1) := Value.LLVM;
      if Size < Atype.Un_Size then
         Values (2) := GetUndef (ArrayType (Int8Type, Atype.Un_Size - Size));
         Count := 2;
      else
         Count := 1;
      end if;

      --  If `FIELD` is the main field of the union, create a struct using
      --  the same type as the union (and possibly pad).
      if Field.Utype = Atype.Un_Main_Field then
         return O_Cnode'
           (LLVM => ConstNamedStruct (Atype.LLVM, Values, Count),
            Ctype => Atype);
      else
         --  Create an on-the-fly record.
         return O_Cnode'(LLVM => ConstStruct (Values, Count, 0),
                         Ctype => Atype);
      end if;
   end New_Union_Aggr;

   ----------------
   -- New_Sizeof --
   ----------------

   --  Return VAL with type RTYPE (either unsigned or access)
   function Const_To_Cnode (Rtype : O_Tnode; Val : Unsigned_64) return O_Cnode
   is
      Tmp : ValueRef;
   begin
      case Rtype.Kind is
         when ON_Scalar_Types =>
            --  Well, unsigned in fact.
            return O_Cnode'(LLVM => ConstInt (Rtype.LLVM, Val, 0),
                            Ctype => Rtype);
         when ON_Access_Type =>
            Tmp := ConstInt (Int64Type, Val, 0);
            return O_Cnode'(LLVM => ConstIntToPtr (Tmp, Rtype.LLVM),
                            Ctype => Rtype);
         when others =>
            raise Program_Error;
      end case;
   end Const_To_Cnode;

   function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
   begin
      return Const_To_Cnode
        (Rtype, ABISizeOfType (Target_Data, Get_LLVM_Type (Atype)));
   end New_Sizeof;

   -----------------
   -- New_Alignof --
   -----------------

   function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
   begin
      return Const_To_Cnode
        (Rtype,
         Unsigned_64
           (ABIAlignmentOfType (Target_Data, Get_LLVM_Type (Atype))));
   end New_Alignof;

   ------------------
   -- New_Offsetof --
   ------------------

   function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
                         return O_Cnode is
   begin
      return Const_To_Cnode
        (Rtype,
         OffsetOfElement (Target_Data,
                          Get_LLVM_Type (Atype),
                          Unsigned_32 (Field.Index)));
   end New_Offsetof;

   ----------------------------
   -- New_Subprogram_Address --
   ----------------------------

   function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
                                   return O_Cnode is
   begin
      return O_Cnode'
        (LLVM => ConstBitCast (Subprg.LLVM, Get_LLVM_Type (Atype)),
         Ctype => Atype);
   end New_Subprogram_Address;

   ------------------------
   -- New_Global_Address --
   ------------------------

   function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
                               return O_Cnode is
   begin
      return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
                      Ctype => Atype);
   end New_Global_Address;

   ----------------------------------
   -- New_Global_Unchecked_Address --
   ----------------------------------

   function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
                                         return O_Cnode
   is
   begin
      return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
                      Ctype => Atype);
   end New_Global_Unchecked_Address;

   -------------
   -- New_Lit --
   -------------

   function New_Lit (Lit : O_Cnode) return O_Enode is
   begin
      return O_Enode'(LLVM => Lit.LLVM,
                      Etype => Lit.Ctype);
   end New_Lit;

   -------------------
   -- New_Dyadic_Op --
   -------------------

   function New_Smod (L, R : ValueRef; Res_Type : TypeRef)
                     return ValueRef
   is
      Cond : ValueRef;
      Br : ValueRef;
      pragma Unreferenced (Br);

      --  The result of 'L rem R'.
      Rm : ValueRef;

      --  Rm + R
      Rm_Plus_R : ValueRef;

      --  The result of 'L xor R'.
      R_Xor : ValueRef;

      Adj : ValueRef;
      Phi : ValueRef;

      --  Basic basic for the non-overflow branch
      Normal_Bb : constant BasicBlockRef :=
        AppendBasicBlock (Cur_Func, Empty_Cstring);

      Adjust_Bb : constant BasicBlockRef :=
        AppendBasicBlock (Cur_Func, Empty_Cstring);

      --  Basic block after the result
      Next_Bb : constant BasicBlockRef :=
        AppendBasicBlock (Cur_Func, Empty_Cstring);

      Vals : ValueRefArray (1 .. 3);
      BBs  : BasicBlockRefArray (1 .. 3);
   begin
      --  Avoid overflow with -1:
      --   if R = -1 then
      --     result := 0;
      --   else
      --     ...
      Cond := BuildICmp
        (Builder, IntEQ, R, ConstAllOnes (Res_Type), Empty_Cstring);
      Br := BuildCondBr (Builder, Cond, Next_Bb, Normal_Bb);
      Vals (1) := ConstNull (Res_Type);
      BBs (1) := GetInsertBlock (Builder);

      --  Rm := Left rem Right
      PositionBuilderAtEnd (Builder, Normal_Bb);
      Rm := BuildSRem (Builder, L, R, Empty_Cstring);

      --  if R = 0 then
      --    result := 0
      --  else
      Cond := BuildICmp
        (Builder, IntEQ, Rm, ConstNull (Res_Type), Empty_Cstring);
      Br := BuildCondBr (Builder, Cond, Next_Bb, Adjust_Bb);
      Vals (2) := ConstNull (Res_Type);
      BBs (2) := Normal_Bb;

      --  if L xor R < 0 then
      --    result := Rm + R
      --  else
      --    result := Rm;
      --  end if;
      PositionBuilderAtEnd (Builder, Adjust_Bb);
      R_Xor := BuildXor (Builder, L, R, Empty_Cstring);
      Cond := BuildICmp
        (Builder, IntSLT, R_Xor, ConstNull (Res_Type), Empty_Cstring);
      Rm_Plus_R := BuildAdd (Builder, Rm, R, Empty_Cstring);
      Adj := BuildSelect (Builder, Cond, Rm_Plus_R, Rm, Empty_Cstring);
      Br := BuildBr (Builder, Next_Bb);
      Vals (3) := Adj;
      BBs (3) := Adjust_Bb;

      --  The Phi node
      PositionBuilderAtEnd (Builder, Next_Bb);
      Phi := BuildPhi (Builder, Res_Type, Empty_Cstring);
      AddIncoming (Phi, Vals, BBs, Vals'Length);

      return Phi;
   end New_Smod;

   type Dyadic_Builder_Acc is access
     function (Builder : BuilderRef;
               LHS : ValueRef; RHS : ValueRef; Name : Cstring)
              return ValueRef;
   pragma Convention (C, Dyadic_Builder_Acc);

   function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
                          return O_Enode
   is
      Build : Dyadic_Builder_Acc := null;
      Res : ValueRef := Null_ValueRef;
   begin
      if Unreach then
         return O_Enode'(LLVM => Null_ValueRef, Etype => Left.Etype);
      end if;

      case Left.Etype.Kind is
         when ON_Integer_Types =>
            case Kind is
               when ON_And =>
                  Build := BuildAnd'Access;
               when ON_Or =>
                  Build := BuildOr'Access;
               when ON_Xor =>
                  Build := BuildXor'Access;

               when ON_Add_Ov =>
                  Build := BuildAdd'Access;
               when ON_Sub_Ov =>
                  Build := BuildSub'Access;
               when ON_Mul_Ov =>
                  Build := BuildMul'Access;

               when ON_Div_Ov =>
                  case Left.Etype.Kind is
                     when ON_Unsigned_Type =>
                        Build := BuildUDiv'Access;
                     when ON_Signed_Type =>
                        Build := BuildSDiv'Access;
                     when others =>
                        null;
                  end case;

               when ON_Mod_Ov
                 | ON_Rem_Ov => -- FIXME...
                  case Left.Etype.Kind is
                     when ON_Unsigned_Type =>
                        Build := BuildURem'Access;
                     when ON_Signed_Type =>
                        if Kind = ON_Rem_Ov then
                           Build := BuildSRem'Access;
                        else
                           Res := New_Smod
                             (Left.LLVM, Right.LLVM, Left.Etype.LLVM);
                        end if;
                     when others =>
                        null;
                  end case;
            end case;

         when ON_Float_Type =>
            case Kind is
               when ON_Add_Ov =>
                  Build := BuildFAdd'Access;
               when ON_Sub_Ov =>
                  Build := BuildFSub'Access;
               when ON_Mul_Ov =>
                  Build := BuildFMul'Access;
               when ON_Div_Ov =>
                  Build := BuildFDiv'Access;

               when others =>
                  null;
            end case;

         when others =>
            null;
      end case;

      if Build /= null then
         pragma Assert (Res = Null_ValueRef);
         Res := Build.all (Builder,  Left.LLVM, Right.LLVM, Empty_Cstring);
      end if;

      if Res = Null_ValueRef then
         raise Program_Error with "Unimplemented New_Dyadic_Op "
           & ON_Dyadic_Op_Kind'Image (Kind)
           & " for type "
           & ON_Type_Kind'Image (Left.Etype.Kind);
      end if;

      Set_Insn_Dbg (Res);

      return O_Enode'(LLVM => Res, Etype => Left.Etype);
   end New_Dyadic_Op;

   --------------------
   -- New_Monadic_Op --
   --------------------

   function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
                           return O_Enode
   is
      Res : ValueRef;
   begin
      case Operand.Etype.Kind is
         when ON_Integer_Types =>
            case Kind is
               when ON_Not =>
                  Res := BuildNot (Builder, Operand.LLVM, Empty_Cstring);
               when ON_Neg_Ov =>
                  Res := BuildNeg (Builder, Operand.LLVM, Empty_Cstring);
               when ON_Abs_Ov =>
                  --  FIXME: float ?
                  Res := BuildSelect
                    (Builder,
                     BuildICmp (Builder, IntSLT,
                                Operand.LLVM,
                                ConstInt (Get_LLVM_Type (Operand.Etype), 0, 0),
                                Empty_Cstring),
                     BuildNeg (Builder, Operand.LLVM, Empty_Cstring),
                     Operand.LLVM,
                     Empty_Cstring);
            end case;
         when ON_Float_Type =>
            case Kind is
               when ON_Not =>
                  raise Program_Error;
               when ON_Neg_Ov =>
                  Res := BuildFNeg (Builder, Operand.LLVM, Empty_Cstring);
               when ON_Abs_Ov =>
                  Res := BuildSelect
                    (Builder,
                     BuildFCmp (Builder, RealOLT,
                                Operand.LLVM,
                                ConstReal (Get_LLVM_Type (Operand.Etype), 0.0),
                                Empty_Cstring),
                     BuildFNeg (Builder, Operand.LLVM, Empty_Cstring),
                     Operand.LLVM,
                     Empty_Cstring);
            end case;
         when others =>
            raise Program_Error;
      end case;

      if IsAInstruction (Res) /= Null_ValueRef then
         Set_Insn_Dbg (Res);
      end if;

      return O_Enode'(LLVM => Res, Etype => Operand.Etype);
   end New_Monadic_Op;

   --------------------
   -- New_Compare_Op --
   --------------------

   type Compare_Op_Entry is record
      Signed_Pred   : IntPredicate;
      Unsigned_Pred : IntPredicate;
      Real_Pred     : RealPredicate;
   end record;

   type Compare_Op_Table_Type is array (ON_Compare_Op_Kind) of
     Compare_Op_Entry;

   Compare_Op_Table : constant Compare_Op_Table_Type :=
     (ON_Eq  => (IntEQ,  IntEQ,  RealOEQ),
      ON_Neq => (IntNE,  IntNE,  RealONE),
      ON_Le  => (IntSLE, IntULE, RealOLE),
      ON_Lt  => (IntSLT, IntULT, RealOLT),
      ON_Ge  => (IntSGE, IntUGE, RealOGE),
      ON_Gt  => (IntSGT, IntUGT, RealOGT));

   function New_Compare_Op
     (Kind : ON_Compare_Op_Kind;
      Left, Right : O_Enode;
      Ntype : O_Tnode)
      return O_Enode
   is
      Res : ValueRef;
   begin
      case Left.Etype.Kind is
         when ON_Unsigned_Type
           | ON_Boolean_Type
           | ON_Enum_Type
           | ON_Access_Type
           | ON_Incomplete_Access_Type =>
            Res := BuildICmp (Builder, Compare_Op_Table (Kind).Unsigned_Pred,
                              Left.LLVM, Right.LLVM, Empty_Cstring);
         when ON_Signed_Type =>
            Res := BuildICmp (Builder, Compare_Op_Table (Kind).Signed_Pred,
                              Left.LLVM, Right.LLVM, Empty_Cstring);
         when ON_Float_Type =>
            Res := BuildFCmp (Builder, Compare_Op_Table (Kind).Real_Pred,
                              Left.LLVM, Right.LLVM, Empty_Cstring);
         when ON_Array_Type
           | ON_Array_Sub_Type
           | ON_Record_Type
           | ON_Incomplete_Record_Type
           | ON_Union_Type
           | ON_No_Type =>
            raise Program_Error;
      end case;
      Set_Insn_Dbg (Res);
      return O_Enode'(LLVM => Res, Etype => Ntype);
   end New_Compare_Op;

   -------------------------
   -- New_Indexed_Element --
   -------------------------

   function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) return O_Lnode
   is
      Idx : constant ValueRefArray (1 .. 2) :=
        (ConstInt (Int32Type, 0, 0),
         Index.LLVM);
   begin
      return O_Lnode'
        (Direct => False,
         LLVM => BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring),
         Ltype => Arr.Ltype.Arr_El_Type);
   end New_Indexed_Element;

   ---------------
   -- New_Slice --
   ---------------

   function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
      return O_Lnode
   is
      Idx : constant ValueRefArray (1 .. 2) :=
        (ConstInt (Int32Type, 0, 0),
         Index.LLVM);
      Tmp : ValueRef;
   begin
      Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring);
      Tmp := BuildBitCast
        (Builder, Tmp, PointerType (Get_LLVM_Type (Res_Type)), Empty_Cstring);
      return O_Lnode'(Direct => False, LLVM => Tmp, Ltype => Res_Type);
   end New_Slice;

   --------------------------
   -- New_Selected_Element --
   --------------------------

   function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
                                 return O_Lnode
   is
      Res : ValueRef;
   begin
      if Unreach then
         Res := Null_ValueRef;
      else
         declare
            Idx : constant ValueRefArray (1 .. 2) :=
              (ConstInt (Int32Type, 0, 0),
               ConstInt (Int32Type, Unsigned_64 (El.Index), 0));
         begin
            Res := BuildGEP (Builder, Rec.LLVM, Idx, 2, Empty_Cstring);
         end;
      end if;
      return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype);
   end New_Selected_Element;

   ------------------------
   -- New_Access_Element --
   ------------------------

   function New_Access_Element (Acc : O_Enode) return O_Lnode
   is
      Res : ValueRef;
   begin
      case Acc.Etype.Kind is
         when ON_Access_Type =>
            Res := Acc.LLVM;
         when ON_Incomplete_Access_Type =>
            --  Unwrap the structure
            declare
               Idx : constant ValueRefArray (1 .. 2) :=
                 (ConstInt (Int32Type, 0, 0), ConstInt (Int32Type, 0, 0));
            begin
               Res := BuildGEP (Builder, Acc.LLVM, Idx, 2, Empty_Cstring);
            end;
         when others =>
            raise Program_Error;
      end case;
      return O_Lnode'(Direct => False,
                      LLVM => Res,
                      Ltype => Acc.Etype.Acc_Type);
   end New_Access_Element;

   --------------------
   -- New_Convert_Ov --
   --------------------

   function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode
   is
      Res : ValueRef := Null_ValueRef;
   begin
      if Rtype = Val.Etype then
         --  Convertion to itself: nothing to do.
         return Val;
      end if;
      if Rtype.LLVM = Val.Etype.LLVM then
         --  Same underlying LLVM type: nothing to do.
         return Val;
      end if;

      case Rtype.Kind is
         when ON_Integer_Types =>
            case Val.Etype.Kind is
               when ON_Integer_Types =>
                  --  Int to Int
                  if Val.Etype.Scal_Size > Rtype.Scal_Size then
                     --  Truncate
                     Res := BuildTrunc
                       (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
                        Empty_Cstring);
                  elsif Val.Etype.Scal_Size < Rtype.Scal_Size then
                     if Val.Etype.Kind = ON_Signed_Type then
                        Res := BuildSExt
                          (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
                           Empty_Cstring);
                     else
                        --  Unsigned, enum
                        Res := BuildZExt
                          (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
                           Empty_Cstring);
                     end if;
                  else
                     Res := BuildBitCast
                       (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
                        Empty_Cstring);
                  end if;

               when ON_Float_Type =>
                  --  Float to Int
                  if Rtype.Kind = ON_Signed_Type then
                     Res := BuildFPToSI
                       (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
                        Empty_Cstring);
                  end if;

               when others =>
                  null;
            end case;

         when ON_Float_Type =>
            if Val.Etype.Kind = ON_Signed_Type then
               Res := BuildSIToFP
                 (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
                  Empty_Cstring);
            elsif Val.Etype.Kind = ON_Unsigned_Type then
               Res := BuildUIToFP
                 (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
                  Empty_Cstring);
            end if;

         when ON_Access_Type
           | ON_Incomplete_Access_Type =>
            if GetTypeKind (TypeOf (Val.LLVM)) /= PointerTypeKind then
               raise Program_Error;
            end if;
            Res := BuildBitCast (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
                                 Empty_Cstring);

         when others =>
            null;
      end case;
      if Res /= Null_ValueRef then
         --  FIXME: only if insn was generated
         --  Set_Insn_Dbg (Res);
         return O_Enode'(LLVM => Res, Etype => Rtype);
      else
         raise Program_Error with "New_Convert_Ov: not implemented for "
           & ON_Type_Kind'Image (Val.Etype.Kind)
           & " -> "
           & ON_Type_Kind'Image (Rtype.Kind);
      end if;
   end New_Convert_Ov;

   -----------------
   -- New_Address --
   -----------------

   function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is
   begin
      return O_Enode'
        (LLVM => BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype),
                               Empty_Cstring),
         Etype => Atype);
   end New_Address;

   ---------------------------
   -- New_Unchecked_Address --
   ---------------------------

   function New_Unchecked_Address  (Lvalue : O_Lnode; Atype : O_Tnode)
                                   return O_Enode
   is
   begin
      return O_Enode'
        (LLVM => BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype),
                               Empty_Cstring),
         Etype => Atype);
   end New_Unchecked_Address;

   ---------------
   -- New_Value --
   ---------------

   function New_Value (Lvalue : O_Lnode) return O_Enode
   is
      Res : ValueRef;
   begin
      if Unreach then
         Res := Null_ValueRef;
      else
         Res := Lvalue.LLVM;
         if not Lvalue.Direct then
            Res := BuildLoad (Builder, Res, Empty_Cstring);
            Set_Insn_Dbg (Res);
         end if;
      end if;
      return O_Enode'(LLVM => Res, Etype => Lvalue.Ltype);
   end New_Value;

   -------------------
   -- New_Obj_Value --
   -------------------

   function New_Obj_Value (Obj : O_Dnode) return O_Enode is
   begin
      return New_Value (New_Obj (Obj));
   end New_Obj_Value;

   -------------
   -- New_Obj --
   -------------

   function New_Obj (Obj : O_Dnode) return O_Lnode is
   begin
      case Obj.Kind is
         when ON_Const_Decl
           | ON_Var_Decl
           | ON_Local_Decl =>
            return O_Lnode'(Direct => False,
                            LLVM => Obj.LLVM,
                            Ltype => Obj.Dtype);

         when ON_Interface_Decl =>
            if Flag_Debug then
               --  The argument was allocated.
               return O_Lnode'(Direct => False,
                               LLVM => Obj.Inter.Ival,
                               Ltype => Obj.Dtype);
            else
               return O_Lnode'(Direct => True,
                               LLVM => Obj.Inter.Ival,
                               Ltype => Obj.Dtype);
            end if;

         when ON_Type_Decl
           | ON_Completed_Type_Decl
           | ON_Subprg_Decl
           | ON_No_Decl =>
            raise Program_Error;
      end case;
   end New_Obj;

   ----------------
   -- New_Alloca --
   ----------------

   function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode
   is
      Res : ValueRef;
   begin
      Res := BuildArrayAlloca (Builder, Int8Type, Size.LLVM, Empty_Cstring);
      Set_Insn_Dbg (Res);
      Res := BuildBitCast (Builder, Res, Get_LLVM_Type (Rtype), Empty_Cstring);
      Set_Insn_Dbg (Res);
      return O_Enode'(LLVM => Res, Etype => Rtype);
   end New_Alloca;

   -------------------
   -- New_Type_Decl --
   -------------------

   function Add_Dbg_Basic_Type (Id : O_Ident; Btype : O_Tnode; Enc : Natural)
                               return ValueRef
   is
      Vals : ValueRefArray (0 .. 9);
   begin
      Vals := (ConstInt (Int32Type, DW_TAG_Base_Type, 0),
               Null_ValueRef,
               Null_ValueRef,
               MDString (Id),
               ConstInt (Int32Type, 0, 0),    -- linenum
               Dbg_Size (Btype.LLVM),
               Dbg_Align (Btype.LLVM),
               ConstInt (Int32Type, 0, 0),    --  Offset
               ConstInt (Int32Type, 0, 0),    --  Flags
               ConstInt (Int32Type, Unsigned_64 (Enc), 0)); --  Encoding
      return MDNode (Vals, Vals'Length);
   end Add_Dbg_Basic_Type;

   function Add_Dbg_Enum_Type (Id : O_Ident; Etype : O_Tnode) return ValueRef
   is
      Vals : ValueRefArray (0 .. 14);
   begin
      Vals := (ConstInt (Int32Type, DW_TAG_Enumeration_Type, 0),
               Dbg_Current_Filedir,
               Null_ValueRef,           --  context
               MDString (Id),
               Dbg_Line,
               Dbg_Size (Etype.LLVM),
               Dbg_Align (Etype.LLVM),
               ConstInt (Int32Type, 0, 0),    --  Offset
               ConstInt (Int32Type, 0, 0),    --  Flags
               Null_ValueRef,
               Get_Value (Enum_Nodes),
               ConstInt (Int32Type, 0, 0),
               Null_ValueRef,
               Null_ValueRef,
               Null_ValueRef); --  Runtime lang
      Clear (Enum_Nodes);
      return MDNode (Vals, Vals'Length);
   end Add_Dbg_Enum_Type;

   function Add_Dbg_Pointer_Type (Id : O_Ident; Ptype : O_Tnode)
                                 return ValueRef
   is
      Vals : ValueRefArray (0 .. 9);
   begin
      pragma Assert (Ptype.Acc_Type.Dbg /= Null_ValueRef);

      Vals := (ConstInt (Int32Type, DW_TAG_Pointer_Type, 0),
               Dbg_Current_Filedir,
               Null_ValueRef,           --  context
               MDString (Id),
               Dbg_Line,
               Dbg_Size (Ptype.LLVM),
               Dbg_Align (Ptype.LLVM),
               ConstInt (Int32Type, 0, 0),    --  Offset
               ConstInt (Int32Type, 1024, 0),    --  Flags
               Ptype.Acc_Type.Dbg);
      return MDNode (Vals, Vals'Length);
   end Add_Dbg_Pointer_Type;

   function Add_Dbg_Record_Type (Id : O_Ident; Rtype : O_Tnode)
                                return ValueRef
   is
      Vals : ValueRefArray (0 .. 14);
   begin
      Vals := (ConstInt (Int32Type, DW_TAG_Structure_Type, 0),
               Dbg_Current_Filedir,
               Null_ValueRef,           --  context
               MDString (Id),
               Dbg_Line,
               Null_ValueRef,  --  5: Size
               Null_ValueRef,  --  6: Align
               ConstInt (Int32Type, 0, 0),    --  Offset
               ConstInt (Int32Type, 1024, 0),    --  Flags
               Null_ValueRef,
               Null_ValueRef, -- 10
               ConstInt (Int32Type, 0, 0),    --  Runtime lang
               Null_ValueRef, -- Vtable Holder
               Null_ValueRef, -- ?
               Null_ValueRef); -- Uniq Id
      if Rtype /= O_Tnode_Null then
         Vals (5) := Dbg_Size (Rtype.LLVM);
         Vals (6) := Dbg_Align (Rtype.LLVM);
         Vals (10) := Rtype.Dbg;
      end if;

      return MDNode (Vals, Vals'Length);
   end Add_Dbg_Record_Type;

   procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is
   begin
      case Atype.Kind is
         when ON_Incomplete_Record_Type =>
            Atype.LLVM :=
              StructCreateNamed (GetGlobalContext, Get_Cstring (Ident));
         when ON_Incomplete_Access_Type =>
            Atype.LLVM := PointerType
              (StructCreateNamed (GetGlobalContext, Get_Cstring (Ident)));
         when others =>
            null;
      end case;

      --  Emit debug info
      if Flag_Debug then
         case Atype.Kind is
            when ON_Unsigned_Type =>
               Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_unsigned);
            when ON_Signed_Type =>
               Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_signed);
            when ON_Float_Type =>
               Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_float);
            when ON_Enum_Type =>
               Atype.Dbg := Add_Dbg_Enum_Type (Ident, Atype);
            when ON_Boolean_Type =>
               Atype.Dbg := Add_Dbg_Enum_Type (Ident, Atype);
            when ON_Access_Type =>
               Atype.Dbg := Add_Dbg_Pointer_Type (Ident, Atype);
            when ON_Record_Type =>
               Atype.Dbg := Add_Dbg_Record_Type (Ident, Atype);
            when ON_Incomplete_Record_Type =>
               Atype.Dbg := Add_Dbg_Record_Type (Ident, O_Tnode_Null);
            when ON_Array_Type
              | ON_Array_Sub_Type =>
               --  FIXME: typedef
               null;
            when ON_Incomplete_Access_Type =>
               --  FIXME: todo
               null;
            when ON_Union_Type =>
               --  FIXME: todo
               null;
            when ON_No_Type =>
               raise Program_Error;
         end case;
      end if;
   end New_Type_Decl;

   -----------------------------
   -- New_Debug_Filename_Decl --
   -----------------------------

   procedure New_Debug_Filename_Decl (Filename : String) is
      Vals : ValueRefArray (1 .. 2);
   begin
      if Flag_Debug then
         Vals := (MDString (Filename),
                  MDString (Current_Directory));
         Dbg_Current_Filedir := MDNode (Vals, 2);

         Vals := (ConstInt (Int32Type, DW_TAG_File_Type, 0),
                  Dbg_Current_Filedir);
         Dbg_Current_File := MDNode (Vals, 2);
      end if;
   end New_Debug_Filename_Decl;

   -------------------------
   -- New_Debug_Line_Decl --
   -------------------------

   procedure New_Debug_Line_Decl (Line : Natural) is
   begin
      Dbg_Current_Line := unsigned (Line);
   end New_Debug_Line_Decl;

   ----------------------------
   -- New_Debug_Comment_Decl --
   ----------------------------

   procedure New_Debug_Comment_Decl (Comment : String) is
   begin
      null;
   end New_Debug_Comment_Decl;

   --------------------
   -- New_Const_Decl --
   --------------------

   procedure Dbg_Add_Global_Var (Id : O_Ident;
                                 Atype : O_Tnode;
                                 Storage : O_Storage;
                                 Decl : O_Dnode)
   is
      pragma Assert (Atype.Dbg /= Null_ValueRef);
      Vals : ValueRefArray (0 .. 12);
      Name : constant ValueRef := MDString (Id);
      Is_Local : constant Boolean := Storage = O_Storage_Private;
      Is_Def : constant Boolean := Storage /= O_Storage_External;
   begin
      Vals :=
        (ConstInt (Int32Type, DW_TAG_Variable, 0),
         Null_ValueRef,
         Null_ValueRef, -- context
         Name,
         Name,
         Null_ValueRef, -- linkageName
         Dbg_Current_File,
         Dbg_Line,
         Atype.Dbg,
         ConstInt (Int1Type, Boolean'Pos (Is_Local), 0), -- isLocal
         ConstInt (Int1Type, Boolean'Pos (Is_Def), 0), -- isDef
         Decl.LLVM,
         Null_ValueRef);
      Append (Global_Nodes, MDNode (Vals, Vals'Length));
   end Dbg_Add_Global_Var;

   procedure New_Const_Decl
     (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode)
   is
      Decl : ValueRef;
   begin
      if Storage = O_Storage_External then
         Decl := GetNamedGlobal (Module, Get_Cstring (Ident));
      else
         Decl := Null_ValueRef;
      end if;
      if Decl = Null_ValueRef then
         Decl := AddGlobal
           (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident));
      end if;

      Res := (Kind => ON_Const_Decl, LLVM => Decl, Dtype => Atype);
      SetGlobalConstant (Res.LLVM, 1);
      if Storage = O_Storage_Private then
         SetLinkage (Res.LLVM, InternalLinkage);
      end if;
      if Flag_Debug then
         Dbg_Add_Global_Var (Ident, Atype, Storage, Res);
      end if;
   end New_Const_Decl;

   -----------------------
   -- Start_Const_Value --
   -----------------------

   procedure Start_Const_Value (Const : in out O_Dnode) is
   begin
      null;
   end Start_Const_Value;

   ------------------------
   -- Finish_Const_Value --
   ------------------------

   procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) is
   begin
      SetInitializer (Const.LLVM, Val.LLVM);
   end Finish_Const_Value;

   ------------------
   -- New_Var_Decl --
   ------------------

   procedure New_Var_Decl
     (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode)
   is
      Decl : ValueRef;
   begin
      if Storage = O_Storage_Local then
         Res := (Kind => ON_Local_Decl,
                 LLVM => BuildAlloca
                   (Decl_Builder, Get_LLVM_Type (Atype), Get_Cstring (Ident)),
                 Dtype => Atype);
         if Flag_Debug then
            Dbg_Create_Variable (DW_TAG_Auto_Variable,
                                 Ident, Atype, 0, Res.LLVM);
         end if;
      else
         if Storage = O_Storage_External then
            Decl := GetNamedGlobal (Module, Get_Cstring (Ident));
         else
            Decl := Null_ValueRef;
         end if;
         if Decl = Null_ValueRef then
            Decl := AddGlobal
              (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident));
         end if;

         Res := (Kind => ON_Var_Decl, LLVM => Decl, Dtype => Atype);

         --  Set linkage.
         case Storage is
            when O_Storage_Private =>
               SetLinkage (Res.LLVM, InternalLinkage);
            when O_Storage_Public
              | O_Storage_External =>
               null;
            when O_Storage_Local =>
               raise Program_Error;
         end case;

         --  Set initializer.
         case Storage is
            when O_Storage_Private
              | O_Storage_Public =>
               SetInitializer (Res.LLVM, ConstNull (Get_LLVM_Type (Atype)));
            when O_Storage_External =>
               null;
            when O_Storage_Local =>
               raise Program_Error;
         end case;

         if Flag_Debug then
            Dbg_Add_Global_Var (Ident, Atype, Storage, Res);
         end if;
      end if;
   end New_Var_Decl;

   -------------------------
   -- Start_Function_Decl --
   -------------------------

   procedure Start_Function_Decl
     (Interfaces : out O_Inter_List;
      Ident : O_Ident;
      Storage : O_Storage;
      Rtype : O_Tnode)
   is
   begin
      Interfaces := (Ident => Ident,
                     Storage => Storage,
                     Res_Type => Rtype,
                     Nbr_Inter => 0,
                     First_Inter => null,
                     Last_Inter => null);
   end Start_Function_Decl;

   --------------------------
   -- Start_Procedure_Decl --
   --------------------------

   procedure Start_Procedure_Decl
     (Interfaces : out O_Inter_List;
      Ident : O_Ident;
      Storage : O_Storage)
   is
   begin
      Interfaces := (Ident => Ident,
                     Storage => Storage,
                     Res_Type => O_Tnode_Null,
                     Nbr_Inter => 0,
                     First_Inter => null,
                     Last_Inter => null);
   end Start_Procedure_Decl;

   ------------------------
   -- New_Interface_Decl --
   ------------------------

   procedure New_Interface_Decl
     (Interfaces : in out O_Inter_List;
      Res : out O_Dnode;
      Ident : O_Ident;
      Atype : O_Tnode)
   is
      Inter : constant O_Inter_Acc := new O_Inter'(Itype => Atype,
                                                   Ival => Null_ValueRef,
                                                   Ident => Ident,
                                                   Next => null);
   begin
      Res := (Kind => ON_Interface_Decl,
              Dtype => Atype,
              LLVM => Null_ValueRef,
              Inter => Inter);
      Interfaces.Nbr_Inter := Interfaces.Nbr_Inter + 1;
      if Interfaces.First_Inter = null then
         Interfaces.First_Inter := Inter;
      else
         Interfaces.Last_Inter.Next := Inter;
      end if;
      Interfaces.Last_Inter := Inter;
   end New_Interface_Decl;

   ----------------------------
   -- Finish_Subprogram_Decl --
   ----------------------------

   procedure Finish_Subprogram_Decl
     (Interfaces : in out O_Inter_List;
      Res : out O_Dnode)
   is
      Count : constant unsigned := unsigned (Interfaces.Nbr_Inter);
      Inter : O_Inter_Acc;
      Types : TypeRefArray (1 .. Count);
      Ftype : TypeRef;
      Rtype : TypeRef;
      Decl : ValueRef;
      Id : constant Cstring := Get_Cstring (Interfaces.Ident);
   begin
      --  Fill Types (from interfaces list)
      Inter := Interfaces.First_Inter;
      for I in 1 .. Count loop
         Types (I) := Inter.Itype.LLVM;
         Inter := Inter.Next;
      end loop;

      --  Build function type.
      if Interfaces.Res_Type = O_Tnode_Null then
         Rtype := VoidType;
      else
         Rtype := Interfaces.Res_Type.LLVM;
      end if;
      Ftype := FunctionType (Rtype, Types, Count, 0);

      if Interfaces.Storage = O_Storage_External then
         Decl := GetNamedFunction (Module, Id);
      else
         Decl := Null_ValueRef;
      end if;
      if Decl = Null_ValueRef then
         Decl := AddFunction (Module, Id, Ftype);
      end if;

      Res := (Kind => ON_Subprg_Decl,
              Dtype => Interfaces.Res_Type,
              Subprg_Id => Interfaces.Ident,
              Nbr_Args => Count,
              Subprg_Inters => Interfaces.First_Inter,
              LLVM => Decl);
      SetFunctionCallConv (Res.LLVM, CCallConv);

      --  Translate interfaces.
      Inter := Interfaces.First_Inter;
      for I in 1 .. Count loop
         Inter.Ival := GetParam (Res.LLVM, I - 1);
         SetValueName (Inter.Ival, Get_Cstring (Inter.Ident));
         Inter := Inter.Next;
      end loop;
   end Finish_Subprogram_Decl;

   ---------------------------
   -- Start_Subprogram_Body --
   ---------------------------

   procedure Start_Subprogram_Body (Func : O_Dnode)
   is
      --  Basic block at function entry that contains all the declarations.
      Decl_BB : BasicBlockRef;
   begin
      if Cur_Func /= Null_ValueRef then
         --  No support for nested subprograms.
         raise Program_Error;
      end if;

      Cur_Func := Func.LLVM;
      Cur_Func_Decl := Func;
      Unreach := False;

      Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring);
      PositionBuilderAtEnd (Decl_Builder, Decl_BB);

      Create_Declare_Block;

      PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb);

      if Flag_Debug then
         declare
            Type_Vals : ValueRefArray (0 .. Func.Nbr_Args);
            Vals : ValueRefArray (0 .. 14);
            Arg : O_Inter_Acc;
            Subprg_Type : ValueRef;

            Subprg_Vals : ValueRefArray (0 .. 19);
            Name : ValueRef;
         begin
            Arg := Func.Subprg_Inters;
            if Func.Dtype /= O_Tnode_Null then
               Type_Vals (0) := Func.Dtype.Dbg;
            else
               --  Void
               Type_Vals (0) := Null_ValueRef;
            end if;
            for I in 1 .. Type_Vals'Last loop
               Type_Vals (I) := Arg.Itype.Dbg;
               Arg := Arg.Next;
            end loop;
            Vals :=
              (ConstInt (Int32Type, DW_TAG_Subroutine_Type, 0),
               ConstInt (Int32Type, 0, 0),  --  1 ??
               Null_ValueRef,               --  2 Context
               MDString (Empty_Cstring, 0), --  3 name
               ConstInt (Int32Type, 0, 0),  --  4 linenum
               ConstInt (Int64Type, 0, 0),  --  5 size
               ConstInt (Int64Type, 0, 0),  --  6 align
               ConstInt (Int64Type, 0, 0),  --  7 offset
               ConstInt (Int32Type, 0, 0),  --  8 flags
               Null_ValueRef,               --  9 derived from
               MDNode (Type_Vals, Type_Vals'Length), --  10 type
               ConstInt (Int32Type, 0, 0),  --  11 runtime lang
               Null_ValueRef,               --  12 containing type
               Null_ValueRef,               --  13 template params
               Null_ValueRef);              --  14 ??
            Subprg_Type := MDNode (Vals, Vals'Length);

            --  Create TAG_subprogram.
            Name := MDString (Func.Subprg_Id);

            Subprg_Vals :=
              (ConstInt (Int32Type, DW_TAG_Subprogram, 0),
               Dbg_Current_Filedir,             --  1 loc
               Dbg_Current_File,                --  2 context
               Name,                            --  3 name
               Name,                            --  4 display name
               Null_ValueRef,                   --  5 linkage name
               Dbg_Line,                        --  6 line num
               Subprg_Type,                     --  7 type
               ConstInt (Int1Type, 0, 0),       --  8 islocal (FIXME)
               ConstInt (Int1Type, 1, 0),       --  9 isdef (FIXME)
               ConstInt (Int32Type, 0, 0),      --  10 virtuality
               ConstInt (Int32Type, 0, 0),      --  11 virtual index
               Null_ValueRef,                   --  12 containing type
               ConstInt (Int32Type, 256, 0),    --  13 flags: prototyped
               ConstInt (Int1Type, 0, 0),       --  14 isOpt (FIXME)
               Cur_Func,                        --  15 function
               Null_ValueRef,                   --  16 template param
               Null_ValueRef,                   --  17 function decl
               Null_ValueRef,                   --  18 variables ???
               Dbg_Line);                       --  19 scope ln
            Cur_Declare_Block.Dbg_Scope :=
              MDNode (Subprg_Vals, Subprg_Vals'Length);
            Append (Subprg_Nodes, Cur_Declare_Block.Dbg_Scope);
            Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope;
         end;

         --  Create local variables for arguments.
         declare
            Arg : O_Inter_Acc;
            Tmp : ValueRef;
            St : ValueRef;
            pragma Unreferenced (St);
            Argno : Natural;
         begin
            Arg := Func.Subprg_Inters;
            Argno := 1;
            while Arg /= null loop
               Tmp := BuildAlloca (Decl_Builder, Get_LLVM_Type (Arg.Itype),
                                   Empty_Cstring);
               Dbg_Create_Variable (DW_TAG_Arg_Variable,
                                    Arg.Ident, Arg.Itype, Argno, Tmp);
               St := BuildStore (Decl_Builder, Arg.Ival, Tmp);
               Arg.Ival := Tmp;

               Arg := Arg.Next;
               Argno := Argno + 1;
            end loop;
         end;
      end if;
   end Start_Subprogram_Body;

   ----------------------------
   -- Finish_Subprogram_Body --
   ----------------------------

   procedure Finish_Subprogram_Body is
      Ret : ValueRef;
      pragma Unreferenced (Ret);
   begin
      --  Add a jump from the declare basic block to the first statement BB.
      Ret := BuildBr (Decl_Builder, Cur_Declare_Block.Stmt_Bb);

      --  Terminate the statement BB.
      if not Unreach then
         if Cur_Func_Decl.Dtype = O_Tnode_Null then
            Ret := BuildRetVoid (Builder);
         else
            Ret := BuildUnreachable (Builder);
         end if;
      end if;

      Destroy_Declare_Block;

      Cur_Func := Null_ValueRef;
      Dbg_Current_Scope := Null_ValueRef;
   end Finish_Subprogram_Body;

   -------------------------
   -- New_Debug_Line_Stmt --
   -------------------------

   procedure New_Debug_Line_Stmt (Line : Natural) is
   begin
      Dbg_Current_Line := unsigned (Line);
   end New_Debug_Line_Stmt;

   ----------------------------
   -- New_Debug_Comment_Stmt --
   ----------------------------

   procedure New_Debug_Comment_Stmt (Comment : String) is
   begin
      null;
   end New_Debug_Comment_Stmt;

   ------------------------
   -- Start_Declare_Stmt --
   ------------------------

   procedure Start_Declare_Stmt
   is
      Br : ValueRef;
      pragma Unreferenced (Br);
   begin
      Create_Declare_Block;

      if Unreach then
         return;
      end if;

      --  Add a jump to the new BB.
      Br := BuildBr (Builder, Cur_Declare_Block.Stmt_Bb);

      PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb);

      if Flag_Debug then
         declare
            Vals : ValueRefArray (0 .. 5);
         begin
            Vals :=
              (ConstInt (Int32Type, DW_TAG_Lexical_Block, 0),
               Dbg_Current_Filedir,             --  1 loc
               Dbg_Current_Scope,               --  2 context
               Dbg_Line,                        --  3 line num
               ConstInt (Int32Type, 0, 0),       --  4 col
               ConstInt (Int32Type, Scope_Uniq_Id, 0));
            Cur_Declare_Block.Dbg_Scope := MDNode (Vals, Vals'Length);
            Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope;
            Scope_Uniq_Id := Scope_Uniq_Id + 1;
         end;
      end if;
   end Start_Declare_Stmt;

   -------------------------
   -- Finish_Declare_Stmt --
   -------------------------

   procedure Finish_Declare_Stmt
   is
      Bb : BasicBlockRef;
      Br : ValueRef;
      pragma Unreferenced (Br);
   begin
      if not Unreach then
         --  Create a basic block for the statements after the declare.
         Bb := AppendBasicBlock (Cur_Func, Empty_Cstring);

         --  Execution will continue on the next statement
         Br := BuildBr (Builder, Bb);

         PositionBuilderAtEnd (Builder, Bb);
      end if;

      --  Do not reset Unread.

      Destroy_Declare_Block;

      Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope;
   end Finish_Declare_Stmt;

   -----------------------
   -- Start_Association --
   -----------------------

   procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode)
   is
   begin
      Assocs := (Subprg => Subprg,
                 Idx => 0,
                 Vals => new ValueRefArray (1 .. Subprg.Nbr_Args));
   end Start_Association;

   ---------------------
   -- New_Association --
   ---------------------

   procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is
   begin
      Assocs.Idx := Assocs.Idx + 1;
      Assocs.Vals (Assocs.Idx) := Val.LLVM;
   end New_Association;

   -----------------------
   -- New_Function_Call --
   -----------------------

   function New_Function_Call (Assocs : O_Assoc_List) return O_Enode
   is
      Res : ValueRef;
      Old_Vals : ValueRefArray_Acc;
   begin
      Res := BuildCall (Builder, Assocs.Subprg.LLVM,
                        Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring);
      Old_Vals := Assocs.Vals;
      Free (Old_Vals);
      Set_Insn_Dbg (Res);
      return O_Enode'(LLVM => Res, Etype => Assocs.Subprg.Dtype);
   end New_Function_Call;

   ------------------------
   -- New_Procedure_Call --
   ------------------------

   procedure New_Procedure_Call (Assocs : in out O_Assoc_List)
   is
      Res : ValueRef;
   begin
      if not Unreach then
         Res := BuildCall (Builder, Assocs.Subprg.LLVM,
                           Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring);
         Set_Insn_Dbg (Res);
      end if;
      Free (Assocs.Vals);
   end New_Procedure_Call;

   ---------------------
   -- New_Assign_Stmt --
   ---------------------

   procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode)
   is
      Res : ValueRef;
   begin
      if Target.Direct then
         raise Program_Error;
      end if;
      if not Unreach then
         Res := BuildStore (Builder, Value.LLVM, Target.LLVM);
         Set_Insn_Dbg (Res);
      end if;
   end New_Assign_Stmt;

   ---------------------
   -- New_Return_Stmt --
   ---------------------

   procedure New_Return_Stmt (Value : O_Enode) is
      Res : ValueRef;
   begin
      if Unreach then
         return;
      end if;
      Res := BuildRet (Builder, Value.LLVM);
      Set_Insn_Dbg (Res);
      Unreach := True;
   end New_Return_Stmt;

   ---------------------
   -- New_Return_Stmt --
   ---------------------

   procedure New_Return_Stmt is
      Res : ValueRef;
   begin
      if Unreach then
         return;
      end if;
      Res := BuildRetVoid (Builder);
      Set_Insn_Dbg (Res);
      Unreach := True;
   end New_Return_Stmt;

   -------------------
   -- Start_If_Stmt --
   -------------------

   procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) is
      Res : ValueRef;
      Bb_Then : BasicBlockRef;
   begin
      --  FIXME: check Unreach
      Bb_Then := AppendBasicBlock (Cur_Func, Empty_Cstring);
      Block := (Bb => AppendBasicBlock (Cur_Func, Empty_Cstring));
      Res := BuildCondBr (Builder, Cond.LLVM, Bb_Then, Block.Bb);
      Set_Insn_Dbg (Res);

      PositionBuilderAtEnd (Builder, Bb_Then);
   end Start_If_Stmt;

   -------------------
   -- New_Else_Stmt --
   -------------------

   procedure New_Else_Stmt (Block : in out O_If_Block) is
      Res : ValueRef;
      pragma Unreferenced (Res);
      Bb_Next : BasicBlockRef;
   begin
      if not Unreach then
         Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring);
         Res := BuildBr (Builder, Bb_Next);
      else
         Bb_Next := Null_BasicBlockRef;
      end if;

      PositionBuilderAtEnd (Builder, Block.Bb);

      Block := (Bb => Bb_Next);
      Unreach := False;
   end New_Else_Stmt;

   --------------------
   -- Finish_If_Stmt --
   --------------------

   procedure Finish_If_Stmt (Block : in out O_If_Block) is
      Res : ValueRef;
      pragma Unreferenced (Res);
      Bb_Next : BasicBlockRef;
   begin
      if not Unreach then
         --  The branch can continue.
         if Block.Bb = Null_BasicBlockRef then
            Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring);
         else
            Bb_Next := Block.Bb;
         end if;
         Res := BuildBr (Builder, Bb_Next);
         PositionBuilderAtEnd (Builder, Bb_Next);
      else
         --  The branch doesn't continue.
         if Block.Bb /= Null_BasicBlockRef then
            --  There is a fall-through (either from the then branch, or
            --  there is no else).
            Unreach := False;
            PositionBuilderAtEnd (Builder, Block.Bb);
         else
            Unreach := True;
         end if;
      end if;
   end Finish_If_Stmt;

   ---------------------
   -- Start_Loop_Stmt --
   ---------------------

   procedure Start_Loop_Stmt (Label : out O_Snode)
   is
      Res : ValueRef;
      pragma Unreferenced (Res);
   begin
      --  FIXME: check Unreach
      Label := (Bb_Entry => AppendBasicBlock (Cur_Func, Empty_Cstring),
                Bb_Exit => AppendBasicBlock (Cur_Func, Empty_Cstring));
      Res := BuildBr (Builder, Label.Bb_Entry);
      PositionBuilderAtEnd (Builder, Label.Bb_Entry);
   end Start_Loop_Stmt;

   ----------------------
   -- Finish_Loop_Stmt --
   ----------------------

   procedure Finish_Loop_Stmt (Label : in out O_Snode) is
      Res : ValueRef;
      pragma Unreferenced (Res);
   begin
      if not Unreach then
         Res := BuildBr (Builder, Label.Bb_Entry);
      end if;
      if Label.Bb_Exit /= Null_BasicBlockRef then
         --  FIXME: always true...
         PositionBuilderAtEnd (Builder, Label.Bb_Exit);
         Unreach := False;
      else
         Unreach := True;
      end if;
   end Finish_Loop_Stmt;

   -------------------
   -- New_Exit_Stmt --
   -------------------

   procedure New_Exit_Stmt (L : O_Snode) is
      Res : ValueRef;
   begin
      if not Unreach then
         Res := BuildBr (Builder, L.Bb_Exit);
         Set_Insn_Dbg (Res);
         Unreach := True;
      end if;
   end New_Exit_Stmt;

   -------------------
   -- New_Next_Stmt --
   -------------------

   procedure New_Next_Stmt (L : O_Snode) is
      Res : ValueRef;
   begin
      if not Unreach then
         Res := BuildBr (Builder, L.Bb_Entry);
         Set_Insn_Dbg (Res);
         Unreach := True;
      end if;
   end New_Next_Stmt;

   ---------------------
   -- Start_Case_Stmt --
   ---------------------

   procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is
   begin
      Block := (BB_Prev => GetInsertBlock (Builder),
                Value => Value.LLVM,
                Vtype => Value.Etype,
                BB_Next => Null_BasicBlockRef,
                BB_Others => Null_BasicBlockRef,
                BB_Choice => Null_BasicBlockRef,
                Nbr_Choices => 0,
                Choices => new O_Choice_Array (1 .. 8));
   end Start_Case_Stmt;

   ------------------
   -- Start_Choice --
   ------------------

   procedure Finish_Branch (Block : in out O_Case_Block) is
      Res : ValueRef;
      pragma Unreferenced (Res);
   begin
      --  Close previous branch.
      if not Unreach then
         if Block.BB_Next = Null_BasicBlockRef then
            Block.BB_Next := AppendBasicBlock (Cur_Func, Empty_Cstring);
         end if;
         Res := BuildBr (Builder, Block.BB_Next);
      end if;
   end Finish_Branch;

   procedure Start_Choice (Block : in out O_Case_Block) is
      Res : ValueRef;
      pragma Unreferenced (Res);
   begin
      if Block.BB_Choice /= Null_BasicBlockRef then
         --  Close previous branch.
         Finish_Branch (Block);
      end if;

      Unreach := False;
      Block.BB_Choice := AppendBasicBlock (Cur_Func, Empty_Cstring);
      PositionBuilderAtEnd (Builder, Block.BB_Choice);
   end Start_Choice;

   ---------------------
   -- New_Expr_Choice --
   ---------------------

   procedure Free is new Ada.Unchecked_Deallocation
     (O_Choice_Array, O_Choice_Array_Acc);

   procedure New_Choice (Block : in out O_Case_Block;
                         Low, High : ValueRef)
   is
      Choices : O_Choice_Array_Acc;
   begin
      if Block.Nbr_Choices = Block.Choices'Last then
         Choices := new O_Choice_Array (1 .. Block.Choices'Last * 2);
         Choices (1 .. Block.Choices'Last) := Block.Choices.all;
         Free (Block.Choices);
         Block.Choices := Choices;
      end if;
      Block.Nbr_Choices := Block.Nbr_Choices + 1;
      Block.Choices (Block.Nbr_Choices) := (Low => Low,
                                            High => High,
                                            Bb => Block.BB_Choice);
   end New_Choice;

   procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is
   begin
      New_Choice (Block, Expr.LLVM, Null_ValueRef);
   end New_Expr_Choice;

   ----------------------
   -- New_Range_Choice --
   ----------------------

   procedure New_Range_Choice
     (Block : in out O_Case_Block; Low, High : O_Cnode)
   is
   begin
      New_Choice (Block, Low.LLVM, High.LLVM);
   end New_Range_Choice;

   ------------------------
   -- New_Default_Choice --
   ------------------------

   procedure New_Default_Choice (Block : in out O_Case_Block) is
   begin
      Block.BB_Others := Block.BB_Choice;
   end New_Default_Choice;

   -------------------
   -- Finish_Choice --
   -------------------

   procedure Finish_Choice (Block : in out O_Case_Block) is
   begin
      null;
   end Finish_Choice;

   ----------------------
   -- Finish_Case_Stmt --
   ----------------------

   procedure Finish_Case_Stmt (Block : in out O_Case_Block)
   is
      Bb_Default : constant BasicBlockRef :=
        AppendBasicBlock (Cur_Func, Empty_Cstring);
      Bb_Default_Last : BasicBlockRef;
      Nbr_Cases : unsigned := 0;
      GE, LE : IntPredicate;
      Res : ValueRef;
   begin
      if Block.BB_Choice /= Null_BasicBlockRef then
         --  Close previous branch.
         Finish_Branch (Block);
      end if;

      --  Strategy: use a switch instruction for simple choices, put range
      --   choices in the default using if statements.
      case Block.Vtype.Kind is
         when ON_Unsigned_Type
           | ON_Enum_Type
           | ON_Boolean_Type =>
            GE := IntUGE;
            LE := IntULE;
         when ON_Signed_Type =>
            GE := IntSGE;
            LE := IntSLE;
         when others =>
            raise Program_Error;
      end case;

      --  BB for the default case of the LLVM switch.
      PositionBuilderAtEnd (Builder, Bb_Default);
      Bb_Default_Last := Bb_Default;

      for I in 1 .. Block.Nbr_Choices loop
         declare
            C : O_Choice_Type renames Block.Choices (I);
         begin
            if C.High /= Null_ValueRef then
               Bb_Default_Last := AppendBasicBlock (Cur_Func, Empty_Cstring);
               Res := BuildCondBr (Builder,
                                   BuildAnd (Builder,
                                             BuildICmp (Builder, GE,
                                                        Block.Value, C.Low,
                                                        Empty_Cstring),
                                             BuildICmp (Builder, LE,
                                                        Block.Value, C.High,
                                                        Empty_Cstring),
                                             Empty_Cstring),
                                   C.Bb, Bb_Default_Last);
               PositionBuilderAtEnd (Builder, Bb_Default_Last);
            else
               Nbr_Cases := Nbr_Cases + 1;
            end if;
         end;
      end loop;

      --  Insert the switch
      PositionBuilderAtEnd (Builder, Block.BB_Prev);
      Res := BuildSwitch (Builder, Block.Value, Bb_Default, Nbr_Cases);
      for I in 1 .. Block.Nbr_Choices loop
         declare
            C : O_Choice_Type renames Block.Choices (I);
         begin
            if C.High = Null_ValueRef then
               AddCase (Res, C.Low, C.Bb);
            end if;
         end;
      end loop;

      --  Insert the others.
      PositionBuilderAtEnd (Builder, Bb_Default_Last);
      if Block.BB_Others /= Null_BasicBlockRef then
         Res := BuildBr (Builder, Block.BB_Others);
      else
         Res := BuildUnreachable (Builder);
      end if;

      if Block.BB_Next /= Null_BasicBlockRef then
         Unreach := False;
         PositionBuilderAtEnd (Builder, Block.BB_Next);
      else
         Unreach := True;
      end if;

      Free (Block.Choices);
   end Finish_Case_Stmt;

   function Get_LLVM_Type (Atype : O_Tnode) return TypeRef is
   begin
      case Atype.Kind is
         when ON_Incomplete_Record_Type
           | ON_Incomplete_Access_Type =>
            if Atype.LLVM = Null_TypeRef then
               raise Program_Error with "early use of incomplete type";
            end if;
            return Atype.LLVM;
         when ON_Union_Type
           | ON_Scalar_Types
           | ON_Access_Type
           | ON_Array_Type
           | ON_Array_Sub_Type
           | ON_Record_Type =>
            return Atype.LLVM;
         when others =>
            raise Program_Error;
      end case;
   end Get_LLVM_Type;

   procedure Finish_Debug is
   begin
      declare
         Dbg_Cu : constant String := "llvm.dbg.cu" & ASCII.NUL;
         Producer : constant String := "ortho llvm";
         Vals : ValueRefArray (0 .. 12);
      begin
         Vals :=
           (ConstInt (Int32Type, DW_TAG_Compile_Unit, 0),
            Dbg_Current_Filedir,         --  1 file+dir
            ConstInt (Int32Type, 1, 0),  --  2 language (C)
            MDString (Producer),         --  3 producer
            ConstInt (Int1Type, 0, 0),   --  4 isOpt
            MDString (""),               --  5 flags
            ConstInt (Int32Type, 0, 0),  --  6 runtime version
            Null_ValueRef,               --  7 enum types
            Null_ValueRef,               --  8 retained types
            Get_Value (Subprg_Nodes),    --  9 subprograms
            Get_Value (Global_Nodes),    --  10 global var
            Null_ValueRef,               --  11 imported entities
            Null_ValueRef);              --  12 split debug

         AddNamedMetadataOperand
           (Module, Dbg_Cu'Address, MDNode (Vals, Vals'Length));
      end;

      declare
         Module_Flags : constant String := "llvm.module.flags" & ASCII.NUL;
         Flags1 : ValueRefArray (0 .. 2);
         Flags2 : ValueRefArray (0 .. 2);
      begin
         Flags1 := (ConstInt (Int32Type, 1, 0),
                    MDString ("Debug Info Version"),
                    ConstInt (Int32Type, 1, 0));
         AddNamedMetadataOperand
           (Module, Module_Flags'Address, MDNode (Flags1, Flags1'Length));
         Flags2 := (ConstInt (Int32Type, 2, 0),
                    MDString ("Dwarf Version"),
                    ConstInt (Int32Type, 2, 0));
         AddNamedMetadataOperand
           (Module, Module_Flags'Address, MDNode (Flags2, Flags2'Length));
      end;
   end Finish_Debug;
end Ortho_LLVM;