path: root/ortho/debug/ortho_debug.adb

--  Ortho debug back-end.
--  Copyright (C) 2005 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 Ada.Unchecked_Deallocation;

package body Ortho_Debug is
   --  Metrics:
   --  Alignment and size for an address.
   Metric_Access_Align : constant Natural := 2;
   Metric_Access_Size : constant Unsigned_32 := 4;

   type ON_Op_To_OE_Type is array (ON_Op_Kind) of OE_Kind;
   ON_Op_To_OE : constant ON_Op_To_OE_Type :=
     (
      ON_Nil => OE_Nil,

      --  Dyadic operations.
      ON_Add_Ov => OE_Add_Ov,
      ON_Sub_Ov => OE_Sub_Ov,
      ON_Mul_Ov => OE_Mul_Ov,
      ON_Div_Ov => OE_Div_Ov,
      ON_Rem_Ov => OE_Rem_Ov,
      ON_Mod_Ov => OE_Mod_Ov,

      --  Binary operations.
      ON_And => OE_And,
      ON_Or => OE_Or,
      ON_Xor => OE_Xor,
      ON_And_Then => OE_And_Then,
      ON_Or_Else => OE_Or_Else,

      --  Monadic operations.
      ON_Not => OE_Not,
      ON_Neg_Ov => OE_Neg_Ov,
      ON_Abs_Ov => OE_Abs_Ov,

      --  Comparaisons
      ON_Eq => OE_Eq,
      ON_Neq => OE_Neq,
      ON_Le => OE_Le,
      ON_Lt => OE_Lt,
      ON_Ge => OE_Ge,
      ON_Gt => OE_Gt
      );

   type Decl_Scope_Type is record
      --  Declarations are chained.
      Parent : O_Snode;
      Last_Decl : O_Dnode;
      Last_Stmt : O_Snode;

      --  If this scope corresponds to a function, PREV_FUNCTION contains
      --  the previous function.
      Prev_Function : O_Dnode;

      --  Declaration scopes are chained.
      Prev : Decl_Scope_Acc;
   end record;

   type Stmt_Kind is
     (Stmt_Function, Stmt_Declare, Stmt_If, Stmt_Loop, Stmt_Case);
   type Stmt_Scope_Type (Kind : Stmt_Kind);
   type Stmt_Scope_Acc is access Stmt_Scope_Type;
   type Stmt_Scope_Type (Kind : Stmt_Kind) is record
      --  Statement which created this scope.
      Parent : O_Snode;
      --  Previous (parent) scope.
      Prev : Stmt_Scope_Acc;
      case Kind is
         when Stmt_Function =>
            Prev_Function : Stmt_Scope_Acc;
            --  Declaration for the function.
            Decl : O_Dnode;
         when Stmt_Declare =>
            null;
         when Stmt_If =>
            Last_Elsif : O_Snode;
         when Stmt_Loop =>
            null;
         when Stmt_Case =>
            Last_Branch : O_Snode;
            Last_Choice : O_Choice;
            Case_Type : O_Tnode;
      end case;
   end record;
   subtype Stmt_Function_Scope_Type is Stmt_Scope_Type (Stmt_Function);
   subtype Stmt_Declare_Scope_Type is Stmt_Scope_Type (Stmt_Declare);
   subtype Stmt_If_Scope_Type is Stmt_Scope_Type (Stmt_If);
   subtype Stmt_Loop_Scope_Type is Stmt_Scope_Type (Stmt_Loop);
   subtype Stmt_Case_Scope_Type is Stmt_Scope_Type (Stmt_Case);

   Current_Stmt_Scope : Stmt_Scope_Acc := null;
   Current_Function : Stmt_Scope_Acc := null;
   Current_Decl_Scope : Decl_Scope_Acc := null;
   Current_Loop_Level : Natural := 0;

   procedure Push_Decl_Scope (Parent : O_Snode)
   is
      Res : Decl_Scope_Acc;
   begin
      Res := new Decl_Scope_Type'(Parent => Parent,
                                  Last_Decl => null,
                                  Last_Stmt => null,
                                  Prev_Function => null,
                                  Prev => Current_Decl_Scope);
      Parent.Alive := True;
      Current_Decl_Scope := Res;
   end Push_Decl_Scope;

   procedure Pop_Decl_Scope
   is
      procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
        (Object => Decl_Scope_Type, Name => Decl_Scope_Acc);
      Old : Decl_Scope_Acc;
   begin
      Old := Current_Decl_Scope;
      Old.Parent.Alive := False;
      Current_Decl_Scope := Old.Prev;
      Unchecked_Deallocation (Old);
   end Pop_Decl_Scope;

   procedure Add_Decl (El : O_Dnode; Check_Dup : Boolean := True) is
   begin
      if Current_Decl_Scope = null then
         --  Not yet initialized, or after compilation.
         raise Program_Error;
      end if;

      --  Note: this requires an hashed ident table.
      --  Use ortho_ident_hash.
      if False and then Check_Dup
        and then not Is_Nul (El.Name)
      then
         --  Check the name is not already defined.
         declare
            E : O_Dnode;
         begin
            E := Current_Decl_Scope.Parent.Decls;
            while E /= O_Dnode_Null loop
               if Is_Equal (E.Name, El.Name) then
                  raise Syntax_Error;
               end if;
               E := E.Next;
            end loop;
         end;
      end if;

      if Current_Decl_Scope.Last_Decl = null then
         if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then
            Current_Decl_Scope.Parent.Decls := El;
         else
            raise Type_Error;
         end if;
      else
         Current_Decl_Scope.Last_Decl.Next := El;
      end if;
      El.Next := null;
      Current_Decl_Scope.Last_Decl := El;
   end Add_Decl;

   procedure Add_Stmt (Stmt : O_Snode)
   is
   begin
      if Current_Decl_Scope = null or Current_Function = null then
         --  You are adding a statement at the global level, ie not inside
         --  a function.
         raise Syntax_Error;
      end if;

      Stmt.Next := null;
      if Current_Decl_Scope.Last_Stmt = null then
         if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then
            Current_Decl_Scope.Parent.Stmts := Stmt;
         else
            raise Syntax_Error;
         end if;
      else
         Current_Decl_Scope.Last_Stmt.Next := Stmt;
      end if;
      Current_Decl_Scope.Last_Stmt := Stmt;
   end Add_Stmt;

   procedure Push_Stmt_Scope (Scope : Stmt_Scope_Acc)
   is
   begin
      if Scope.Prev /= Current_Stmt_Scope then
         --  SCOPE was badly initialized.
         raise Program_Error;
      end if;
      Current_Stmt_Scope := Scope;
   end Push_Stmt_Scope;

   procedure Pop_Stmt_Scope (Kind : Stmt_Kind)
   is
      procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
        (Object => Stmt_Scope_Type, Name => Stmt_Scope_Acc);
      Old : Stmt_Scope_Acc;
   begin
      Old := Current_Stmt_Scope;
      if Old.Kind /= Kind then
         raise Syntax_Error;
      end if;
      --Old.Parent.Last_Stmt := Current_Decl_Scope.Last_Stmt;
      Current_Stmt_Scope := Old.Prev;
      Unchecked_Deallocation (Old);
   end Pop_Stmt_Scope;

   --  Check declaration DECL is reachable, ie its scope is in the current
   --  stack of scopes.
   procedure Check_Scope (Decl : O_Dnode)
   is
      Res : Boolean;
   begin
      case Decl.Kind is
         when ON_Interface_Decl =>
            Res := Decl.Func_Scope.Alive;
         when others =>
            Res := Decl.Scope.Alive;
      end case;
      if not Res then
         raise Syntax_Error;
      end if;
   end Check_Scope;

   --  Raise SYNTAX_ERROR if OBJ is not at a constant address.
