diff options
Diffstat (limited to 'ortho/mcode/ortho_code-decls.adb')
| -rw-r--r-- | ortho/mcode/ortho_code-decls.adb | 783 |
1 files changed, 0 insertions, 783 deletions
diff --git a/ortho/mcode/ortho_code-decls.adb b/ortho/mcode/ortho_code-decls.adb deleted file mode 100644 index fcbf0b0de..000000000 --- a/ortho/mcode/ortho_code-decls.adb +++ /dev/null @@ -1,783 +0,0 @@ --- 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_Subprg_Ext => - -- Chain of interfaces. - Subprg_Inter : O_Dnode; - - 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; - - Use_Subprg_Ext : constant Boolean := False; - - 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 OD_Function - | OD_Procedure => - if Use_Subprg_Ext then - return Decl + 2; - else - return Decl + 1; - end if; - 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 : O_Dnode; - begin - if Use_Subprg_Ext then - Res := Decl + 2; - else - Res := Decl + 1; - end if; - - 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; - - New_Interface_Decl (Interfaces, Res, Static_Chain_Id, O_Tnode_Ptr); - end Add_Static_Chain; - - procedure Start_Subprogram_Decl (Interfaces : out O_Inter_List) - is - Storage : O_Storage; - Decl : constant O_Dnode := Dnodes.Last; - begin - Storage := Get_Decl_Storage (Decl); - 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 (Decl, Storage); - end case; - end if; - if Use_Subprg_Ext then - Dnodes.Append (Dnode_Common'(Kind => OD_Subprg_Ext, - Storage => Storage, - Depth => Cur_Depth, - Reg => R_Nil, - Subprg_Inter => O_Dnode_Null, - others => False)); - end if; - - Start_Subprogram (Decl, Interfaces.Abi); - Interfaces.Decl := Decl; - 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 OD_Subprg_Ext => - Put ("Subprg_Ext"); --- 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 Debug_Decl (Decl : O_Dnode) is - begin - Disp_Decl (1, Decl); - end Debug_Decl; - - pragma Unreferenced (Debug_Decl); - - 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; |