diff options
Diffstat (limited to 'src/ortho/mcode/ortho_mcode.adb')
| -rw-r--r-- | src/ortho/mcode/ortho_mcode.adb | 738 |
1 files changed, 738 insertions, 0 deletions
diff --git a/src/ortho/mcode/ortho_mcode.adb b/src/ortho/mcode/ortho_mcode.adb new file mode 100644 index 000000000..55e890bf3 --- /dev/null +++ b/src/ortho/mcode/ortho_mcode.adb @@ -0,0 +1,738 @@ +-- Mcode back-end for ortho. +-- 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 Ada.Text_IO; +with Ortho_Code.Debug; +with Ortho_Ident; +with Ortho_Code.Abi; +-- with Binary_File; + +package body Ortho_Mcode is + procedure New_Debug_Comment_Stmt (Comment : String) + is + pragma Unreferenced (Comment); + begin + null; + end New_Debug_Comment_Stmt; + + procedure Start_Const_Value (Const : in out O_Dnode) + is + pragma Unreferenced (Const); + begin + null; + end Start_Const_Value; + + procedure Start_Record_Type (Elements : out O_Element_List) is + begin + Ortho_Code.Types.Start_Record_Type + (Ortho_Code.Types.O_Element_List (Elements)); + end Start_Record_Type; + + procedure New_Record_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; Etype : O_Tnode) is + begin + Ortho_Code.Types.New_Record_Field + (Ortho_Code.Types.O_Element_List (Elements), + Ortho_Code.O_Fnode (El), Ident, Ortho_Code.O_Tnode (Etype)); + end New_Record_Field; + + procedure Finish_Record_Type + (Elements : in out O_Element_List; Res : out O_Tnode) is + begin + Ortho_Code.Types.Finish_Record_Type + (Ortho_Code.Types.O_Element_List (Elements), + Ortho_Code.O_Tnode (Res)); + end Finish_Record_Type; + + procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is + begin + Ortho_Code.Types.New_Uncomplete_Record_Type (Ortho_Code.O_Tnode (Res)); + end New_Uncomplete_Record_Type; + + procedure Start_Uncomplete_Record_Type (Res : O_Tnode; + Elements : out O_Element_List) is + begin + Ortho_Code.Types.Start_Uncomplete_Record_Type + (Ortho_Code.O_Tnode (Res), + Ortho_Code.Types.O_Element_List (Elements)); + end Start_Uncomplete_Record_Type; + + procedure Start_Union_Type (Elements : out O_Element_List) is + begin + Ortho_Code.Types.Start_Union_Type + (Ortho_Code.Types.O_Element_List (Elements)); + 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 + Ortho_Code.Types.New_Union_Field + (Ortho_Code.Types.O_Element_List (Elements), + Ortho_Code.O_Fnode (El), + Ident, + Ortho_Code.O_Tnode (Etype)); + end New_Union_Field; + + procedure Finish_Union_Type + (Elements : in out O_Element_List; Res : out O_Tnode) is + begin + Ortho_Code.Types.Finish_Union_Type + (Ortho_Code.Types.O_Element_List (Elements), + Ortho_Code.O_Tnode (Res)); + end Finish_Union_Type; + + function New_Access_Type (Dtype : O_Tnode) return O_Tnode is + begin + return O_Tnode + (Ortho_Code.Types.New_Access_Type (Ortho_Code.O_Tnode (Dtype))); + end New_Access_Type; + + procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is + begin + Ortho_Code.Types.Finish_Access_Type (Ortho_Code.O_Tnode (Atype), + Ortho_Code.O_Tnode (Dtype)); + end Finish_Access_Type; + + procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) + is + pragma Warnings (Off, Const); + begin + New_Const_Value (Ortho_Code.O_Dnode (Const), Ortho_Code.O_Cnode (Val)); + end Finish_Const_Value; + + function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) + return O_Tnode is + begin + return O_Tnode + (Ortho_Code.Types.New_Array_Type (Ortho_Code.O_Tnode (El_Type), + Ortho_Code.O_Tnode (Index_Type))); + end New_Array_Type; + + function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) + return O_Tnode + is + Len : constant Ortho_Code.O_Cnode := Ortho_Code.O_Cnode (Length); + L_Type : Ortho_Code.O_Tnode; + begin + L_Type := Get_Const_Type (Len); + if Get_Type_Kind (L_Type) /= OT_Unsigned then + raise Syntax_Error; + end if; + return O_Tnode (New_Constrained_Array_Type + (Ortho_Code.O_Tnode (Atype), Get_Const_U32 (Len))); + end New_Constrained_Array_Type; + + function New_Unsigned_Type (Size : Natural) return O_Tnode is + begin + return O_Tnode (Ortho_Code.Types.New_Unsigned_Type (Size)); + end New_Unsigned_Type; + + function New_Signed_Type (Size : Natural) return O_Tnode is + begin + return O_Tnode (Ortho_Code.Types.New_Signed_Type (Size)); + end New_Signed_Type; + + function New_Float_Type return O_Tnode is + begin + return O_Tnode (Ortho_Code.Types.New_Float_Type); + 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 + begin + Ortho_Code.Types.New_Boolean_Type (Ortho_Code.O_Tnode (Res), + False_Id, + Ortho_Code.O_Cnode (False_E), + True_Id, + Ortho_Code.O_Cnode (True_E)); + end New_Boolean_Type; + + procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) is + begin + Ortho_Code.Types.Start_Enum_Type (Ortho_Code.Types.O_Enum_List (List), + Size); + end Start_Enum_Type; + + procedure New_Enum_Literal (List : in out O_Enum_List; + Ident : O_Ident; Res : out O_Cnode) is + begin + Ortho_Code.Types.New_Enum_Literal (Ortho_Code.Types.O_Enum_List (List), + Ident, Ortho_Code.O_Cnode (Res)); + end New_Enum_Literal; + + procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is + begin + Ortho_Code.Types.Finish_Enum_Type (Ortho_Code.Types.O_Enum_List (List), + Ortho_Code.O_Tnode (Res)); + end Finish_Enum_Type; + + ------------------- + -- Expressions -- + ------------------- + + To_Op : constant array (ON_Op_Kind) of Ortho_Code.ON_Op_Kind := + ( + ON_Nil => ON_Nil, + + -- Dyadic operations. + ON_Add_Ov => ON_Add_Ov, + ON_Sub_Ov => ON_Sub_Ov, + ON_Mul_Ov => ON_Mul_Ov, + ON_Div_Ov => ON_Div_Ov, + ON_Rem_Ov => ON_Rem_Ov, + ON_Mod_Ov => ON_Mod_Ov, + + -- Binary operations. + ON_And => ON_And, + ON_Or => ON_Or, + ON_Xor => ON_Xor, + + -- Monadic operations. + ON_Not => ON_Not, + ON_Neg_Ov => ON_Neg_Ov, + ON_Abs_Ov => ON_Abs_Ov, + + -- Comparaisons + ON_Eq => ON_Eq, + ON_Neq => ON_Neq, + ON_Le => ON_Le, + ON_Lt => ON_Lt, + ON_Ge => ON_Ge, + ON_Gt => ON_Gt + ); + + function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Signed_Literal (Ortho_Code.O_Tnode (Ltype), + Value)); + end New_Signed_Literal; + + function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Unsigned_Literal (Ortho_Code.O_Tnode (Ltype), + Value)); + end New_Unsigned_Literal; + + function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Float_Literal (Ortho_Code.O_Tnode (Ltype), + Value)); + end New_Float_Literal; + + function New_Null_Access (Ltype : O_Tnode) return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Null_Access (Ortho_Code.O_Tnode (Ltype))); + end New_Null_Access; + + procedure Start_Record_Aggr (List : out O_Record_Aggr_List; + Atype : O_Tnode) is + begin + Ortho_Code.Consts.Start_Record_Aggr + (Ortho_Code.Consts.O_Record_Aggr_List (List), + Ortho_Code.O_Tnode (Atype)); + end Start_Record_Aggr; + + procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; + Value : O_Cnode) is + begin + Ortho_Code.Consts.New_Record_Aggr_El + (Ortho_Code.Consts.O_Record_Aggr_List (List), + Ortho_Code.O_Cnode (Value)); + end New_Record_Aggr_El; + + procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; + Res : out O_Cnode) is + begin + Ortho_Code.Consts.Finish_Record_Aggr + (Ortho_Code.Consts.O_Record_Aggr_List (List), + Ortho_Code.O_Cnode (Res)); + end Finish_Record_Aggr; + + procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) + is + begin + Ortho_Code.Consts.Start_Array_Aggr + (Ortho_Code.Consts.O_Array_Aggr_List (List), + Ortho_Code.O_Tnode (Atype)); + end Start_Array_Aggr; + + procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; + Value : O_Cnode) is + begin + Ortho_Code.Consts.New_Array_Aggr_El + (Ortho_Code.Consts.O_Array_Aggr_List (List), + Ortho_Code.O_Cnode (Value)); + end New_Array_Aggr_El; + + procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; + Res : out O_Cnode) is + begin + Ortho_Code.Consts.Finish_Array_Aggr + (Ortho_Code.Consts.O_Array_Aggr_List (List), + Ortho_Code.O_Cnode (Res)); + end Finish_Array_Aggr; + + function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Union_Aggr (Ortho_Code.O_Tnode (Atype), + Ortho_Code.O_Fnode (Field), + Ortho_Code.O_Cnode (Value))); + end New_Union_Aggr; + + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Sizeof (Ortho_Code.O_Tnode (Atype), + Ortho_Code.O_Tnode (Rtype))); + end New_Sizeof; + + function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Alignof (Ortho_Code.O_Tnode (Atype), + Ortho_Code.O_Tnode (Rtype))); + end New_Alignof; + + function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Offsetof (Ortho_Code.O_Tnode (Atype), + Ortho_Code.O_Fnode (Field), + Ortho_Code.O_Tnode (Rtype))); + end New_Offsetof; + + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Subprogram_Address + (Ortho_Code.O_Dnode (Subprg), Ortho_Code.O_Tnode (Atype))); + end New_Subprogram_Address; + + function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Global_Address + (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype))); + end New_Global_Address; + + function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Global_Unchecked_Address + (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype))); + end New_Global_Unchecked_Address; + + function New_Lit (Lit : O_Cnode) return O_Enode is + begin + return O_Enode (Ortho_Code.Exprs.New_Lit (Ortho_Code.O_Cnode (Lit))); + end New_Lit; + + function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) + return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Dyadic_Op (To_Op (Kind), + Ortho_Code.O_Enode (Left), + Ortho_Code.O_Enode (Right))); + end New_Dyadic_Op; + + function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) + return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Monadic_Op (To_Op (Kind), + Ortho_Code.O_Enode (Operand))); + end New_Monadic_Op; + + function New_Compare_Op + (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) + return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Compare_Op (To_Op (Kind), + Ortho_Code.O_Enode (Left), + Ortho_Code.O_Enode (Right), + Ortho_Code.O_Tnode (Ntype))); + end New_Compare_Op; + + function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) + return O_Lnode is + begin + return O_Lnode + (Ortho_Code.Exprs.New_Indexed_Element (Ortho_Code.O_Lnode (Arr), + Ortho_Code.O_Enode (Index))); + end New_Indexed_Element; + + function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) + return O_Lnode is + begin + return O_Lnode + (Ortho_Code.Exprs.New_Slice (Ortho_Code.O_Lnode (Arr), + Ortho_Code.O_Tnode (Res_Type), + Ortho_Code.O_Enode (Index))); + end New_Slice; + + function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) + return O_Lnode is + begin + return O_Lnode + (Ortho_Code.Exprs.New_Selected_Element (Ortho_Code.O_Lnode (Rec), + Ortho_Code.O_Fnode (El))); + end New_Selected_Element; + + function New_Access_Element (Acc : O_Enode) return O_Lnode is + begin + return O_Lnode + (Ortho_Code.Exprs.New_Access_Element (Ortho_Code.O_Enode (Acc))); + end New_Access_Element; + + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Convert_Ov (Ortho_Code.O_Enode (Val), + Ortho_Code.O_Tnode (Rtype))); + end New_Convert_Ov; + + function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Address (Ortho_Code.O_Lnode (Lvalue), + Ortho_Code.O_Tnode (Atype))); + end New_Address; + + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Unchecked_Address (Ortho_Code.O_Lnode (Lvalue), + Ortho_Code.O_Tnode (Atype))); + end New_Unchecked_Address; + + function New_Value (Lvalue : O_Lnode) return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Value (Ortho_Code.O_Lnode (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_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode is + begin + return O_Enode (Ortho_Code.Exprs.New_Alloca (Ortho_Code.O_Tnode (Rtype), + Ortho_Code.O_Enode (Size))); + end New_Alloca; + + --------------------- + -- Declarations. -- + --------------------- + + procedure New_Debug_Filename_Decl (Filename : String) + renames Ortho_Code.Abi.New_Debug_Filename_Decl; + + procedure New_Debug_Line_Decl (Line : Natural) + is + pragma Unreferenced (Line); + begin + null; + end New_Debug_Line_Decl; + + procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is + begin + Ortho_Code.Decls.New_Type_Decl (Ident, Ortho_Code.O_Tnode (Atype)); + end New_Type_Decl; + + To_Storage : constant array (O_Storage) of Ortho_Code.O_Storage := + (O_Storage_External => O_Storage_External, + O_Storage_Public => O_Storage_Public, + O_Storage_Private => O_Storage_Private, + O_Storage_Local => O_Storage_Local); + + procedure New_Const_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode) is + begin + Ortho_Code.Decls.New_Const_Decl + (Ortho_Code.O_Dnode (Res), Ident, To_Storage (Storage), + Ortho_Code.O_Tnode (Atype)); + end New_Const_Decl; + + procedure New_Var_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode) is + begin + Ortho_Code.Decls.New_Var_Decl + (Ortho_Code.O_Dnode (Res), Ident, To_Storage (Storage), + Ortho_Code.O_Tnode (Atype)); + end New_Var_Decl; + + function New_Obj (Obj : O_Dnode) return O_Lnode is + begin + return O_Lnode (Ortho_Code.Exprs.New_Obj (Ortho_Code.O_Dnode (Obj))); + end New_Obj; + + procedure Start_Function_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage; + Rtype : O_Tnode) is + begin + Ortho_Code.Decls.Start_Function_Decl + (Ortho_Code.Decls.O_Inter_List (Interfaces), + Ident, To_Storage (Storage), Ortho_Code.O_Tnode (Rtype)); + end Start_Function_Decl; + + procedure Start_Procedure_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage) is + begin + Ortho_Code.Decls.Start_Procedure_Decl + (Ortho_Code.Decls.O_Inter_List (Interfaces), + Ident, To_Storage (Storage)); + 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 + Ortho_Code.Decls.New_Interface_Decl + (Ortho_Code.Decls.O_Inter_List (Interfaces), + Ortho_Code.O_Dnode (Res), + Ident, + Ortho_Code.O_Tnode (Atype)); + end New_Interface_Decl; + + procedure Finish_Subprogram_Decl + (Interfaces : in out O_Inter_List; Res : out O_Dnode) is + begin + Ortho_Code.Decls.Finish_Subprogram_Decl + (Ortho_Code.Decls.O_Inter_List (Interfaces), Ortho_Code.O_Dnode (Res)); + end Finish_Subprogram_Decl; + + procedure Start_Subprogram_Body (Func : O_Dnode) is + begin + Ortho_Code.Exprs.Start_Subprogram_Body (Ortho_Code.O_Dnode (Func)); + end Start_Subprogram_Body; + + procedure Finish_Subprogram_Body + renames Ortho_Code.Exprs.Finish_Subprogram_Body; + + ------------------- + -- Statements. -- + ------------------- + + procedure New_Debug_Line_Stmt (Line : Natural) + renames Ortho_Code.Exprs.New_Debug_Line_Stmt; + + procedure New_Debug_Comment_Decl (Comment : String) + is + pragma Unreferenced (Comment); + begin + null; + end New_Debug_Comment_Decl; + + procedure Start_Declare_Stmt renames + Ortho_Code.Exprs.Start_Declare_Stmt; + procedure Finish_Declare_Stmt renames + Ortho_Code.Exprs.Finish_Declare_Stmt; + + procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) is + begin + Ortho_Code.Exprs.Start_Association + (Ortho_Code.Exprs.O_Assoc_List (Assocs), Ortho_Code.O_Dnode (Subprg)); + end Start_Association; + + procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is + begin + Ortho_Code.Exprs.New_Association + (Ortho_Code.Exprs.O_Assoc_List (Assocs), Ortho_Code.O_Enode (Val)); + end New_Association; + + function New_Function_Call (Assocs : O_Assoc_List) return O_Enode is + begin + return O_Enode (Ortho_Code.Exprs.New_Function_Call + (Ortho_Code.Exprs.O_Assoc_List (Assocs))); + end New_Function_Call; + + procedure New_Procedure_Call (Assocs : in out O_Assoc_List) is + begin + Ortho_Code.Exprs.New_Procedure_Call + (Ortho_Code.Exprs.O_Assoc_List (Assocs)); + end New_Procedure_Call; + + procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) is + begin + Ortho_Code.Exprs.New_Assign_Stmt (Ortho_Code.O_Lnode (Target), + Ortho_Code.O_Enode (Value)); + end New_Assign_Stmt; + + procedure New_Return_Stmt (Value : O_Enode) is + begin + Ortho_Code.Exprs.New_Return_Stmt (Ortho_Code.O_Enode (Value)); + end New_Return_Stmt; + + procedure New_Return_Stmt + renames Ortho_Code.Exprs.New_Return_Stmt; + + procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) is + begin + Ortho_Code.Exprs.Start_If_Stmt (Ortho_Code.Exprs.O_If_Block (Block), + Ortho_Code.O_Enode (Cond)); + end Start_If_Stmt; + + procedure New_Else_Stmt (Block : in out O_If_Block) is + begin + Ortho_Code.Exprs.New_Else_Stmt (Ortho_Code.Exprs.O_If_Block (Block)); + end New_Else_Stmt; + + procedure Finish_If_Stmt (Block : in out O_If_Block) is + begin + Ortho_Code.Exprs.Finish_If_Stmt (Ortho_Code.Exprs.O_If_Block (Block)); + end Finish_If_Stmt; + + procedure Start_Loop_Stmt (Label : out O_Snode) is + begin + Ortho_Code.Exprs.Start_Loop_Stmt (Ortho_Code.Exprs.O_Snode (Label)); + end Start_Loop_Stmt; + + procedure Finish_Loop_Stmt (Label : in out O_Snode) is + begin + Ortho_Code.Exprs.Finish_Loop_Stmt (Ortho_Code.Exprs.O_Snode (Label)); + end Finish_Loop_Stmt; + + procedure New_Exit_Stmt (L : O_Snode) is + begin + Ortho_Code.Exprs.New_Exit_Stmt (Ortho_Code.Exprs.O_Snode (L)); + end New_Exit_Stmt; + + procedure New_Next_Stmt (L : O_Snode) is + begin + Ortho_Code.Exprs.New_Next_Stmt (Ortho_Code.Exprs.O_Snode (L)); + end New_Next_Stmt; + + procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is + begin + Ortho_Code.Exprs.Start_Case_Stmt + (Ortho_Code.Exprs.O_Case_Block (Block), Ortho_Code.O_Enode (Value)); + end Start_Case_Stmt; + + procedure Start_Choice (Block : in out O_Case_Block) is + begin + Ortho_Code.Exprs.Start_Choice (Ortho_Code.Exprs.O_Case_Block (Block)); + end Start_Choice; + + procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is + begin + Ortho_Code.Exprs.New_Expr_Choice (Ortho_Code.Exprs.O_Case_Block (Block), + Ortho_Code.O_Cnode (Expr)); + end New_Expr_Choice; + + procedure New_Range_Choice (Block : in out O_Case_Block; + Low, High : O_Cnode) is + begin + Ortho_Code.Exprs.New_Range_Choice + (Ortho_Code.Exprs.O_Case_Block (Block), + Ortho_Code.O_Cnode (Low), Ortho_Code.O_Cnode (High)); + end New_Range_Choice; + + procedure New_Default_Choice (Block : in out O_Case_Block) is + begin + Ortho_Code.Exprs.New_Default_Choice + (Ortho_Code.Exprs.O_Case_Block (Block)); + end New_Default_Choice; + + procedure Finish_Choice (Block : in out O_Case_Block) is + begin + Ortho_Code.Exprs.Finish_Choice (Ortho_Code.Exprs.O_Case_Block (Block)); + end Finish_Choice; + + procedure Finish_Case_Stmt (Block : in out O_Case_Block) is + begin + Ortho_Code.Exprs.Finish_Case_Stmt + (Ortho_Code.Exprs.O_Case_Block (Block)); + end Finish_Case_Stmt; + + procedure Init is + begin + -- Create an anonymous pointer type. + if New_Access_Type (O_Tnode_Null) /= O_Tnode (O_Tnode_Ptr) then + raise Program_Error; + end if; + -- Do not finish the access, since this creates an infinite recursion + -- in gdb (at least for GDB 6.3). + --Finish_Access_Type (O_Tnode_Ptr, O_Tnode_Ptr); + Ortho_Code.Abi.Init; + end Init; + + procedure Finish is + begin + if False then + Ortho_Code.Decls.Disp_All_Decls; + --Ortho_Code.Exprs.Disp_All_Enode; + end if; + Ortho_Code.Abi.Finish; + if Debug.Flag_Debug_Stat then + Ada.Text_IO.Put_Line ("Statistics:"); + Ortho_Code.Exprs.Disp_Stats; + Ortho_Code.Decls.Disp_Stats; + Ortho_Code.Types.Disp_Stats; + Ortho_Code.Consts.Disp_Stats; + Ortho_Ident.Disp_Stats; + -- Binary_File.Disp_Stats; + end if; + end Finish; + + procedure Free_All is + begin + Ortho_Code.Types.Finish; + Ortho_Code.Exprs.Finish; + Ortho_Code.Consts.Finish; + Ortho_Code.Decls.Finish; + Ortho_Ident.Finish; + end Free_All; +end Ortho_Mcode; |