path: root/ortho/mcode/ortho_code-decls.adb

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

package body Ortho_Code.Decls is
   --  Common fields:
   --    kind: 4 bits
   --    storage: 2 bits
   --    reg : 8 bits
   --    depth : 16 bits
   --    flags: addr + 9
   --  Additionnal fields:
   --    OD_Type: Id, dtype
   --    OD_Var: Id, Dtype, symbol
   --    OD_Local: Id, Dtype, offset/reg
   --    OD_Const: Id, Dtype, Val, Symbol?
   --    OD_Function: Id, Dtype [interfaces follows], Symbol
   --    OD_Procedure: Id [interfaces follows], Symbol
   --    OD_Interface: Id, Dtype, offset/reg
   --    OD_Begin: Last
   --    OD_Body: Decl, Stmt, Parent
   type Dnode_Common (Kind : OD_Kind := OD_Type) is record
      Storage : O_Storage;

      --  True if the address of the declaration is taken.
      Flag_Addr : Boolean;

      Flag2 : Boolean;

      Reg : O_Reg;

      --  Depth of the declaration.
      Depth : O_Depth;

      case Kind is
         when OD_Type
           | OD_Const
           | OD_Var
           | OD_Local
           | OD_Function
           | OD_Procedure
           | OD_Interface =>
            --  Identifier of this declaration.
            Id : O_Ident;
            --  Type of this declaration.
            Dtype : O_Tnode;
            --  Symbol or offset.
            Ref : Int32;
            --  For const: the value.
            --  For subprg: size of pushed arguments.
            Info2 : Int32;
         when OD_Block =>
            --  Last declaration of this block.
            Last : O_Dnode;
            --  Max stack offset.
            Block_Max_Stack : Uns32;
            --  Infos: may be used to store symbols.
            Block_Info1 : Int32;
            Block_Info2 : Int32;
         when OD_Body =>
            --  Corresponding declaration (function/procedure).
            Body_Decl : O_Dnode;
            --  Entry statement for this body.
            Body_Stmt : O_Enode;
            --  Parent (as a body) of this body or null if at top level.
            Body_Parent : O_Dnode;
            Body_Info : Int32;
         when OD_Const_Val =>
            --  Corresponding declaration.
            Val_Decl : O_Dnode;
            --  Value.
            Val_Val : O_Cnode;
      end case;
   end record;

   pragma Pack (Dnode_Common);

   package Dnodes is new GNAT.Table
     (Table_Component_Type => Dnode_Common,
      Table_Index_Type => O_Dnode,
      Table_Low_Bound => O_Dnode_First,
      Table_Initial => 128,
      Table_Increment => 100);

   package TDnodes is new GNAT.Table
     (Table_Component_Type => O_Dnode,
      Table_Index_Type => O_Tnode,
      Table_Low_Bound => O_Tnode_First,
      Table_Initial => 1,
      Table_Increment => 100);

   Context : O_Dnode := O_Dnode_Null;

   function Get_Decl_Type (Decl : O_Dnode) return O_Tnode is
   begin
      return Dnodes.Table (Decl).Dtype;
   end Get_Decl_Type;

   function Get_Decl_Kind (Decl : O_Dnode) return OD_Kind is
   begin
      return Dnodes.Table (Decl).Kind;
   end Get_Decl_Kind;

   function Get_Decl_Storage (Decl : O_Dnode) return O_Storage is
   begin
      return Dnodes.Table (Decl).Storage;
   end Get_Decl_Storage;

   procedure Set_Decl_Storage (Decl : O_Dnode; Storage : O_Storage) is
   begin
      Dnodes.Table (Decl).Storage := Storage;
   end Set_Decl_Storage;

   function Get_Decl_Reg (Decl : O_Dnode) return O_Reg is
   begin
      return Dnodes.Table (Decl).Reg;
   end Get_Decl_Reg;

   procedure Set_Decl_Reg (Decl : O_Dnode; Reg : O_Reg) is
   begin
      Dnodes.Table (Decl).Reg := Reg;
   end Set_Decl_Reg;

   function Get_Decl_Depth (Decl : O_Dnode) return O_Depth is
   begin
      return Dnodes.Table (Decl).Depth;
   end Get_Decl_Depth;

   function Get_Decl_Chain (Decl : O_Dnode) return O_Dnode is
   begin
      case Get_Decl_Kind (Decl) is
         when OD_Block =>
            return Get_Block_Last (Decl) + 1;
         when OD_Body =>
            return Get_Block_Last (Decl + 1) + 1;
         when others =>
            return Decl + 1;
      end case;
   end Get_Decl_Chain;

   function Get_Body_Stmt (Bod : O_Dnode) return O_Enode is
   begin
      return Dnodes.Table (Bod).Body_Stmt;
   end Get_Body_Stmt;

   function Get_Body_Decl (Bod : O_Dnode) return O_Dnode is
   begin
      return Dnodes.Table (Bod).Body_Decl;
   end Get_Body_Decl;

   function Get_Body_Parent (Bod : O_Dnode) return O_Dnode is
   begin
      return Dnodes.Table (Bod).Body_Parent;
   end Get_Body_Parent;

   function Get_Body_Info (Bod : O_Dnode) return Int32 is
   begin
      return Dnodes.Table (Bod).Body_Info;
   end Get_Body_Info;

   procedure Set_Body_Info (Bod : O_Dnode; Info : Int32) is
   begin
      Dnodes.Table (Bod).Body_Info := Info;
   end Set_Body_Info;

   function Get_Decl_Ident (Decl : O_Dnode) return O_Ident is
   begin
      return Dnodes.Table (Decl).Id;
   end Get_Decl_Ident;

   function Get_Decl_Last return O_Dnode is
   begin
      return Dnodes.Last;
   end Get_Decl_Last;

   function Get_Block_Last (Blk : O_Dnode) return O_Dnode is
   begin
      return Dnodes.Table (Blk).Last;
   end Get_Block_Last;

   function Get_Block_Max_Stack (Blk : O_Dnode) return Uns32 is
   begin
      return Dnodes.Table (Blk).Block_Max_Stack;
   end Get_Block_Max_Stack;

   procedure Set_Block_Max_Stack (Blk : O_Dnode; Max : Uns32) is
   begin
      Dnodes.Table (Blk).Block_Max_Stack := Max;
   end Set_Block_Max_Stack;

   function Get_Block_Info1 (Blk : O_Dnode) return Int32 is
   begin
      return Dnodes.Table (Blk).Block_Info1;
   end Get_Block_Info1;

   procedure Set_Block_Info1 (Blk : O_Dnode; Info : Int32) is
   begin
      Dnodes.Table (Blk).Block_Info1 := Info;
   end Set_Block_Info1;

   function Get_Block_Info2 (Blk : O_Dnode) return Int32 is
   begin
      return Dnodes.Table (Blk).Block_Info2;
   end Get_Block_Info2;

   procedure Set_Block_Info2 (Blk : O_Dnode; Info : Int32) is
   begin
      Dnodes.Table (Blk).Block_Info2 := Info;
   end Set_Block_Info2;

   function Get_Subprg_Interfaces (Decl : O_Dnode) return O_Dnode
   is
      Res : constant O_Dnode := Decl + 1;
   begin
      if Get_Decl_Kind (Res) = OD_Interface then
         return Res;
      else
         return O_Dnode_Null;
      end if;
   end Get_Subprg_Interfaces;

   function Get_Interface_Chain (Decl : O_Dnode) return O_Dnode
   is
      Res : constant O_Dnode := Decl + 1;
   begin
      if Get_Decl_Kind (Res) = OD_Interface then
         return Res;
      else
         return O_Dnode_Null;
      end if;
   end Get_Interface_Chain;

   function Get_Val_Decl (Decl : O_Dnode) return O_Dnode is
   begin
      return Dnodes.Table (Decl).Val_Decl;
   end Get_Val_Decl;

   function Get_Val_Val (Decl : O_Dnode) return O_Cnode is
   begin
      return Dnodes.Table (Decl).Val_Val;
   end Get_Val_Val;

   Cur_Depth : O_Depth := O_Toplevel;

   procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is
   begin
      Dnodes.Append (Dnode_Common'(Kind => OD_Type,
                                   Storage => O_Storage_Private,
                                   Depth => Cur_Depth,
                                   Reg => R_Nil,
                                   Id => Ident,
                                   Dtype => Atype,
                                   Ref => 0,
                                   Info2 => 0,
                                   others => False));
      if Flags.Flag_Type_Name then
         declare
            L : O_Tnode;
         begin
            L := TDnodes.Last;
            if Atype > L then
               TDnodes.Set_Last (Atype);
               TDnodes.Table (L + 1 .. Atype) := (others => O_Dnode_Null);
            end if;
         end;
         TDnodes.Table (Atype) := Dnodes.Last;
      end if;
   end New_Type_Decl;

   function Get_Type_Decl (Atype : O_Tnode) return O_Dnode is
   begin
      if Atype <= TDnodes.Last then
         return TDnodes.Table (Atype);
      else
         return O_Dnode_Null;
      end if;
   end Get_Type_Decl;

   procedure New_Const_Decl
     (Res : out O_Dnode;
      Ident : O_Ident;
      Storage : O_Storage;
      Atype : O_Tnode)
   is
   begin
      Dnodes.Append (Dnode_Common'(Kind => OD_Const,
                                   Storage => Storage,
                                   Depth => Cur_Depth,
                                   Reg => R_Nil,
                                   Id => Ident,
                                   Dtype => Atype,
                                   Ref => 0,
                                   Info2 => 0,
                                   others => False));
      Res := Dnodes.Last;
      if not Flag_Debug_Hli then
         Expand_Const_Decl (Res);
      end if;
   end New_Const_Decl;

   procedure New_Const_Value (Cst : O_Dnode; Val : O_Cnode) is
   begin
      if Dnodes.Table (Cst).Info2 /= 0 then
         --  Value was already set.
         raise Syntax_Error;
      end if;
      Dnodes.Table (Cst).Info2 := Int32 (Val);
      if Flag_Debug_Hli then
         Dnodes.Append (Dnode_Common'(Kind => OD_Const_Val,
                                      Storage => O_Storage_Private,
                                      Depth => Cur_Depth,
                                      Reg => R_Nil,
                                      Val_Decl => Cst,
                                      Val_Val => Val,
                                      others => False));
      else
         Expand_Const_Value (Cst, Val);
      end if;
   end New_Const_Value;

   procedure New_Var_Decl
     (Res : out O_Dnode;
      Ident : O_Ident;
      Storage : O_Storage;
      Atype : O_Tnode)
   is
   begin
      if Storage = O_Storage_Local then
         Dnodes.Append (Dnode_Common'(Kind => OD_Local,
                                      Storage => Storage,
                                      Depth => Cur_Depth,
                                      Reg => R_Nil,
                                      Id => Ident,
                                      Dtype => Atype,
                                      Ref => 0,
                                      Info2 => 0,
                                      others => False));
         Res := Dnodes.Last;
      else
         Dnodes.Append (Dnode_Common'(Kind => OD_Var,
                                      Storage => Storage,
                                      Depth => Cur_Depth,
                                      Reg => R_Nil,
                                      Id => Ident,
                                      Dtype => Atype,
                                      Ref => 0,
                                      Info2 => 0,
                                      others => False));
         Res := Dnodes.Last;
         if not Flag_Debug_Hli then
            Expand_Var_Decl (Res);
         end if;
      end if;
   end New_Var_Decl;

   Static_Chain_Id : O_Ident := O_Ident_Nul;

   procedure Add_Static_Chain (Interfaces : in out O_Inter_List)
   is
      Res : O_Dnode;
   begin
      if Static_Chain_Id = O_Ident_Nul then
         Static_Chain_Id := Ortho_Ident.Get_Identifier ("STATIC_CHAIN");
      end if;

      Dnodes.Append (Dnode_Common'(Kind => OD_Interface,
                                   Storage => O_Storage_Local,
                                   Depth => Cur_Depth + 1,
                                   Reg => R_Nil,
                                   Id => Static_Chain_Id,
                                   Dtype => O_Tnode_Ptr,
                                   Ref => 0,
                                   Info2 => 0,
                                   others => False));
      Res := Dnodes.Last;
      New_Interface (Res, Interfaces.Abi);
   end Add_Static_Chain;

   procedure Start_Subprogram_Decl (Interfaces : out O_Inter_List)
   is
      Storage : O_Storage;
   begin
      Storage := Get_Decl_Storage (Dnodes.Last);
      if Cur_Depth /= O_Toplevel then
         case Storage is
            when O_Storage_External
              | O_Storage_Local =>
               null;
            when O_Storage_Public =>
               raise Syntax_Error;
            when O_Storage_Private =>
               Storage := O_Storage_Local;
               Set_Decl_Storage (Dnodes.Last, Storage);
         end case;
      end if;
      Start_Subprogram (Dnodes.Last, Interfaces.Abi);
      Interfaces.Decl := Dnodes.Last;
      if Storage = O_Storage_Local then
         Add_Static_Chain (Interfaces);
      end if;
   end Start_Subprogram_Decl;

   procedure Start_Function_Decl
     (Interfaces : out O_Inter_List;
      Ident : O_Ident;
      Storage : O_Storage;
      Rtype : O_Tnode)
   is
   begin
      Dnodes.Append (Dnode_Common'(Kind => OD_Function,
                                   Storage => Storage,
                                   Depth => Cur_Depth,
                                   Reg => R_Nil,
                                   Id => Ident,
                                   Dtype => Rtype,
                                   Ref => 0,
                                   Info2 => 0,
                                   others => False));
      Start_Subprogram_Decl (Interfaces);
   end Start_Function_Decl;

   procedure Start_Procedure_Decl
     (Interfaces : out O_Inter_List;
      Ident : O_Ident;
      Storage : O_Storage)
   is
   begin
      Dnodes.Append (Dnode_Common'(Kind => OD_Procedure,
                                   Storage => Storage,
                                   Depth => Cur_Depth,
                                   Reg => R_Nil,
                                   Id => Ident,
                                   Dtype => O_Tnode_Null,
                                   Ref => 0,
                                   Info2 => 0,
                                   others => False));
      Start_Subprogram_Decl (Interfaces);
   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
   begin
      Dnodes.Append (Dnode_Common'(Kind => OD_Interface,
                                   Storage => O_Storage_Local,
                                   Depth => Cur_Depth + 1,
                                   Reg => R_Nil,
                                   Id => Ident,
                                   Dtype => Atype,
                                   Ref => 0,
                                   Info2 => 0,
                                   others => False));
      Res := Dnodes.Last;
      New_Interface (Res, Interfaces.Abi);
   end New_Interface_Decl;

   procedure Set_Local_Offset (Decl : O_Dnode; Off : Int32) is
   begin
      Dnodes.Table (Decl).Ref := Off;
   end Set_Local_Offset;

   function Get_Local_Offset (Decl : O_Dnode) return Int32 is
   begin
      return Dnodes.Table (Decl).Ref;
   end Get_Local_Offset;

   function Get_Inter_Offset (Inter : O_Dnode) return Int32 is
   begin
      return Dnodes.Table (Inter).Ref;
   end Get_Inter_Offset;

   procedure Set_Decl_Info (Decl : O_Dnode; Ref : Int32) is
   begin
      Dnodes.Table (Decl).Ref := Ref;
   end Set_Decl_Info;

   function Get_Decl_Info (Decl : O_Dnode) return Int32 is
   begin
      return Dnodes.Table (Decl).Ref;
   end Get_Decl_Info;

   procedure Set_Subprg_Stack (Decl : O_Dnode; Val : Int32) is
   begin
      Dnodes.Table (Decl).Info2 := Val;
   end Set_Subprg_Stack;

   function Get_Subprg_Stack (Decl : O_Dnode) return Int32 is
   begin
      return Dnodes.Table (Decl).Info2;
   end Get_Subprg_Stack;

   procedure Finish_Subprogram_Decl
     (Interfaces : in out O_Inter_List; Res : out O_Dnode) is
   begin
      Res := Interfaces.Decl;
      Finish_Subprogram (Res, Interfaces.Abi);
   end Finish_Subprogram_Decl;

   Cur_Block : O_Dnode := O_Dnode_Null;

   function Start_Declare_Stmt return O_Dnode is
   begin
      Dnodes.Append (Dnode_Common'(Kind => OD_Block,
                                   Storage => O_Storage_Local,
                                   Depth => Cur_Depth,
                                   Reg => R_Nil,
                                   Last => O_Dnode_Null,
                                   Block_Max_Stack => 0,
                                   Block_Info1 => 0,
                                   Block_Info2 => 0,
                                   others => False));
      Cur_Block := Dnodes.Last;
      return Cur_Block;
   end Start_Declare_Stmt;

   procedure Finish_Declare_Stmt (Parent : O_Dnode) is
   begin
      Dnodes.Table (Cur_Block).Last := Dnodes.Last;
      Cur_Block := Parent;
   end Finish_Declare_Stmt;

   function Start_Subprogram_Body (Decl : O_Dnode; Stmt : O_Enode)
                                  return O_Dnode
   is
      Res : O_Dnode;
   begin
      Dnodes.Append (Dnode_Common'(Kind => OD_Body,
                                   Storage => O_Storage_Local,
                                   Depth => Cur_Depth,
                                   Reg => R_Nil,
                                   Body_Parent => Context,
                                   Body_Decl => Decl,
                                   Body_Stmt => Stmt,
                                   Body_Info => 0,
                                   others => False));
      Res := Dnodes.Last;
      Context := Res;
      Cur_Depth := Cur_Depth + 1;
      return Res;
   end Start_Subprogram_Body;

   procedure Finish_Subprogram_Body is
   begin
      Cur_Depth := Cur_Depth - 1;
      Context := Get_Body_Parent (Context);
   end Finish_Subprogram_Body;