--    procedure Check_Const_Address (Obj : O_Lnode) is
--    begin
--       case Obj.Kind is
--          when OL_Const_Ref
--            | OL_Var_Ref =>
--             case Obj.Decl.Storage is
--                when O_Storage_External
--                  | O_Storage_Public
--                  | O_Storage_Private =>
--                   null;
--                when O_Storage_Local =>
--                   raise Syntax_Error;
--             end case;
--          when others =>
--             --  FIXME: constant indexed element, selected element maybe
--             --   of const address.
--             raise Syntax_Error;
--       end case;
--    end Check_Const_Address;

   procedure Check_Type (T1, T2 : O_Tnode) is
   begin
      if T1 = T2 then
         return;
      end if;
      if T1.Kind = ON_Array_Sub_Type and then T2.Kind = ON_Array_Sub_Type
        and then T1.Base_Type = T2.Base_Type
        and then T1.Length.all = T2.Length.all
      then
         return;
      end if;
      raise Type_Error;
   end Check_Type;

   procedure Check_Ref (N : O_Enode) is
   begin
      if N.Ref then
         --  Already referenced.
         raise Syntax_Error;
      end if;
      N.Ref := True;
   end Check_Ref;

   procedure Check_Ref (N : O_Lnode) is
   begin
      if N.Ref then
         raise Syntax_Error;
      end if;
      N.Ref := True;
   end Check_Ref;

   procedure Check_Complete_Type (T : O_Tnode) is
   begin
      if not T.Complete then
         --  Uncomplete type cannot be used here (since its size is required,
         --   for example).
         raise Syntax_Error;
      end if;
   end Check_Complete_Type;

   function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
     return O_Enode
   is
      K : constant OE_Kind := ON_Op_To_OE (Kind);
      Res : O_Enode;
   begin
      Check_Type (Left.Rtype, Right.Rtype);
      Check_Ref (Left);
      Check_Ref (Right);
      Res := new O_Enode_Type (K);
      Res.Rtype := Left.Rtype;
      Res.Ref := False;
      Res.Left := Left;
      Res.Right := Right;
      return Res;
   end New_Dyadic_Op;

   function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
     return O_Enode
   is
      Res : O_Enode;
   begin
      Check_Ref (Operand);
      Res := new O_Enode_Type (ON_Op_To_OE (Kind));
      Res.Ref := False;
      Res.Operand := Operand;
      Res.Rtype := Operand.Rtype;
      return Res;
   end New_Monadic_Op;

   function New_Compare_Op
     (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode)
     return O_Enode
   is
      Res : O_Enode;
   begin
      if Ntype.Kind /= ON_Boolean_Type then
         raise Type_Error;
      end if;
      if Left.Rtype /= Right.Rtype then
         raise Type_Error;
      end if;
      Check_Ref (Left);
      Check_Ref (Right);
      Res := new O_Enode_Type (ON_Op_To_OE (Kind));
      Res.Ref := False;
      Res.Left := Left;
      Res.Right := Right;
      Res.Rtype := Ntype;
      return Res;
   end New_Compare_Op;


   function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
     return O_Cnode
   is
      subtype O_Cnode_Signed_Lit is O_Cnode_Type (OC_Signed_Lit);
   begin
      if Ltype.Kind = ON_Signed_Type then
         return new O_Cnode_Signed_Lit'(Kind => OC_Signed_Lit,
                                        Ctype => Ltype,
                                        Ref => False,
                                        S_Val => Value);
      else
         raise Type_Error;
      end if;
   end New_Signed_Literal;

   function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
     return O_Cnode
   is
      subtype O_Cnode_Unsigned_Lit is O_Cnode_Type (OC_Unsigned_Lit);
   begin
      if Ltype.Kind = ON_Unsigned_Type then
         return new O_Cnode_Unsigned_Lit'(Kind => OC_Unsigned_Lit,
                                          Ctype => Ltype,
                                          Ref => False,
                                          U_Val => Value);
      else
         raise Type_Error;
      end if;
   end New_Unsigned_Literal;

   function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
     return O_Cnode
   is
      subtype O_Cnode_Float_Lit is O_Cnode_Type (OC_Float_Lit);
   begin
      if Ltype.Kind = ON_Float_Type then
         return new O_Cnode_Float_Lit'(Kind => OC_Float_Lit,
                                       Ctype => Ltype,
                                       Ref => False,
                                       F_Val => Value);
      else
         raise Type_Error;
      end if;
   end New_Float_Literal;

   function New_Null_Access (Ltype : O_Tnode) return O_Cnode
   is
      subtype O_Cnode_Null_Lit_Type is O_Cnode_Type (OC_Null_Lit);
   begin
      if Ltype.Kind /= ON_Access_Type then
         raise Type_Error;
      end if;
      return  new O_Cnode_Null_Lit_Type'(Kind => OC_Null_Lit,
                                         Ctype => Ltype,
                                         Ref => False);
   end New_Null_Access;

   function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode
   is
      subtype O_Cnode_Sizeof_Type is O_Cnode_Type (OC_Sizeof_Lit);
   begin
      if Rtype.Kind /= ON_Unsigned_Type then
         raise Type_Error;
      end if;
      Check_Complete_Type (Atype);
      if Atype.Kind = ON_Array_Type then
         raise Type_Error;
      end if;
      return new O_Cnode_Sizeof_Type'(Kind => OC_Sizeof_Lit,
                                      Ctype => Rtype,
                                      Ref => False,
                                      S_Type => Atype);
   end New_Sizeof;

   function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Cnode
   is
      subtype O_Cnode_Offsetof_Type is O_Cnode_Type (OC_Offsetof_Lit);
   begin
      if Rtype.Kind /= ON_Unsigned_Type then
         raise Type_Error;
      end if;
      return new O_Cnode_Offsetof_Type'(Kind => OC_Offsetof_Lit,
                                        Ctype => Rtype,
                                        Ref => False,
                                        Off_Field => Field);
   end New_Offsetof;

   function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode
   is
      subtype O_Enode_Alloca_Type is O_Enode_Type (OE_Alloca);
      Res : O_Enode;
   begin
      if Rtype.Kind /= ON_Access_Type then
         raise Type_Error;
      end if;
      if Size.Rtype.Kind /= ON_Unsigned_Type then
         raise Type_Error;
      end if;
      Res := new O_Enode_Alloca_Type'(Kind => OE_Alloca,
                                      Rtype => Rtype,
                                      Ref => False,
                                      A_Size => Size);
      return Res;
   end New_Alloca;

   procedure Check_Constrained_Type (Atype : O_Tnode) is
   begin
      case Atype.Kind is
         when ON_Array_Type =>
            raise Type_Error;
         when ON_Unsigned_Type
           | ON_Signed_Type
           | ON_Boolean_Type
           | ON_Record_Type
           | ON_Union_Type
           | ON_Access_Type
           | ON_Float_Type
           | ON_Array_Sub_Type
           | ON_Enum_Type =>
            null;
      end case;
   end Check_Constrained_Type;

   procedure New_Completed_Type_Decl (Atype : O_Tnode)
   is
      N : O_Dnode;
   begin
      if Atype.Decl = null then
         --  The uncompleted type must have been declared.
         raise Type_Error;
      end if;
      N := new O_Dnode_Type (ON_Completed_Type_Decl);
      N.Name := Atype.Decl.Name;
      N.Dtype := Atype;
      Add_Decl (N, False);
   end New_Completed_Type_Decl;

   procedure New_Uncomplete_Record_Type (Res : out O_Tnode)
   is
      subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type);
   begin
      Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type,
                                      Decl => O_Dnode_Null,
                                      Align => 0,
                                      Size => 0,
                                      Uncomplete => True,
                                      Complete => False,
                                      Elements => O_Fnode_Null);
   end New_Uncomplete_Record_Type;

   procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
                                           Elements : out O_Element_List) is
   begin
      if not Res.Uncomplete then
         --  RES record type is not an uncomplete record type.
         raise Syntax_Error;
      end if;
      if Res.Elements /= O_Fnode_Null then
         --  RES record type already has elements...
         raise Syntax_Error;
      end if;
      Elements.Res := Res;
      Elements.Last := null;
   end Start_Uncomplete_Record_Type;

   procedure Start_Record_Type (Elements : out O_Element_List)
   is
      subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type);
   begin
      Elements.Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type,
                                               Decl => O_Dnode_Null,
                                               Align => 0,
                                               Size => 0,
                                               Uncomplete => False,
                                               Complete => False,
                                               Elements => O_Fnode_Null);
      Elements.Last := null;
   end Start_Record_Type;

   function Align_Size (Size : Unsigned_32; Align : Natural)
     return Unsigned_32
   is
      M : Unsigned_32;
   begin
      M := (2 ** Align) - 1;
      return (Size + M) and (not M);
   end Align_Size;

   procedure New_Record_Field
     (Elements : in out O_Element_List;
      El : out O_Fnode;
      Ident : O_Ident; Etype : O_Tnode)
   is
   begin
      Check_Complete_Type (Etype);
      Check_Constrained_Type (Etype);
      --  The alignment of a structure is the max alignment of its field.
      if Etype.Align > Elements.Res.Align then
         Elements.Res.Align := Etype.Align;
      end if;
      --  Align the current size for the new field.
      Elements.Res.Size := Align_Size (Elements.Res.Size, Etype.Align);
      El := new O_Fnode_Type'(Parent => Elements.Res,
                              Next => null,
                              Ident => Ident,
                              Ftype => Etype,
                              Offset => Elements.Res.Size);
      --  Add the size of the field.
      Elements.Res.Size := Elements.Res.Size + Etype.Size;
      if Elements.Last = null then
         Elements.Res.Elements := El;
      else
         Elements.Last.Next := El;
      end if;
      Elements.Last := El;
   end New_Record_Field;

   procedure Finish_Record_Type
     (Elements : in out O_Element_List; Res : out O_Tnode) is
   begin
      --  Align the structure.
      Res := Elements.Res;
      Res.Size := Align_Size (Res.Size, Res.Align);
      if Res.Uncomplete then
         New_Completed_Type_Decl (Res);
      end if;
      Res.Complete := True;
   end Finish_Record_Type;

   procedure Start_Union_Type (Elements : out O_Element_List)
   is
      subtype O_Tnode_Union_Type is O_Tnode_Type (ON_Union_Type);
   begin
      Elements.Res := new O_Tnode_Union_Type'(Kind => ON_Union_Type,
                                              Decl => O_Dnode_Null,
                                              Align => 0,
                                              Size => 0,
                                              Uncomplete => False,
                                              Complete => False,
                                              Elements => O_Fnode_Null);
      Elements.Last := null;
   end Start_Union_Type;

   procedure New_Union_Field
     (Elements : in out O_Element_List;
      El : out O_Fnode;
      Ident : O_Ident; Etype : O_Tnode)
   is
   begin
      New_Record_Field (Elements, El, Ident, Etype);
   end New_Union_Field;

   procedure Finish_Union_Type
     (Elements : in out O_Element_List; Res : out O_Tnode) is
   begin
      --  Align the structure.
      Res := Elements.Res;
      Res.Size := Align_Size (Res.Size, Res.Align);
      Res.Complete := True;
   end Finish_Union_Type;

   function New_Access_Type (Dtype : O_Tnode) return O_Tnode
   is
      subtype O_Tnode_Access is O_Tnode_Type (ON_Access_Type);
      Res : O_Tnode;
   begin
      if Dtype /= O_Tnode_Null
        and then Dtype.Kind = ON_Array_Sub_Type
      then
         --  Access to sub array are not allowed, use access to array.
         raise Type_Error;
      end if;
      Res := new O_Tnode_Access'(Kind => ON_Access_Type,
                                 Decl => O_Dnode_Null,
                                 Align => Metric_Access_Align,
                                 Size => Metric_Access_Size,
                                 Uncomplete => Dtype = O_Tnode_Null,
                                 Complete => True,
                                 D_Type => Dtype);
      return Res;
   end New_Access_Type;

   procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode)
   is
   begin
      if Dtype.Kind = ON_Array_Sub_Type then
         --  Access to sub array are not allowed, use access to array.
         raise Type_Error;
      end if;
      if Atype.D_Type /= O_Tnode_Null
        or Atype.Uncomplete = False
      then
         --  Type already completed.
         raise Syntax_Error;
      end if;
      Atype.D_Type := Dtype;
      New_Completed_Type_Decl (Atype);
   end Finish_Access_Type;

   function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
     return O_Tnode
   is
      subtype O_Tnode_Array is O_Tnode_Type (ON_Array_Type);
   begin
      Check_Constrained_Type (El_Type);
      Check_Complete_Type (El_Type);
      return new O_Tnode_Array'(Kind => ON_Array_Type,
                                Decl => O_Dnode_Null,
                                Align => El_Type.Align,
                                Size => 0,
                                Uncomplete => False,
                                Complete => True,
                                El_Type => El_Type,
                                Index_Type => Index_Type);
   end New_Array_Type;

   function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
     return O_Tnode
   is
      subtype O_Tnode_Sub_Array is O_Tnode_Type (ON_Array_Sub_Type);
      Size : Unsigned_32;
   begin
      if Atype.Kind /= ON_Array_Type then
         raise Type_Error;
      end if;
      Size := Unsigned_32 (Length.U_Val) * Atype.El_Type.Size;
      return new O_Tnode_Sub_Array'(Kind => ON_Array_Sub_Type,
                                    Decl => O_Dnode_Null,
                                    Align => Atype.Align,
                                    Size => Size,
                                    Uncomplete => False,
                                    Complete => True,
                                    Base_Type => Atype,
                                    Length => Length);
   end New_Constrained_Array_Type;

   function Get_Scalar_Pow (Bit_Size : Natural) return Natural is
   begin
      if Bit_Size <= 8 then
         return 0;
      elsif Bit_Size <= 32 then
         return 2;
      elsif Bit_Size <= 64 then
         return 3;
      else
         raise Type_Error;
      end if;
   end Get_Scalar_Pow;

   function New_Unsigned_Type (Size : Natural) return O_Tnode
   is
      subtype O_Tnode_Unsigned is O_Tnode_Type (ON_Unsigned_Type);
      Align : Natural;
   begin
      Align := Get_Scalar_Pow (Size);
      return new O_Tnode_Unsigned'(Kind => ON_Unsigned_Type,
                                   Decl => O_Dnode_Null,
                                   Align => Align,
                                   Size => 2 ** Align,
                                   Uncomplete => False,
                                   Complete => True);
   end New_Unsigned_Type;

   function New_Signed_Type (Size : Natural) return O_Tnode
   is
      subtype O_Tnode_Signed is O_Tnode_Type (ON_Signed_Type);
      Align : Natural;
   begin
      Align := Get_Scalar_Pow (Size);
      return new O_Tnode_Signed'(Kind => ON_Signed_Type,
                                 Decl => O_Dnode_Null,
                                 Align => Align,
                                 Size => 2 ** Align,
                                 Uncomplete => False,
                                 Complete => True);
   end New_Signed_Type;

   function New_Float_Type return O_Tnode
   is
      subtype O_Tnode_Float is O_Tnode_Type (ON_Float_Type);
   begin
      return new O_Tnode_Float'(Kind => ON_Float_Type,
                                Decl => O_Dnode_Null,
                                Align => 0,
                                Size => 1,
                                Uncomplete => False,
                                Complete => True);
   end New_Float_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
      subtype O_Tnode_Boolean is O_Tnode_Type (ON_Boolean_Type);
      subtype O_Cnode_Boolean_Lit is O_Cnode_Type (OC_Boolean_Lit);
   begin
      Res := new O_Tnode_Boolean'(Kind => ON_Boolean_Type,
                                  Decl => O_Dnode_Null,
                                  Align => 0,
                                  Size => 1,
                                  Uncomplete => False,
                                  Complete => True,
                                  True_N => O_Cnode_Null,
                                  False_N => O_Cnode_Null);
      True_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit,
                                         Ctype => Res,
                                         Ref => False,
                                         B_Val => True,
                                         B_Id => True_Id);
      False_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit,
                                          Ctype => Res,
                                          Ref => False,
                                          B_Val => False,
                                          B_Id => False_Id);
      Res.True_N := True_E;
      Res.False_N := False_E;
   end New_Boolean_Type;

   procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural)
   is
      subtype O_Tnode_Enum is O_Tnode_Type (ON_Enum_Type);
      Res : O_Tnode;
      Align : Natural;
   begin
      Align := Get_Scalar_Pow (Size);
      Res := new O_Tnode_Enum'(Kind => ON_Enum_Type,
                               Decl => O_Dnode_Null,
                               Align => Align,
                               Size => 2 ** Align,
                               Uncomplete => False,
                               Complete => False,
                               Nbr => 0,
                               Literals => O_Cnode_Null);
      List.Res := Res;
      List.Last := O_Cnode_Null;
   end Start_Enum_Type;

   procedure New_Enum_Literal (List : in out O_Enum_List;
                               Ident : O_Ident;
                               Res : out O_Cnode)
   is
      subtype O_Cnode_Enum_Lit is O_Cnode_Type (OC_Enum_Lit);
   begin
      Res := new O_Cnode_Enum_Lit'(Kind => OC_Enum_Lit,
                                   Ctype => List.Res,
                                   Ref => False,
                                   E_Val => List.Res.Nbr,
                                   E_Name => Ident,
                                   E_Next => O_Cnode_Null);
      --  Link it.
      if List.Last = O_Cnode_Null then
         List.Res.Literals := Res;
      else
         List.Last.E_Next := Res;
      end if;
      List.Last := Res;

      List.Res.Nbr := List.Res.Nbr + 1;
   end New_Enum_Literal;

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

   function Get_Base_Type (Atype : O_Tnode) return O_Tnode
   is
   begin
      case Atype.Kind is
         when ON_Array_Sub_Type =>
            return Atype.Base_Type;
         when others =>
            return Atype;
      end case;
   end Get_Base_Type;


   procedure Start_Record_Aggr (List : out O_Record_Aggr_List; Atype : O_Tnode)
   is
      subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate);
      Res : O_Cnode;
   begin
      if Atype.Kind /= ON_Record_Type then
         raise Type_Error;
      end if;
      Check_Complete_Type (Atype);
      Res := new O_Cnode_Aggregate'(Kind => OC_Aggregate,
                                    Ctype => Atype,
                                    Ref => False,
                                    Aggr_Els => null);
      List.Res := Res;
      List.Last := null;
      List.Field := Atype.Elements;
   end Start_Record_Aggr;

   procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
                                 Value : O_Cnode)
   is
      subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element);
      El : O_Cnode;
   begin
      if List.Field = O_Fnode_Null then
         --  No more element in the aggregate.
         raise Syntax_Error;
      end if;
      Check_Type (Value.Ctype, List.Field.Ftype);
      El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element,
                                     Ctype => Value.Ctype,
                                     Ref => False,
                                     Aggr_Value => Value,
                                     Aggr_Next => null);
      if List.Last = null then
         List.Res.Aggr_Els := El;
      else
         List.Last.Aggr_Next := El;
      end if;
      List.Last := El;
      List.Field := List.Field.Next;
   end New_Record_Aggr_El;

   procedure Finish_Record_Aggr
     (List : in out O_Record_Aggr_List; Res : out O_Cnode)
   is
   begin
      if List.Field /= null then
         --  Not enough elements in aggregate.
         raise Type_Error;
      end if;
      Res := List.Res;
   end Finish_Record_Aggr;

   procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode)
   is
      subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate);
      Res : O_Cnode;
   begin
      if Atype.Kind /= ON_Array_Sub_Type then
         raise Type_Error;
      end if;
      Check_Complete_Type (Atype);
      Res := new O_Cnode_Aggregate'(Kind => OC_Aggregate,
                                    Ctype => Atype,
                                    Ref => False,
                                    Aggr_Els => null);
      List.Res := Res;
      List.Last := null;
      List.El_Type := Atype.Base_Type.El_Type;
   end Start_Array_Aggr;

   procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
                                Value : O_Cnode)
   is
      subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element);
      El : O_Cnode;
   begin
      Check_Type (Value.Ctype, List.El_Type);
      El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element,
                                     Ctype => Value.Ctype,
                                     Ref => False,
                                     Aggr_Value => Value,
                                     Aggr_Next => null);
      if List.Last = null then
         List.Res.Aggr_Els := El;
      else
         List.Last.Aggr_Next := El;
      end if;
      List.Last := El;
   end New_Array_Aggr_El;

   procedure Finish_Array_Aggr
     (List : in out O_Array_Aggr_List; Res : out O_Cnode) is
   begin
      Res := List.Res;
   end Finish_Array_Aggr;

   function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
                           return O_Cnode
   is
      subtype O_Cnode_Union_Aggr is O_Cnode_Type (OC_Union_Aggr);
      Res : O_Cnode;
   begin
      if Atype.Kind /= ON_Union_Type then
         raise Type_Error;
      end if;
      Check_Type (Value.Ctype, Field.Ftype);

      Res := new O_Cnode_Union_Aggr'(Kind => OC_Union_Aggr,
                                     Ctype => Atype,
                                     Ref => False,
                                     Uaggr_Field => Field,
                                     Uaggr_Value => Value);
      return Res;
   end New_Union_Aggr;

   function New_Obj (Obj : O_Dnode) return O_Lnode
   is
      subtype O_Lnode_Obj is O_Lnode_Type (OL_Obj);
   begin
      case Obj.Kind is
         when ON_Const_Decl
           | ON_Var_Decl
           | ON_Interface_Decl =>
            null;
         when others =>
            raise Program_Error;
      end case;
      Check_Scope (Obj);
      return new O_Lnode_Obj'(Kind => OL_Obj,
                              Rtype => Obj.Dtype,
                              Ref => False,
                              Obj => Obj);
   end New_Obj;

   function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
     return O_Lnode
   is
      subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element);
      Res : O_Lnode;
   begin
      Check_Ref (Arr);
      Res := new O_Lnode_Indexed'(Kind => OL_Indexed_Element,
                                  Rtype => Get_Base_Type (Arr.Rtype).El_Type,
                                  Ref => False,
                                  Array_Base => Arr,
                                  Index => Index);
      return Res;
   end New_Indexed_Element;

   function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
     return O_Lnode
   is
      subtype O_Lnode_Slice is O_Lnode_Type (OL_Slice);
      Res : O_Lnode;
   begin
      if Res_Type.Kind /= ON_Array_Type
        and then Res_Type.Kind /= ON_Array_Sub_Type
      then
         raise Type_Error;
      end if;
      Check_Ref (Arr);
      Check_Ref (Index);
      -- FIXME: check type.
      Res := new O_Lnode_Slice'(Kind => OL_Slice,
                                Rtype => Res_Type,
                                Ref => False,
                                Slice_Base => Arr,
                                Slice_Index => Index);
      return Res;
   end New_Slice;

   function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
     return O_Lnode
   is
      subtype O_Lnode_Selected_Element is O_Lnode_Type (OL_Selected_Element);
   begin
      if Rec.Rtype.Kind /= ON_Record_Type then
         raise Type_Error;
      end if;
      if Rec.Rtype /= El.Parent then
         raise Type_Error;
      end if;
      Check_Ref (Rec);
      return new O_Lnode_Selected_Element'(Kind => OL_Selected_Element,
                                           Rtype => El.Ftype,
                                           Ref => False,
                                           Rec_Base => Rec,
                                           Rec_El => El);
   end New_Selected_Element;

   function New_Access_Element (Acc : O_Enode) return O_Lnode
   is
      subtype O_Lnode_Access_Element is O_Lnode_Type (OL_Access_Element);
   begin
      if Acc.Rtype.Kind /= ON_Access_Type then
         raise Type_Error;
      end if;
      Check_Ref (Acc);
      return new O_Lnode_Access_Element'(Kind => OL_Access_Element,
                                         Rtype => Acc.Rtype.D_Type,
                                         Ref => False,
                                         Acc_Base => Acc);
   end New_Access_Element;

   function Check_Conv (Source : ON_Type_Kind; Target : ON_Type_Kind)
     return Boolean
   is
      type Conv_Array is array (ON_Type_Kind, ON_Type_Kind) of Boolean;
      T : constant Boolean := True;
      F : constant Boolean := False;
      Conv_Allowed : constant Conv_Array :=
        (ON_Boolean_Type =>  (T, F, T, T, F, F, F, F, F, F),
         ON_Enum_Type =>     (F, F, T, T, F, F, F, F, F, F),
         ON_Unsigned_Type => (T, T, T, T, F, F, F, F, F, F),
         ON_Signed_Type =>   (T, T, T, T, T, F, F, F, F, F),
         ON_Float_Type =>    (F, F, F, T, T, F, F, F, F, F),
         ON_Array_Type =>    (F, F, F, F, F, F, T, F, F, F),
         ON_Array_Sub_Type =>(F, F, F, F, F, T, T, F, F, F),
         ON_Record_Type =>   (F, F, F, F, F, F, F, F, F, F),
         ON_Union_Type =>    (F, F, F, F, F, F, F, F, F, F),
         ON_Access_Type =>   (F, F, F, F, F, F, F, F, F, T));
   begin
      if Source = Target then
         return True;
      else
         return Conv_Allowed (Source, Target);
      end if;
   end Check_Conv;

   function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode
   is
      subtype O_Enode_Convert is O_Enode_Type (OE_Convert_Ov);
      Res : O_Enode;
   begin
      Check_Ref (Val);
      if not Check_Conv (Val.Rtype.Kind, Rtype.Kind) then
         raise Type_Error;
      end if;
      Res := new O_Enode_Convert'(Kind => OE_Convert_Ov,
                                  Rtype => Rtype,
                                  Ref => False,
                                  Conv => Val);
      return Res;
   end New_Convert_Ov;

   function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
     return O_Enode
   is
      subtype O_Enode_Address is O_Enode_Type (OE_Unchecked_Address);
   begin
      Check_Ref (Lvalue);
      if Atype.Kind /= ON_Access_Type then
         --  An address is of type access.
         raise Type_Error;
      end if;
      return new O_Enode_Address'(Kind => OE_Unchecked_Address,
                                  Rtype => Atype,
                                  Ref => False,
                                  Lvalue => Lvalue);
   end New_Unchecked_Address;

   function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode
   is
      subtype O_Enode_Address is O_Enode_Type (OE_Address);
   begin
      Check_Ref (Lvalue);
      if Atype.Kind /= ON_Access_Type then
         --  An address is of type access.
         raise Type_Error;
      end if;
      if Get_Base_Type (Lvalue.Rtype) /= Get_Base_Type (Atype.D_Type) then
         raise Type_Error;
      end if;
      return new O_Enode_Address'(Kind => OE_Address,
                                  Rtype => Atype,
                                  Ref => False,
                                  Lvalue => Lvalue);
   end New_Address;

   function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
     return O_Cnode
   is
      subtype O_Cnode_Address is O_Cnode_Type (OC_Unchecked_Address);
   begin
      Check_Scope (Decl);
      if Atype.Kind /= ON_Access_Type then
         --  An address is of type access.
         raise Type_Error;
      end if;
      return new O_Cnode_Address'(Kind => OC_Unchecked_Address,
                                  Ctype => Atype,
                                  Ref => False,
                                  Decl => Decl);
   end New_Global_Unchecked_Address;

   function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode
   is
      subtype O_Cnode_Address is O_Cnode_Type (OC_Address);
   begin
      Check_Scope (Decl);
      if Atype.Kind /= ON_Access_Type then
         --  An address is of type access.
         raise Type_Error;
      end if;
      if Get_Base_Type (Decl.Dtype) /= Get_Base_Type (Atype.D_Type) then
         raise Type_Error;
      end if;
      return new O_Cnode_Address'(Kind => OC_Address,
                                  Ctype => Atype,
                                  Ref => False,
                                  Decl => Decl);
   end New_Global_Address;

   function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
     return O_Cnode
   is
      subtype O_Cnode_Subprg_Address is O_Cnode_Type (OC_Subprogram_Address);
   begin
      if Atype.Kind /= ON_Access_Type then
         --  An address is of type access.
         raise Type_Error;
      end if;
      return new O_Cnode_Subprg_Address'(Kind => OC_Subprogram_Address,
                                         Ctype => Atype,
                                         Ref => False,
                                         Decl => Subprg);
   end New_Subprogram_Address;

   --  Raise TYPE_ERROR is ATYPE is a composite type.
   procedure Check_Not_Composite (Atype : O_Tnode) is
   begin
      case Atype.Kind is
         when ON_Boolean_Type
           | ON_Unsigned_Type
           | ON_Signed_Type
           | ON_Float_Type
           | ON_Enum_Type
           | ON_Access_Type=>
            return;
         when ON_Array_Type
           | ON_Record_Type
           | ON_Union_Type
           | ON_Array_Sub_Type =>
            raise Type_Error;
      end case;
   end Check_Not_Composite;

   function New_Value (Lvalue : O_Lnode) return O_Enode is
      subtype O_Enode_Value is O_Enode_Type (OE_Value);
   begin
      Check_Not_Composite (Lvalue.Rtype);
      Check_Ref (Lvalue);
      return new O_Enode_Value'(Kind => OE_Value,
                                Rtype => Lvalue.Rtype,
                                Ref => False,
                                Value => Lvalue);
   end New_Value;

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

   function New_Lit (Lit : O_Cnode) return O_Enode is
      subtype O_Enode_Lit is O_Enode_Type (OE_Lit);
   begin
      Check_Not_Composite (Lit.Ctype);
      return new O_Enode_Lit'(Kind => OE_Lit,
                              Rtype => Lit.Ctype,
                              Ref => False,
                              Lit => Lit);
   end New_Lit;

   ---------------------
   --  Declarations.  --
   ---------------------

   procedure New_Debug_Filename_Decl (Filename : String)
   is
      subtype O_Dnode_Filename_Decl is O_Dnode_Type (ON_Debug_Filename_Decl);
      N : O_Dnode;
   begin
      N := new O_Dnode_Filename_Decl;
      N.Filename := new String'(Filename);
      Add_Decl (N, False);
   end New_Debug_Filename_Decl;

   procedure New_Debug_Line_Decl (Line : Natural)
   is
      subtype O_Dnode_Line_Decl is O_Dnode_Type (ON_Debug_Line_Decl);
      N : O_Dnode;
   begin
      N := new O_Dnode_Line_Decl;
      N.Line := Line;
      Add_Decl (N, False);
   end New_Debug_Line_Decl;

   procedure New_Debug_Comment_Decl (Comment : String)
   is
      subtype O_Dnode_Comment_Decl is O_Dnode_Type (ON_Debug_Comment_Decl);
      N : O_Dnode;
   begin
      N := new O_Dnode_Comment_Decl;
      N.Comment := new String'(Comment);
      Add_Decl (N, False);
   end New_Debug_Comment_Decl;

   procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode)
   is
      N : O_Dnode;
   begin
      if Atype.Decl /= null then
         --  Type was already declared.
         raise Type_Error;
      end if;
      N := new O_Dnode_Type (ON_Type_Decl);
      N.Name := Ident;
      N.Dtype := Atype;
      Atype.Decl := N;
      Add_Decl (N);
   end New_Type_Decl;

   procedure Check_Object_Storage (Storage : O_Storage) is
   begin
      if Current_Function /= null then
         --  Inside a subprogram.
         case Storage is
            when O_Storage_Public =>
               --  Cannot create public variables inside a subprogram.
               raise Syntax_Error;
            when O_Storage_Private
              | O_Storage_Local
              | O_Storage_External =>
               null;
         end case;
      else
         --  Global scope.
         case Storage is
            when O_Storage_Public
              | O_Storage_Private
              | O_Storage_External =>
               null;
            when O_Storage_Local =>
               --  Cannot create a local variables outside a subprogram.
               raise Syntax_Error;
         end case;
      end if;
   end Check_Object_Storage;

   procedure New_Const_Decl
     (Res : out O_Dnode;
      Ident : O_Ident;
      Storage : O_Storage;
      Atype : O_Tnode)
   is
      subtype O_Dnode_Const is O_Dnode_Type (ON_Const_Decl);
   begin
      Check_Complete_Type (Atype);
      if Storage = O_Storage_Local then
         --  A constant cannot be local.
         raise Syntax_Error;
      end if;
      Check_Object_Storage (Storage);
      Res := new O_Dnode_Const'(Kind => ON_Const_Decl,
                                Name => Ident,
                                Next => null,
                                Dtype => Atype,
                                Storage => Storage,
                                Scope => Current_Decl_Scope.Parent,
                                Lineno => 0,
                                Const_Value => O_Dnode_Null);
      Add_Decl (Res);
   end New_Const_Decl;

   procedure Start_Const_Value (Const : in out O_Dnode)
   is
      subtype O_Dnode_Const_Value is O_Dnode_Type (ON_Const_Value);
      N : O_Dnode;
      Temp : constant O_Dnode := Const;
   begin
      if Const.Const_Value /= O_Dnode_Null then
         --  Constant already has a value.
         raise Syntax_Error;
      end if;

      if Const.Storage = O_Storage_External then
         --  An external constant must not have a value.
         raise Syntax_Error;
      end if;

      --  FIXME: check scope is the same.

      N := new O_Dnode_Const_Value'(Kind => ON_Const_Value,
                                    Name => Const.Name,
                                    Next => null,
                                    Dtype => Const.Dtype,
                                    Storage => Const.Storage,
                                    Scope => Current_Decl_Scope.Parent,
                                    Lineno => 0,
                                    Const_Decl => Const,
                                    Value => O_Cnode_Null);
      Temp.Const_Value := N;
      Const := Temp;
      Add_Decl (N, False);
   end Start_Const_Value;

   procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode)
   is
      Temp : constant O_Dnode := Const;
   begin

      if Const.Const_Value = O_Dnode_Null then
         --  Start_Const_Value not called.
         raise Syntax_Error;
      end if;
      if Const.Const_Value.Value /= O_Cnode_Null then
         --  Finish_Const_Value already called.
         raise Syntax_Error;
      end if;
      if Val = O_Cnode_Null then
         --  No value or bad type.
         raise Type_Error;
      end if;
      Check_Type (Val.Ctype, Const.Dtype);
      Temp.Const_Value.Value := Val;
      Const := Temp;
   end Finish_Const_Value;

   procedure New_Var_Decl
     (Res : out O_Dnode;
      Ident : O_Ident;
      Storage : O_Storage;
      Atype : O_Tnode)
   is
      subtype O_Dnode_Var is O_Dnode_Type (ON_Var_Decl);
   begin
      Check_Complete_Type (Atype);
      Check_Object_Storage (Storage);
      Res := new O_Dnode_Var'(Kind => ON_Var_Decl,
                              Name => Ident,
                              Next => null,
                              Dtype => Atype,
                              Storage => Storage,
                              Lineno => 0,
                              Scope => Current_Decl_Scope.Parent);
      Add_Decl (Res);
   end New_Var_Decl;

   procedure Start_Subprogram_Decl_1
     (Interfaces : out O_Inter_List;
      Ident : O_Ident;
      Storage : O_Storage;
      Rtype : O_Tnode)
   is
      subtype O_Dnode_Function is O_Dnode_Type (ON_Function_Decl);
      N : O_Dnode;
   begin
      N := new O_Dnode_Function'(Kind => ON_Function_Decl,
                                 Next => null,
                                 Name => Ident,
                                 Dtype => Rtype,
                                 Storage => Storage,
                                 Scope => Current_Decl_Scope.Parent,
                                 Lineno => 0,
                                 Interfaces => null,
                                 Func_Body => null,
                                 Alive => False);
      Add_Decl (N);
      Interfaces.Func := N;
      Interfaces.Last := null;
   end Start_Subprogram_Decl_1;

   procedure Start_Function_Decl
     (Interfaces : out O_Inter_List;
      Ident : O_Ident;
      Storage : O_Storage;
      Rtype : O_Tnode)
   is
   begin
      Check_Not_Composite (Rtype);
      Check_Complete_Type (Rtype);
      Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, Rtype);
   end Start_Function_Decl;

   procedure Start_Procedure_Decl
     (Interfaces : out O_Inter_List;
      Ident : O_Ident;
      Storage : O_Storage) is
   begin
      Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, null);
   end Start_Procedure_Decl;

   procedure New_Interface_Decl
     (Interfaces : in out O_Inter_List;
      Res : out O_Dnode;
      Ident : O_Ident;
      Atype : O_Tnode)
   is
      subtype O_Dnode_Interface is O_Dnode_Type (ON_Interface_Decl);
   begin
      Check_Not_Composite (Atype);
      Check_Complete_Type (Atype);
      Res := new O_Dnode_Interface'(Kind => ON_Interface_Decl,
                                    Next => null,
                                    Name => Ident,
                                    Dtype => Atype,
                                    Storage => O_Storage_Private,
                                    Scope => Current_Decl_Scope.Parent,
                                    Lineno => 0,
                                    Func_Scope => Interfaces.Func);
      if Interfaces.Last = null then
         Interfaces.Func.Interfaces := Res;
      else
         Interfaces.Last.Next := Res;
      end if;
      Interfaces.Last := Res;
   end New_Interface_Decl;

   procedure Finish_Subprogram_Decl
     (Interfaces : in out O_Inter_List; Res : out O_Dnode)
   is
   begin
      Res := Interfaces.Func;
   end Finish_Subprogram_Decl;

   procedure Start_Subprogram_Body (Func : O_Dnode)
   is
      B : O_Dnode;
      S : O_Snode;
   begin
      if Func.Func_Body /= null then
         --  Function was already declared.
         raise Syntax_Error;
      end if;
      S := new O_Snode_Type (ON_Declare_Stmt);
      S.all := O_Snode_Type'(Kind => ON_Declare_Stmt,
                             Next => null,
                             Decls => null,
                             Stmts => null,
                             Lineno => 0,
                             Alive => True);
      B := new O_Dnode_Type (ON_Function_Body);
      B.all := O_Dnode_Type'(ON_Function_Body,
                             Name => Func.Name,
                             Dtype => Func.Dtype,
                             Storage => Func.Storage,
                             Scope => Current_Decl_Scope.Parent,
                             Lineno => 0,
                             Func_Decl => Func,
                             Func_Stmt => S,
                             Next => null);
      Add_Decl (B, False);
      Func.Func_Body := B;
      Push_Decl_Scope (S);
      Push_Stmt_Scope
        (new Stmt_Function_Scope_Type'(Kind => Stmt_Function,
                                       Parent => S,
                                       Prev => Current_Stmt_Scope,
                                       Prev_Function => Current_Function,
                                       Decl => Func));
      Current_Function := Current_Stmt_Scope;
      Func.Alive := True;
   end Start_Subprogram_Body;

   procedure Finish_Subprogram_Body is
   begin
      Pop_Decl_Scope;
      if Current_Function.Kind /= Stmt_Function then
         --  Internal error.
         raise Syntax_Error;
      end if;
      Current_Function.Decl.Alive := False;
      Current_Function := Current_Function.Prev_Function;
      Pop_Stmt_Scope (Stmt_Function);
   end Finish_Subprogram_Body;

   -------------------
   --  Statements.  --
   -------------------

   procedure New_Debug_Line_Stmt (Line : Natural)
   is
      subtype O_Snode_Line_Stmt is O_Snode_Type (ON_Debug_Line_Stmt);
   begin
      Add_Stmt (new O_Snode_Line_Stmt'(Kind => ON_Debug_Line_Stmt,
                                       Next => null,
                                       Lineno => 0,
                                       Line => Line));
   end New_Debug_Line_Stmt;

   procedure New_Debug_Comment_Stmt (Comment : String)
   is
      subtype O_Snode_Comment_Stmt is O_Snode_Type (ON_Debug_Comment_Stmt);
   begin
      Add_Stmt (new O_Snode_Comment_Stmt'(Kind => ON_Debug_Comment_Stmt,
                                          Next => null,
                                          Lineno => 0,
                                          Comment => new String'(Comment)));
   end New_Debug_Comment_Stmt;

   procedure Start_Declare_Stmt
   is
      N : O_Snode;
   begin
      N := new O_Snode_Type (ON_Declare_Stmt);
      Add_Stmt (N);
      Push_Decl_Scope (N);
      Push_Stmt_Scope
        (new Stmt_Declare_Scope_Type'(Kind => Stmt_Declare,
                                      Parent => N,
                                      Prev => Current_Stmt_Scope));
   end Start_Declare_Stmt;

   procedure Finish_Declare_Stmt is
   begin
      Pop_Decl_Scope;
      Pop_Stmt_Scope (Stmt_Declare);
   end Finish_Declare_Stmt;

   procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode)
   is
      N : O_Snode;
   begin
      Check_Type (Target.Rtype, Value.Rtype);
      Check_Not_Composite (Target.Rtype);
      Check_Ref (Target);
      Check_Ref (Value);
      N := new O_Snode_Type (ON_Assign_Stmt);
      N.all := O_Snode_Type'(Kind => ON_Assign_Stmt,
                             Next => null,
                             Lineno => 0,
                             Target => Target,
                             Value => Value);
      Add_Stmt (N);
   end New_Assign_Stmt;

   procedure New_Return_Stmt_1 (Value : O_Enode)
   is
      subtype O_Snode_Return_Stmt is O_Snode_Type (ON_Return_Stmt);
      N : O_Snode;
   begin
      N := new O_Snode_Return_Stmt'(Kind => ON_Return_Stmt,
                                    Next => null,
                                    Lineno => 0,
                                    Ret_Val => Value);
      Add_Stmt (N);
   end New_Return_Stmt_1;

   procedure New_Return_Stmt (Value : O_Enode)
   is
   begin
      if Current_Function = null
        or else Current_Function.Decl.Dtype = O_Tnode_Null
      then
         -- Either not in a function or in a procedure.
         raise Syntax_Error;
      end if;
      Check_Type (Value.Rtype, Current_Function.Decl.Dtype);
      Check_Ref (Value);
      New_Return_Stmt_1 (Value);
   end New_Return_Stmt;

   procedure New_Return_Stmt is
   begin
      if Current_Function = null
        or else Current_Function.Decl.Dtype /= O_Tnode_Null
      then
         -- Not in a procedure.
         raise Syntax_Error;
      end if;
      New_Return_Stmt_1 (null);
   end New_Return_Stmt;

   procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode)
   is
   begin
      Check_Scope (Subprg);
      Assocs.Subprg := Subprg;
      Assocs.Interfaces := Subprg.Interfaces;
      Assocs.First := null;
      Assocs.Last := null;
   end Start_Association;

   procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode)
   is
      N : O_Anode;
   begin
      Check_Type (Assocs.Interfaces.Dtype, Val.Rtype);
      Assocs.Interfaces := Assocs.Interfaces.Next;
      Check_Ref (Val);
      N := new O_Anode_Type'(Next => null, Formal => null, Actual => Val);
      if Assocs.Last = null then
         Assocs.First := N;
      else
         Assocs.Last.Next := N;
      end if;
      Assocs.Last := N;
   end New_Association;

   function New_Function_Call (Assocs : O_Assoc_List) return O_Enode
   is
      subtype O_Enode_Call is O_Enode_Type (OE_Function_Call);
      Res : O_Enode;
   begin
      if Assocs.Interfaces /= null then
         --  Not enough arguments.
         raise Syntax_Error;
      end if;
      if Assocs.Subprg.Dtype = null then
         --  This is a procedure.
         raise Syntax_Error;
      end if;

      Res := new O_Enode_Call'(Kind => OE_Function_Call,
                               Rtype => Assocs.Subprg.Dtype,
                               Ref => False,
                               Func => Assocs.Subprg,
                               Assoc => Assocs.First);
      return Res;
   end New_Function_Call;

   procedure New_Procedure_Call (Assocs : in out O_Assoc_List)
   is
      N : O_Snode;
   begin
      if Assocs.Interfaces /= null then
         --  Not enough arguments.
         raise Syntax_Error;
      end if;
      if Assocs.Subprg.Dtype /= null then
         --  This is a function.
         raise Syntax_Error;
      end if;
      N := new O_Snode_Type (ON_Call_Stmt);
      N.Proc := Assocs.Subprg;
      N.Assoc := Assocs.First;
      Add_Stmt (N);
   end New_Procedure_Call;

   procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode);

   procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode)
   is
      subtype O_Snode_If is O_Snode_Type (ON_If_Stmt);
      N : O_Snode;
   begin
      --  Note: no checks are performed here, since they are done in
      --  new_elsif_stmt.
      N := new O_Snode_If'(Kind => ON_If_Stmt,
                           Next => null,
                           Lineno => 0,
                           Elsifs => null,
                           If_Last => null);
      Add_Stmt (N);
      Push_Stmt_Scope (new Stmt_If_Scope_Type'(Kind => Stmt_If,
                                               Parent => N,
                                               Prev => Current_Stmt_Scope,
                                               Last_Elsif => null));
      New_Elsif_Stmt (Block, Cond);
   end Start_If_Stmt;

   procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode)
   is
      pragma Unreferenced (Block);
      N : O_Snode;
   begin
      if Cond /= null then
         if Cond.Rtype.Kind /= ON_Boolean_Type then
            raise Type_Error;
         end if;
         Check_Ref (Cond);
      end if;
      N := new O_Snode_Type (ON_Elsif_Stmt);
      N.all := O_Snode_Type'(Kind => ON_Elsif_Stmt,
                             Next => null,
                             Lineno => 0,
                             Cond => Cond,
                             Next_Elsif => null);
      if Current_Stmt_Scope.Kind /= Stmt_If then
         raise Syntax_Error;
      end if;
      Add_Stmt (N);
      if Current_Stmt_Scope.Last_Elsif = null then
         Current_Stmt_Scope.Parent.Elsifs := N;
      else
         --  Check for double 'else'
         if Current_Stmt_Scope.Last_Elsif.Cond = null then
            raise Syntax_Error;
         end if;
         Current_Stmt_Scope.Last_Elsif.Next_Elsif := N;
      end if;
      Current_Stmt_Scope.Last_Elsif := N;
   end New_Elsif_Stmt;

   procedure New_Else_Stmt (Block : in out O_If_Block) is
   begin
      New_Elsif_Stmt (Block, null);
   end New_Else_Stmt;

   procedure Finish_If_Stmt (Block : in out O_If_Block)
   is
      pragma Unreferenced (Block);
      Parent : O_Snode;
   begin
      Parent := Current_Stmt_Scope.Parent;
      Pop_Stmt_Scope (Stmt_If);
      Parent.If_Last := Current_Decl_Scope.Last_Stmt;
   end Finish_If_Stmt;

   procedure Start_Loop_Stmt (Label : out O_Snode)
   is
      subtype O_Snode_Loop_Type is O_Snode_Type (ON_Loop_Stmt);
   begin
      Current_Loop_Level := Current_Loop_Level + 1;
      Label := new O_Snode_Loop_Type'(Kind => ON_Loop_Stmt,
                                      Next => null,
                                      Lineno => 0,
                                      Loop_Last => null,
                                      Loop_Level => Current_Loop_Level);
      Add_Stmt (Label);
      Push_Stmt_Scope (new Stmt_Loop_Scope_Type'(Kind => Stmt_Loop,
                                                 Parent => Label,
                                                 Prev => Current_Stmt_Scope));
   end Start_Loop_Stmt;

   procedure Finish_Loop_Stmt (Label : in out O_Snode)
   is
      pragma Unreferenced (Label);
      Parent : O_Snode;
   begin
      Parent := Current_Stmt_Scope.Parent;
      Pop_Stmt_Scope (Stmt_Loop);
      Parent.Loop_Last := Current_Decl_Scope.Last_Stmt;
      Current_Loop_Level := Current_Loop_Level - 1;
   end Finish_Loop_Stmt;

   procedure New_Exit_Next_Stmt (Kind : ON_Stmt_Kind; L : O_Snode)
   is
      N : O_Snode;
   begin
      N := new O_Snode_Type (Kind);
      N.Next := null;
      N.Loop_Id := L;
      Add_Stmt (N);
   end New_Exit_Next_Stmt;

   procedure New_Exit_Stmt (L : O_Snode) is
   begin
      New_Exit_Next_Stmt (ON_Exit_Stmt, L);
   end New_Exit_Stmt;

   procedure New_Next_Stmt (L : O_Snode) is
   begin
      New_Exit_Next_Stmt (ON_Next_Stmt, L);
   end New_Next_Stmt;

   procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode)
   is
      pragma Unreferenced (Block);
      subtype O_Snode_Case_Type is O_Snode_Type (ON_Case_Stmt);
      N : O_Snode;
   begin
      case Value.Rtype.Kind is
         when ON_Boolean_Type
           | ON_Unsigned_Type
           | ON_Signed_Type
           | ON_Enum_Type =>
            null;
         when others =>
            raise Type_Error;
      end case;
      Check_Ref (Value);
      N := new O_Snode_Case_Type'(Kind => ON_Case_Stmt,
                                  Next => null,
                                  Lineno => 0,
                                  Case_Last => null,
                                  Selector => Value,
                                  Branches => null);
      Add_Stmt (N);
      Push_Stmt_Scope (new Stmt_Case_Scope_Type'(Kind => Stmt_Case,
                                                 Parent => N,
                                                 Prev => Current_Stmt_Scope,
                                                 Last_Branch => null,
                                                 Last_Choice => null,
                                                 Case_Type => Value.Rtype));
   end Start_Case_Stmt;

   procedure Start_Choice (Block : in out O_Case_Block)
   is
      pragma Unreferenced (Block);
      N : O_Snode;
   begin
      if Current_Stmt_Scope.Kind /= Stmt_Case then
         --  You are adding a branch outside a case statment.
         raise Syntax_Error;
      end if;
      if Current_Stmt_Scope.Last_Choice /= null then
         --  You are creating branch while the previous one was not finished.
         raise Syntax_Error;
      end if;

      N := new O_Snode_Type (ON_When_Stmt);
      N.all := O_Snode_Type'(Kind => ON_When_Stmt,
                             Next => null,
                             Lineno => 0,
                             Choice_List => null,
                             Next_Branch => null);
      if Current_Stmt_Scope.Last_Branch = null then
         Current_Stmt_Scope.Parent.Branches := N;
      else
         Current_Stmt_Scope.Last_Branch.Next_Branch := N;
      end if;
      Current_Stmt_Scope.Last_Branch := N;
      Current_Stmt_Scope.Last_Choice := null;
      Add_Stmt (N);
   end Start_Choice;

   procedure Add_Choice (Block : in out O_Case_Block; Choice : O_Choice)
   is
      pragma Unreferenced (Block);
   begin
      if Current_Stmt_Scope.Kind /= Stmt_Case then
         --  You are adding a choice not inside a case statement.
         raise Syntax_Error;
      end if;
      if Current_Stmt_Scope.Last_Branch = null then
         --  You are not inside a branch.
         raise Syntax_Error;
      end if;
      if Current_Stmt_Scope.Last_Choice = null then
         if Current_Stmt_Scope.Last_Branch.Choice_List /= null then
            --  The branch was already closed.
            raise Syntax_Error;
         end if;
         Current_Stmt_Scope.Last_Branch.Choice_List := Choice;
      else
         Current_Stmt_Scope.Last_Choice.Next := Choice;
      end if;
      Current_Stmt_Scope.Last_Choice := Choice;
   end Add_Choice;

   procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode)
   is
      N : O_Choice;
   begin
      if Current_Stmt_Scope.Kind /= Stmt_Case then
         --  You are creating a choice not inside a case statement.
         raise Syntax_Error;
      end if;
      if Current_Stmt_Scope.Case_Type /= Expr.Ctype then
         --  Expr type is not the same as choice type.
         raise Type_Error;
      end if;

      N := new O_Choice_Type (ON_Choice_Expr);
      N.all := O_Choice_Type'(Kind => ON_Choice_Expr,
                              Next => null,
                              Expr => Expr);
      Add_Choice (Block, N);
   end New_Expr_Choice;

   procedure New_Range_Choice (Block : in out O_Case_Block;
                               Low, High : O_Cnode)
   is
      N : O_Choice;
   begin
      if Current_Stmt_Scope.Kind /= Stmt_Case then
         --  You are creating a choice not inside a case statement.
         raise Syntax_Error;
      end if;
      if Current_Stmt_Scope.Case_Type /= Low.Ctype
        or Current_Stmt_Scope.Case_Type /= High.Ctype
      then
         --  Low/High type is not the same as choice type.
         raise Type_Error;
      end if;

      N := new O_Choice_Type (ON_Choice_Range);
      N.all := O_Choice_Type'(Kind => ON_Choice_Range,
                              Next => null,
                              Low => Low,
                              High => High);
      Add_Choice (Block, N);
   end New_Range_Choice;

   procedure New_Default_Choice (Block : in out O_Case_Block)
   is
      N : O_Choice;
   begin
      if Current_Stmt_Scope.Kind /= Stmt_Case then
         --  You are creating a choice not inside a case statement.
         raise Syntax_Error;
      end if;

      N := new O_Choice_Type (ON_Choice_Default);
      N.all := O_Choice_Type'(Kind => ON_Choice_Default,
                             Next => null);
      Add_Choice (Block, N);
   end New_Default_Choice;

   procedure Finish_Choice (Block : in out O_Case_Block)
   is
      pragma Unreferenced (Block);
   begin
      if Current_Stmt_Scope.Kind /= Stmt_Case then
         --  You are adding a choice not inside a case statement.
         raise Syntax_Error;
      end if;
      if Current_Stmt_Scope.Last_Branch = null then
         --  You are not inside a branch.
         raise Syntax_Error;
      end if;
      if Current_Stmt_Scope.Last_Choice = null then
         --  The branch is empty or you are not inside a branch.
         raise Syntax_Error;
      end if;
      Current_Stmt_Scope.Last_Choice := null;
   end Finish_Choice;

   procedure Finish_Case_Stmt (Block : in out O_Case_Block)
   is
      pragma Unreferenced (Block);
      Parent : O_Snode;
   begin
      Parent := Current_Stmt_Scope.Parent;
      Pop_Stmt_Scope (Stmt_Case);
      Parent.Case_Last := Current_Decl_Scope.Last_Stmt;
   end Finish_Case_Stmt;

   procedure Init is
   begin
      Top := new O_Snode_Type (ON_Declare_Stmt);
      Push_Decl_Scope (Top);
   end Init;

   procedure Finish is
   begin
      Pop_Decl_Scope;
   end Finish;
end Ortho_Debug;