--    function Image (Decl : O_Dnode) return String is
--    begin
--       return O_Dnode'Image (Decl);
--    end Image;

   procedure Disp_Decl_Name (Decl : O_Dnode)
   is
      use Ada.Text_IO;
      use Ortho_Ident;
      Id : O_Ident;
   begin
      Id := Get_Decl_Ident (Decl);
      if Is_Equal (Id, O_Ident_Nul) then
         declare
            Res : String := O_Dnode'Image (Decl);
         begin
            Res (1) := '?';
            Put (Res);
         end;
      else
         Put (Get_String (Id));
      end if;
   end Disp_Decl_Name;

   procedure Disp_Decl_Storage (Decl : O_Dnode)
   is
      use Ada.Text_IO;
   begin
      case Get_Decl_Storage (Decl) is
         when O_Storage_Local =>
            Put ("local");
         when O_Storage_External =>
            Put ("external");
         when O_Storage_Public =>
            Put ("public");
         when O_Storage_Private =>
            Put ("private");
      end case;
   end Disp_Decl_Storage;

   procedure Disp_Decl (Indent : Natural; Decl : O_Dnode)
   is
      use Ada.Text_IO;
      use Ortho_Ident;
      use Ortho_Code.Debug.Int32_IO;
   begin
      Set_Col (Count (Indent));
      Put (Int32 (Decl), 0);
      Set_Col (Count (7 + Indent));
      case Get_Decl_Kind (Decl) is
         when OD_Type =>
            Put ("type ");
            Disp_Decl_Name (Decl);
            Put (" is ");
            Put (Int32 (Get_Decl_Type (Decl)), 0);
         when OD_Function =>
            Disp_Decl_Storage (Decl);
            Put (" function ");
            Disp_Decl_Name (Decl);
            Put (" return ");
            Put (Int32 (Get_Decl_Type (Decl)), 0);
         when OD_Procedure =>
            Disp_Decl_Storage (Decl);
            Put (" procedure ");
            Disp_Decl_Name (Decl);
         when OD_Interface =>
            Put (" interface ");
            Disp_Decl_Name (Decl);
            Put (": ");
            Put (Int32 (Get_Decl_Type (Decl)), 0);
            Put (", offset=");
            Put (Get_Inter_Offset (Decl), 0);
         when OD_Const =>
            Disp_Decl_Storage (Decl);
            Put (" const ");
            Disp_Decl_Name (Decl);
            Put (": ");
            Put (Int32 (Get_Decl_Type (Decl)), 0);
         when OD_Const_Val =>
            Put ("constant ");
            Disp_Decl_Name (Get_Val_Decl (Decl));
            Put (": ");
            Put (Int32 (Get_Val_Val (Decl)), 0);
         when OD_Local =>
            Put ("local ");
            Disp_Decl_Name (Decl);
            Put (": ");
            Put (Int32 (Get_Decl_Type (Decl)), 0);
            Put (", offset=");
            Put (Get_Inter_Offset (Decl), 0);
         when OD_Var =>
            Disp_Decl_Storage (Decl);
            Put (" var ");
            Disp_Decl_Name (Decl);
            Put (": ");
            Put (Int32 (Get_Decl_Type (Decl)), 0);
         when OD_Body =>
            Put ("body of ");
            Put (Int32 (Get_Body_Decl (Decl)), 0);
            Put (", stmt at ");
            Put (Int32 (Get_Body_Stmt (Decl)), 0);
         when OD_Block =>
            Put ("block until ");
            Put (Int32 (Get_Block_Last (Decl)), 0);
--           when others =>
--              Put (OD_Kind'Image (Get_Decl_Kind (Decl)));
      end case;
      New_Line;
   end Disp_Decl;

   procedure Disp_Decls (Indent : Natural; First, Last : O_Dnode)
   is
      N : O_Dnode;
   begin
      N := First;
      while N <= Last loop
         case Get_Decl_Kind (N) is
            when OD_Body =>
               Disp_Decl (Indent, N);
               Ortho_Code.Exprs.Disp_Subprg_Body
                 (Indent + 2, Get_Body_Stmt (N));
               N := N + 1;
            when OD_Block =>
               --  Skip inner bindings.
               N := Get_Block_Last (N) + 1;
            when others =>
               Disp_Decl (Indent, N);
               N := N + 1;
         end case;
      end loop;
   end Disp_Decls;

   procedure Disp_Block (Indent : Natural; Start : O_Dnode)
   is
      Last : O_Dnode;
   begin
      if Get_Decl_Kind (Start) /= OD_Block then
         Disp_Decl (Indent, Start);
         raise Program_Error;
      end if;
      Last := Get_Block_Last (Start);
      Disp_Decl (Indent, Start);
      Disp_Decls (Indent, Start + 1, Last);
   end Disp_Block;

   procedure Disp_All_Decls
   is
   begin
      if False then
         for I in Dnodes.First .. Dnodes.Last loop
            Disp_Decl (1, I);
         end loop;
      end if;

      Disp_Decls (1, Dnodes.First, Dnodes.Last);
   end Disp_All_Decls;

   procedure Disp_Stats
   is
      use Ada.Text_IO;
   begin
      Put_Line ("Number of Dnodes: " & O_Dnode'Image (Dnodes.Last));
      Put_Line ("Number of TDnodes: " & O_Tnode'Image (TDnodes.Last));
   end Disp_Stats;

   procedure Mark (M : out Mark_Type) is
   begin
      M.Dnode := Dnodes.Last;
      M.TDnode := TDnodes.Last;
   end Mark;

   procedure Release (M : Mark_Type) is
   begin
      Dnodes.Set_Last (M.Dnode);
      TDnodes.Set_Last (M.TDnode);
   end Release;

   procedure Finish is
   begin
      Dnodes.Free;
      TDnodes.Free;
   end Finish;
end Ortho_Code.Decls;