-- Ortho implementation for GCC. -- Copyright (C) 2002, 2003, 2004, 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_Conversion; with Agcc; use Agcc; with Agcc.Hwint; use Agcc.Hwint; with Agcc.Toplev; use Agcc.Toplev; with Agcc.Tm; use Agcc.Tm; with Agcc.Stor_Layout; use Agcc.Stor_Layout; with Agcc.Machmode; with System; with Agcc.Autils; use Agcc.Autils; with Agcc.Real; use Agcc.Real; with Agcc.Fe; use Agcc.Fe; with Agcc.Rtl; use Agcc.Rtl; with Agcc.Input; use Agcc.Input; with Agcc.Machmode; package body Ortho_Gcc is type ON_Op_To_Tree_Code_Type is array (ON_Op_Kind) of Tree_Code; ON_Op_To_Tree_Code : constant ON_Op_To_Tree_Code_Type := ( -- Dyadic operations. ON_Add_Ov => PLUS_EXPR, ON_Sub_Ov => MINUS_EXPR, ON_Mul_Ov => MULT_EXPR, ON_Div_Ov => ERROR_MARK, ON_Rem_Ov => TRUNC_MOD_EXPR, ON_Mod_Ov => FLOOR_MOD_EXPR, -- Binary operations. ON_And => TRUTH_AND_EXPR, ON_Or => TRUTH_OR_EXPR, ON_Xor => TRUTH_XOR_EXPR, ON_And_Then => TRUTH_ANDIF_EXPR, ON_Or_Else => TRUTH_ORIF_EXPR, -- Monadic operations. ON_Not => TRUTH_NOT_EXPR, ON_Neg_Ov => NEGATE_EXPR, ON_Abs_Ov => ABS_EXPR, -- Comparaisons ON_Eq => EQ_EXPR, ON_Neq => NE_EXPR, ON_Le => LE_EXPR, ON_Lt => LT_EXPR, ON_Ge => GE_EXPR, ON_Gt => GT_EXPR, ON_Nil => ERROR_MARK ); -- Constants used for FP rounding. Fp_Const_P5 : REAL_VALUE_TYPE; -- 0.5 Fp_Const_M_P5 : REAL_VALUE_TYPE; -- -0.5 Fp_Const_Zero : REAL_VALUE_TYPE; -- 0.0 procedure Init is use Agcc.Machmode; L, H : HOST_WIDE_INT; V : REAL_VALUE_TYPE; begin To_Host_Wide_Int (Integer_64'(1), L, H); REAL_VALUE_FROM_INT (V'Address, L, H, DFmode); Fp_Const_P5 := REAL_VALUE_LDEXP (V, -1); To_Host_Wide_Int (Integer_64'(-1), L, H); REAL_VALUE_FROM_INT (V'Address, L, H, DFmode); Fp_Const_M_P5 := REAL_VALUE_LDEXP (V, -1); To_Host_Wide_Int (Integer_64'(0), L, H); REAL_VALUE_FROM_INT (Fp_Const_Zero'Address, L, H, DFmode); end Init; procedure Chain_Init (Constr : out Chain_Constr_Type) is begin Constr.First := NULL_TREE; Constr.Last := NULL_TREE; end Chain_Init; procedure Chain_Append (Constr : in out Chain_Constr_Type; El : Tree) is begin if Constr.First = NULL_TREE then if Constr.Last /= NULL_TREE then raise Program_Error; end if; Constr.First := El; else Set_TREE_CHAIN (Constr.Last, El); end if; Constr.Last := El; end Chain_Append; procedure List_Init (Constr : out List_Constr_Type) is begin Constr := (First => NULL_TREE, Last => NULL_TREE); end List_Init; procedure List_Append (Constr : in out List_Constr_Type; El : Tree) is Res : Tree; begin Res := Tree_Cons (NULL_TREE, El, NULL_TREE); if Constr.First = NULL_TREE then Constr.First := Res; else Set_TREE_CHAIN (Constr.Last, Res); end if; Constr.Last := Res; end List_Append; function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) return O_Enode is Left_Type : Tree; Code : Tree_Code; begin Left_Type := Get_TREE_TYPE (Tree (Left)); if Left_Type /= Get_TREE_TYPE (Tree (Right)) then raise Type_Error; end if; case Kind is when ON_Div_Ov => if Get_TREE_CODE (Left_Type) = REAL_TYPE then Code := RDIV_EXPR; else Code := TRUNC_DIV_EXPR; end if; when others => Code := ON_Op_To_Tree_Code (Kind); end case; return O_Enode (Build (Code, Left_Type, Tree (Left), Tree (Right))); end New_Dyadic_Op; function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) return O_Enode is begin return Build1 (ON_Op_To_Tree_Code (Kind), Get_TREE_TYPE (Operand), 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 if Get_TREE_CODE (Ntype) /= BOOLEAN_TYPE then raise Type_Error; end if; if Get_TREE_TYPE (Left) /= Get_TREE_TYPE (Right) then raise Type_Error; end if; return O_Enode (Build (ON_Op_To_Tree_Code (Kind), Tree (Ntype), Tree (Left), Tree (Right))); end New_Compare_Op; -- function Unchecked_Conversion is new -- Ada.Unchecked_Conversion (Source => Unsigned_32, Target => HOST_WIDE_INT); -- function High_Part (V : Unsigned_64) return HOST_WIDE_INT -- is -- begin -- return Unchecked_Conversion (Unsigned_32 (Shift_Left (V, 32))); -- end High_Part; -- function Low_Part (V : Unsigned_64) return HOST_WIDE_INT -- is -- begin -- return Unchecked_Conversion -- (Unsigned_32 (V and (Unsigned_32'Modulus - 1))); -- end Low_Part; function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) return O_Cnode is L, H : HOST_WIDE_INT; Res : Tree; begin To_Host_Wide_Int (Value, L, H); Res := Build_Int_2 (L, H); Set_TREE_TYPE (Res, Tree (Ltype)); return O_Cnode (Res); end New_Signed_Literal; function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) return O_Cnode is Res : Tree; L, H : HOST_WIDE_INT; begin To_Host_Wide_Int (Value, L, H); Res := Build_Int_2 (L, H); Set_TREE_TYPE (Res, Tree (Ltype)); return O_Cnode (Res); end New_Unsigned_Literal; function New_Null_Access (Ltype : O_Tnode) return O_Cnode is Res : Tree; begin Res := Build_Int_2 (0, 0); Set_TREE_TYPE (Res, Tree (Ltype)); return O_Cnode (Res); end New_Null_Access; function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) return O_Cnode is Res : REAL_VALUE_TYPE; begin Res := To_Real_Value_Type (Value); return O_Cnode (Build_Real (Tree (Ltype), Res)); end New_Float_Literal; procedure Check_Constrained_Type (Atype : O_Tnode) is pragma Unreferenced (Atype); begin null; end Check_Constrained_Type; procedure Finish_Type_Def (Atype : O_Tnode) is begin Layout_Type (Atype); --Rest_Of_Type_Compilation (Tree (Atype), True); end Finish_Type_Def; procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is begin Res := Make_Node (RECORD_TYPE); end New_Uncomplete_Record_Type; procedure Start_Record_Type (Elements : out O_Element_List) is begin Elements.Res := Make_Node (RECORD_TYPE); Chain_Init (Elements.Chain); end Start_Record_Type; procedure Start_Uncomplete_Record_Type (Res : O_Tnode; Elements : out O_Element_List) is begin Elements.Res := Tree (Res); Chain_Init (Elements.Chain); end Start_Uncomplete_Record_Type; procedure New_Record_Union_Field (Elements : in out O_Element_List; El : out O_Fnode; Ident : O_Ident; Etype : O_Tnode) is Res : Tree; begin Check_Constrained_Type (Etype); Res := Build_Decl (FIELD_DECL, Ident, Tree (Etype)); Set_DECL_CONTEXT (Res, Elements.Res); Chain_Append (Elements.Chain, Res); El := O_Fnode (Res); end New_Record_Union_Field; procedure New_Record_Field (Elements : in out O_Element_List; El : out O_Fnode; Ident : O_Ident; Etype : O_Tnode) renames New_Record_Union_Field; procedure Finish_Record_Type (Elements : in out O_Element_List; Res : out O_Tnode) is begin Set_TYPE_FIELDS (Elements.Res, Elements.Chain.First); Finish_Type_Def (O_Tnode (Elements.Res)); Res := O_Tnode (Elements.Res); if Get_TYPE_NAME (Elements.Res) /= NULL_TREE then -- The type was completed. Rest_Of_Type_Compilation (Elements.Res, C_True); end if; end Finish_Record_Type; procedure Start_Union_Type (Elements : out O_Element_List) is begin Elements.Res := Make_Node (UNION_TYPE); Chain_Init (Elements.Chain); end Start_Union_Type; procedure New_Union_Field (Elements : in out O_Element_List; El : out O_Fnode; Ident : O_Ident; Etype : O_Tnode) renames New_Record_Union_Field; procedure Finish_Union_Type (Elements : in out O_Element_List; Res : out O_Tnode) is begin Set_TYPE_FIELDS (Elements.Res, Elements.Chain.First); Finish_Type_Def (O_Tnode (Elements.Res)); Res := O_Tnode (Elements.Res); end Finish_Union_Type; function New_Access_Type (Dtype : O_Tnode) return O_Tnode is Res : Tree; begin if Dtype = O_Tnode_Null then Res := Make_Node (POINTER_TYPE); Set_TREE_TYPE (Res, NULL_TREE); Set_TYPE_MODE (Res, Machmode.Ptr_Mode); Layout_Type (Res); return O_Tnode (Res); else return Build_Pointer_Type (Dtype); end if; end New_Access_Type; procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is begin if Get_TREE_CODE (Atype) /= POINTER_TYPE or else Get_TREE_TYPE (Atype) /= O_Tnode_Null then raise Syntax_Error; end if; Set_TREE_TYPE (Atype, Dtype); end Finish_Access_Type; function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) return O_Tnode is begin Check_Constrained_Type (El_Type); return Build_Array_Type (El_Type, Index_Type); end New_Array_Type; function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) return O_Tnode is Range_Type : Tree; Index_Type : Tree; Len : Tree; One : Tree; begin --if Atype.Kind /= ON_Array_Type then -- raise Type_Error; --end if; Index_Type := Get_TYPE_DOMAIN (Tree (Atype)); if +Integer_Zerop (Tree (Length)) then -- Handle null array, by creating a one-length array... Len := Size_Zero_Node; else One := Build_Int_2 (1, 0); Set_TREE_TYPE (One, Index_Type); Len := Build (MINUS_EXPR, Index_Type, Tree (Length), One); Len := Fold (Len); end if; Range_Type := Build_Range_Type (Index_Type, Size_Zero_Node, Len); return O_Tnode (Build_Array_Type (Get_TREE_TYPE (Tree (Atype)), Range_Type)); end New_Constrained_Array_Type; function New_Unsigned_Type (Size : Natural) return O_Tnode is begin return Make_Unsigned_Type (Size); end New_Unsigned_Type; function New_Signed_Type (Size : Natural) return O_Tnode is begin return Make_Signed_Type (Size); end New_Signed_Type; function New_Float_Type return O_Tnode is Res : O_Tnode; begin Res := Make_Node (REAL_TYPE); Set_TYPE_PRECISION (Res, DOUBLE_TYPE_SIZE); Layout_Type (Res); return Res; 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 pragma Unreferenced (False_Id); pragma Unreferenced (True_Id); begin -- see java/decl.c Res := O_Tnode'(Make_Node (BOOLEAN_TYPE)); Set_TYPE_PRECISION (Tree (Res), 1); Fixup_Unsigned_Type (Tree (Res)); False_E := O_Cnode (Get_TYPE_MIN_VALUE (Tree (Res))); True_E := O_Cnode (Get_TYPE_MAX_VALUE (Tree (Res))); end New_Boolean_Type; procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) is begin List.Res := Make_Node (ENUMERAL_TYPE); Chain_Init (List.Chain); List.Num := 0; List.Size := Size; end Start_Enum_Type; procedure New_Enum_Literal (List : in out O_Enum_List; Ident : O_Ident; Res : out O_Cnode) is begin Res := Build_Int_2 (HOST_WIDE_INT (List.Num), 0); Set_TREE_TYPE (Tree (Res), List.Res); Chain_Append (List.Chain, Tree_Cons (Ident, Tree (Res), NULL_TREE)); List.Num := List.Num + 1; end New_Enum_Literal; procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is begin Res := O_Tnode (List.Res); Set_TYPE_VALUES (List.Res, List.Chain.First); Set_TYPE_MIN_VALUE (List.Res, Get_TREE_VALUE (List.Chain.First)); Set_TYPE_MAX_VALUE (List.Res, Get_TREE_VALUE (List.Chain.Last)); Set_TREE_UNSIGNED (List.Res, C_True); Set_TYPE_PRECISION (List.Res, Integer (List.Size)); Finish_Type_Def (Res); end Finish_Enum_Type; procedure Start_Record_Aggr (List : out O_Record_Aggr_List; Atype : O_Tnode) is begin List.Atype := Tree (Atype); Chain_Init (List.Chain); end Start_Record_Aggr; procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; Value : O_Cnode) is begin -- FIXME: should check type of value. Chain_Append (List.Chain, Build_Tree_List (NULL_TREE, Tree (Value))); end New_Record_Aggr_El; procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; Res : out O_Cnode) is begin Res := O_Cnode (Build_Constructor (List.Atype, List.Chain.First)); end Finish_Record_Aggr; procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) is begin List.Atype := Tree (Atype); Chain_Init (List.Chain); end Start_Array_Aggr; procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; Value : O_Cnode) is begin -- FIXME: should check type of value. Chain_Append (List.Chain, Build_Tree_List (NULL_TREE, Tree (Value))); end New_Array_Aggr_El; procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; Res : out O_Cnode) is begin Res := O_Cnode (Build_Constructor (List.Atype, List.Chain.First)); end Finish_Array_Aggr; function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) return O_Cnode is El : Tree; Res : Tree; begin El := Build_Tree_List (Tree (Field), Tree (Value)); Res := Build_Constructor (Tree (Atype), El); Set_TREE_CONSTANT (Res, C_True); return O_Cnode (Res); end New_Union_Aggr; function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) return O_Lnode is Res : Tree; V : C_Bool; begin V := Mark_Addressable (Tree (Arr)); Res := Build (ARRAY_REF, Get_TREE_TYPE (Get_TREE_TYPE (Tree (Arr))), Tree (Arr), Tree (Index)); return O_Lnode (Res); end New_Indexed_Element; function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) return O_Lnode is Res : Tree; Ptr_Type : Tree; V : C_Bool; begin -- *((RES_TYPE *)(&ARR[INDEX])) -- convert ARR to a pointer, add index, and reconvert to array ? if Get_TREE_CODE (Res_Type) /= ARRAY_TYPE then raise Type_Error; end if; V := Mark_Addressable (Tree (Arr)); Ptr_Type := Build_Pointer_Type (Tree (Res_Type)); Res := Build (ARRAY_REF, Get_TREE_TYPE (Get_TREE_TYPE (Tree (Arr))), Tree (Arr), Tree (Index)); Res := Build1 (ADDR_EXPR, Ptr_Type, Res); Res := Build1 (INDIRECT_REF, Tree (Res_Type), Res); return O_Lnode (Res); end New_Slice; function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) return O_Lnode is begin if Get_TREE_CODE (Get_TREE_TYPE (Rec)) /= RECORD_TYPE then raise Type_Error; end if; return O_Lnode (Build (COMPONENT_REF, Get_TREE_TYPE (Tree (El)), Tree (Rec), Tree (El))); end New_Selected_Element; function New_Access_Element (Acc : O_Enode) return O_Lnode is Acc_Type : Tree; begin Acc_Type := Get_TREE_TYPE (Tree (Acc)); if Get_TREE_CODE (Acc_Type) /= POINTER_TYPE then raise Type_Error; end if; return O_Lnode (Build1 (INDIRECT_REF, Get_TREE_TYPE (Acc_Type), Tree (Acc))); end New_Access_Element; function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is Val_Type : Tree; Val_Code : Tree_Code; Rtype_Code : Tree_Code; Code : Tree_Code; begin Val_Type := Get_TREE_TYPE (Tree (Val)); if Val_Type = Tree (Rtype) then return Val; end if; -- FIXME: check conversions. Val_Code := Get_TREE_CODE (Val_Type); Rtype_Code := Get_TREE_CODE (Rtype); if Val_Code = POINTER_TYPE and then Rtype_Code = POINTER_TYPE then Code := NOP_EXPR; elsif Val_Code = INTEGER_TYPE and then Rtype_Code = INTEGER_TYPE then Code := CONVERT_EXPR; elsif Val_Code = REAL_TYPE and then Rtype_Code = INTEGER_TYPE then -- REAL to INTEGER -- Gcc only handles FIX_TRUNC_EXPR, but we need rounding. declare M_P5 : Tree; P5 : Tree; Zero : Tree; Saved : Tree; Comp : Tree; Adj : Tree; Res : Tree; begin M_P5 := Build_Real (Val_Type, Fp_Const_M_P5); P5 := Build_Real (Val_Type, Fp_Const_P5); Zero := Build_Real (Val_Type, Fp_Const_Zero); Saved := Build_Save_Expr (Tree (Val)); Comp := Build (GE_EXPR, Integer_Type_Node, Saved, Zero); -- FIXME: instead of res = res + (comp ? .5 : -.5) -- do: res = res (comp ? + : -) .5 Adj := Build (COND_EXPR, Val_Type, Comp, P5, M_P5); Res := Build (PLUS_EXPR, Val_Type, Saved, Adj); Res := Build1 (FIX_TRUNC_EXPR, Tree (Rtype), Res); return O_Enode (Res); end; elsif Val_Code = INTEGER_TYPE and then Rtype_Code = ENUMERAL_TYPE then Code := CONVERT_EXPR; elsif Val_Code = ENUMERAL_TYPE and then Rtype_Code = INTEGER_TYPE then Code := CONVERT_EXPR; elsif Val_Code = INTEGER_TYPE and then Rtype_Code = REAL_TYPE then Code := FLOAT_EXPR; elsif Val_Code = BOOLEAN_TYPE and then Rtype_Code = BOOLEAN_TYPE then Code := NOP_EXPR; elsif Val_Code = BOOLEAN_TYPE and then Rtype_Code = INTEGER_TYPE then Code := CONVERT_EXPR; elsif Val_Code = INTEGER_TYPE and then Rtype_Code = BOOLEAN_TYPE then -- From integer to boolean. Code := NOP_EXPR; elsif Val_Code = REAL_TYPE and then Rtype_Code = REAL_TYPE then Code := CONVERT_EXPR; else raise Program_Error; end if; return O_Enode (Build1 (Code, Tree (Rtype), Tree (Val))); end New_Convert_Ov; function Build_Addr (Operand : Tree; Atype : Tree) return Tree is use Agcc.Machmode; Result : Tree; begin case Get_TREE_CODE (Operand) is when INDIRECT_REF => -- This may be an unchecked conversion. Result := Get_TREE_OPERAND (Operand, 0); if Get_TREE_CODE (Get_TREE_TYPE (Result)) /= POINTER_TYPE then raise Program_Error; end if; return Result; when ARRAY_REF | COMPONENT_REF => -- Find the address of the prefix and add the offset. declare Op_Type : Tree; Bitsize, Bitpos : HOST_WIDE_INT; Inner, Offset : Tree; Mode : Machine_Mode; Unsignedp, Volatilep : Integer; begin Op_Type := Get_TREE_TYPE (Get_TREE_OPERAND (Operand, 0)); Inner := Get_Inner_Reference (Operand, Bitsize'Address, Bitpos'Address, Offset'Address, Mode'Address, Unsignedp'Address, Volatilep'Address); -- Compute the offset as a byte offset from INNER. */ if Offset = NULL_TREE then Offset := Size_Zero_Node; end if; Offset := Size_Binop (PLUS_EXPR, Offset, Size_Int (Bitpos / HOST_WIDE_INT (BITS_PER_UNIT))); -- Take the address of INNER, convert the offset to void *, and -- add then. It will later be converted to the desired result -- type, if any. Inner := Build_Addr (Inner, Ptr_Type_Node); Inner := Convert (Ptr_Type_Node, Inner); Offset := Convert (Ptr_Type_Node, Offset); Result := Fold (Build (PLUS_EXPR, Ptr_Type_Node, Inner, Offset)); return Result; end; when VAR_DECL => -- This is like Mark_Addressable. Put_Var_Into_Stack (Operand, C_True); Set_TREE_ADDRESSABLE (Operand, C_True); return Build1 (ADDR_EXPR, Atype, Operand); when others => raise Program_Error; end case; end Build_Addr; function New_Addr (Lvalue : Tree; Atype : O_Tnode) return Tree is Result : Tree; begin Result := Build_Addr (Lvalue, Tree (Atype)); if Get_TREE_TYPE (Result) /= Tree (Atype) then if Get_TREE_CODE (Get_TREE_TYPE (Result)) /= POINTER_TYPE then raise Program_Error; end if; Result := Build1 (NOP_EXPR, Tree (Atype), Result); end if; return Result; --return O_Enode (Build1 (ADDR_EXPR, Tree (Atype), Tree (Lvalue))); end New_Addr; function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is begin return O_Enode (New_Addr (Tree (Lvalue), Atype)); end New_Unchecked_Address; function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is begin --if Get_TREE_TYPE (Lvalue) /= Get_TREE_TYPE (Atype) then -- raise Type_Error; --end if; return O_Enode (New_Addr (Tree (Lvalue), Atype)); end New_Address; function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode is begin return O_Cnode (New_Addr (Tree (Decl), Atype)); end New_Global_Unchecked_Address; function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode is begin --if Get_TREE_TYPE (Lvalue) /= Get_TREE_TYPE (Atype) then -- raise Type_Error; --end if; return O_Cnode (New_Addr (Tree (Decl), Atype)); end New_Global_Address; function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) return O_Cnode is begin return O_Cnode (Build1 (ADDR_EXPR, Tree (Atype), Tree (Subprg))); end New_Subprogram_Address; function New_Value (Lvalue : O_Lnode) return O_Enode is begin return O_Enode (Lvalue); end New_Value; function New_Obj_Value (Obj : O_Dnode) return O_Enode is begin return O_Enode (Obj); end New_Obj_Value; function New_Obj (Obj : O_Dnode) return O_Lnode is begin return O_Lnode (Obj); end New_Obj; function New_Lit (Lit : O_Cnode) return O_Enode is begin return O_Enode (Lit); end New_Lit; function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Cnode is Off : Tree; Bit_Off : Tree; Pos : HOST_WIDE_INT; Res : Tree; begin Off := Get_DECL_FIELD_OFFSET (Tree (Field)); if Host_Integerp (Off, 1) = 0 then -- The offset must be a constant. raise Program_Error; end if; Bit_Off := Get_DECL_FIELD_BIT_OFFSET (Tree (Field)); if Host_Integerp (Bit_Off, 1) = 0 then -- The offset must be a constant. raise Program_Error; end if; Pos := Get_TREE_INT_CST_LOW (Off) + (Get_TREE_INT_CST_LOW (Bit_Off) / HOST_WIDE_INT (BITS_PER_UNIT)); Res := Build_Int_2 (Pos, 0); Set_TREE_TYPE (Res, Tree (Rtype)); return O_Cnode (Res); end New_Offsetof; function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is Size : Tree; begin Size := Get_TYPE_SIZE_UNIT (Tree (Atype)); --Size := Size_Binop (CEIL_DIV_EXPR, Size, -- Size_Int (HOST_WIDE_INT (BITS_PER_UNIT))); return O_Cnode (Fold (Build1 (NOP_EXPR, Tree (Rtype), Size))); end New_Sizeof; function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode is Var : Tree; Var_Type : Tree; Res : Tree; begin -- Create a dummy variable of the correct size. -- This way, the storage will be deallocated at the end of the scope. Var_Type := Build_Array_Type (Char_Type_Node, Build_Index_Type (Tree (Size))); Var := Build_Decl (VAR_DECL, NULL_TREE, Var_Type); Set_TREE_STATIC (Var, C_False); Set_DECL_EXTERNAL (Var, C_False); Set_TREE_PUBLIC (Var, C_False); Pushdecl (Var); Expand_Decl (Var); Res := Build1 (ADDR_EXPR, Tree (Rtype), Var); return O_Enode (Res); -- Old code that use alloca. This is not space efficient, since the -- storage will be freed only at the exit of the function. --Arg := Build1 (CONVERT_EXPR, Sizetype, Tree (Size)); --Res := Build (CALL_EXPR, Ptr_Type_Node, Alloca_Function_Ptr, -- Tree_Cons (NULL_TREE, Arg, NULL_TREE)); --return O_Enode (Build1 (NOP_EXPR, Tree (Rtype), Res)); end New_Alloca; --------------------- -- Declarations. -- --------------------- type String_Acc is access String; Current_Filename : String_Acc := null; procedure New_Debug_Filename_Decl (Filename : String) is Len : Natural; begin Len := Filename'Length; if Current_Filename = null or else Current_Filename.all'Length /= Len + 1 or else Current_Filename (1 .. Len) /= Filename then Current_Filename := new String (1 .. Len + 1); Current_Filename (1 .. Len) := Filename; Current_Filename (Len + 1) := Nul; Input_Location.File := Current_Filename (1)'Address; end if; end New_Debug_Filename_Decl; procedure New_Debug_Line_Decl (Line : Natural) is begin Input_Location.Line := Line; end New_Debug_Line_Decl; procedure New_Debug_Comment_Decl (Comment : String) is pragma Unreferenced (Comment); begin null; end New_Debug_Comment_Decl; procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is Decl : Tree; Ttype : Tree := Tree (Atype); begin -- if Atype.Decl /= null then -- raise Type_Error; -- end if; Set_TYPE_NAME (Ttype, Ident); Decl := Build_Decl (TYPE_DECL, Ident, Ttype); Set_TYPE_STUB_DECL (Ttype, Decl); Pushdecl (Decl); if Get_TYPE_SIZE (Ttype) /= NULL_TREE then -- Do not generate debug info for uncompleted types. Rest_Of_Type_Compilation (Ttype, C_True); end if; end New_Type_Decl; procedure Set_Storage (Node : Tree; Storage : O_Storage) is begin case Storage is when O_Storage_External => Set_DECL_EXTERNAL (Node, C_True); Set_TREE_PUBLIC (Node, C_True); Set_TREE_STATIC (Node, C_False); when O_Storage_Public => Set_DECL_EXTERNAL (Node, C_False); Set_TREE_PUBLIC (Node, C_True); Set_TREE_STATIC (Node, C_True); when O_Storage_Private => Set_DECL_EXTERNAL (Node, C_False); Set_TREE_PUBLIC (Node, C_False); Set_TREE_STATIC (Node, C_True); when O_Storage_Local => Set_DECL_EXTERNAL (Node, C_False); Set_TREE_PUBLIC (Node, C_False); Set_TREE_STATIC (Node, C_False); end case; end Set_Storage; procedure New_Const_Decl (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode) is Cst : Tree; begin Cst := Build_Decl (VAR_DECL, Ident, Tree (Atype)); Set_Storage (Cst, Storage); Set_TREE_READONLY (Cst, C_True); Pushdecl (Cst); case Storage is when O_Storage_Local => raise Syntax_Error; when O_Storage_External => -- We are at top level if Current_Function_Decl is null. Rest_Of_Decl_Compilation (Cst, NULL_Chars, Boolean'Pos (Current_Function_Decl = NULL_TREE), C_False); when O_Storage_Public | O_Storage_Private => null; end case; Res := O_Dnode (Cst); end New_Const_Decl; procedure Start_Const_Value (Const : in out O_Dnode) is pragma Unreferenced (Const); begin null; end Start_Const_Value; procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) is begin Set_DECL_INITIAL (Tree (Const), Tree (Val)); Set_TREE_CONSTANT (Val, C_True); Rest_Of_Decl_Compilation (Tree (Const), NULL_Chars, Boolean'Pos (Current_Function_Decl = NULL_TREE), C_False); end Finish_Const_Value; procedure New_Var_Decl (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode) is Var : Tree; begin Var := Build_Decl (VAR_DECL, Ident, Tree (Atype)); if Current_Function_Decl /= NULL_TREE then -- Local variable. Set_TREE_STATIC (Var, C_False); Set_DECL_EXTERNAL (Var, C_False); Set_TREE_PUBLIC (Var, C_False); else Set_Storage (Var, Storage); end if; Pushdecl (Var); if Current_Function_Decl /= NULL_TREE then Expand_Decl (Var); else Rest_Of_Decl_Compilation (Var, NULL_Chars, C_True, C_False); end if; Res := O_Dnode (Var); end New_Var_Decl; procedure Start_Function_Decl (Interfaces : out O_Inter_List; Ident : O_Ident; Storage : O_Storage; Rtype : O_Tnode) is begin Interfaces.Ident := Ident; Interfaces.Storage := Storage; Interfaces.Rtype := Rtype; Chain_Init (Interfaces.Param_Chain); List_Init (Interfaces.Param_List); end Start_Function_Decl; procedure Start_Procedure_Decl (Interfaces : out O_Inter_List; Ident : O_Ident; Storage : O_Storage) is begin Start_Function_Decl (Interfaces, Ident, Storage, O_Tnode (Void_Type_Node)); 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 R : Tree; begin R := Build_Decl (PARM_DECL, Ident, Tree (Atype)); --Set_DECL_CONTEXT (Res, Xxx); -- Do type conversion: convert boolean and enums to int if +PROMOTE_PROTOTYPES then case Get_TREE_CODE (Tree (Atype)) is when ENUMERAL_TYPE | BOOLEAN_TYPE => Set_DECL_ARG_TYPE (R, Integer_Type_Node); when others => Set_DECL_ARG_TYPE (R, Tree (Atype)); end case; else Set_DECL_ARG_TYPE (R, Tree (Atype)); end if; Chain_Append (Interfaces.Param_Chain, R); List_Append (Interfaces.Param_List, Tree (Atype)); Res := O_Dnode (R); end New_Interface_Decl; -- Current function nest level, or the number of parents. Function_Nest_Level : Natural := 0; procedure Finish_Subprogram_Decl (Interfaces : in out O_Inter_List; Res : out O_Dnode) is Decl : Tree; Result : Tree; Parm : Tree; Is_Global : Boolean; begin Decl := Build_Decl (FUNCTION_DECL, Interfaces.Ident, Build_Function_Type (Tree (Interfaces.Rtype), Interfaces.Param_List.First)); Is_Global := Function_Nest_Level = 0 or Interfaces.Storage = O_Storage_External; if Is_Global then Set_Storage (Decl, Interfaces.Storage); else -- A nested subprogram. Set_DECL_EXTERNAL (Decl, C_False); Set_TREE_PUBLIC (Decl, C_False); end if; -- The function exist in static storage. Set_TREE_STATIC (Decl, C_True); Set_DECL_INITIAL (Decl, Error_Mark_Node); Set_TREE_ADDRESSABLE (Decl, C_True); -- Declare the result. -- FIXME: should be moved in start_function_body. Result := Build_Decl (RESULT_DECL, NULL_TREE, Tree (Interfaces.Rtype)); Set_DECL_RESULT (Decl, Result); Set_DECL_CONTEXT (Result, Decl); Set_DECL_ARGUMENTS (Decl, Interfaces.Param_Chain.First); -- Set DECL_CONTEXT of parameters. Parm := Interfaces.Param_Chain.First; while Parm /= NULL_TREE loop Set_DECL_CONTEXT (Parm, Decl); Parm := Get_TREE_CHAIN (Parm); end loop; Pushdecl (Decl); if Is_Global then Rest_Of_Decl_Compilation (Decl, NULL_Chars, C_True, C_False); else Expand_Decl (Decl); end if; --Make_Function_Rtl (Decl); Res := O_Dnode (Decl); end Finish_Subprogram_Decl; procedure Start_Subprogram_Body (Func : O_Dnode) is begin if Function_Nest_Level /= 0 then -- For a nested subprogram: Push_Function_Context; --start_function (c-decl.c) -- announce_function -- current_function_decl = pushdecl (x) -- ?? --XXX --finish_function(1) (c-decl.c) -- poplevel --pop_function_context --add_decl_stmt end if; Function_Nest_Level := Function_Nest_Level + 1; Current_Function_Decl := Tree (Func); Announce_Function (Tree (Func)); -- Create a binding for the parameters. Pushlevel (C_False); -- FIXME: should push parameters. --Make_Function_Rtl (Current_Function_Decl); Init_Function_Start (Func, NULL_Chars, 0); Expand_Function_Start (Func, C_False); -- Create a binding for the function. -- This is necessary for compatibility. Pushlevel (C_False); Expand_Start_Bindings (0); end Start_Subprogram_Body; procedure Finish_Subprogram_Body is begin Expand_End_Bindings (Getdecls, C_True, C_False); Poplevel (C_True, C_False, C_False); Expand_Function_End (NULL_Chars, 0, C_False); Poplevel (C_True, C_False, C_True); -- The subprogram is not external anymore (extern inline is not -- supported). As a result, code will be generated. Set_DECL_EXTERNAL (Current_Function_Decl, C_False); -- FIXME: protect against ggc. See c-decl.c:c_expand_body Rest_Of_Compilation (Current_Function_Decl); Function_Nest_Level := Function_Nest_Level - 1; if Function_Nest_Level > 0 then Pop_Function_Context; else Current_Function_Decl := NULL_TREE; end if; end Finish_Subprogram_Body; ------------------- -- Statements. -- ------------------- procedure New_Debug_Line_Stmt (Line : Natural) is begin Input_Location.Line := Line; Emit_Line_Note (Input_Location); end New_Debug_Line_Stmt; procedure New_Debug_Comment_Stmt (Comment : String) is pragma Unreferenced (Comment); begin null; end New_Debug_Comment_Stmt; procedure Start_Declare_Stmt is begin Pushlevel (C_False); Expand_Start_Bindings (0); end Start_Declare_Stmt; procedure Finish_Declare_Stmt is begin Expand_End_Bindings (Getdecls, C_True, C_True); Poplevel (C_True, C_False, C_False); end Finish_Declare_Stmt; procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) is begin Assocs.Subprg := Tree (Subprg); List_Init (Assocs.List); end Start_Association; -- 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 New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is begin List_Append (Assocs.List, Tree (Val)); end New_Association; -- Return a pointer to function FUNC. function Build_Function_Ptr (Func : Tree) return Tree is begin return Build1 (ADDR_EXPR, Build_Pointer_Type (Get_TREE_TYPE (Func)), Func); end Build_Function_Ptr; function New_Function_Call (Assocs : O_Assoc_List) return O_Enode is begin return O_Enode (Build (CALL_EXPR, Get_TREE_TYPE (Get_TREE_TYPE (Assocs.Subprg)), Build_Function_Ptr (Assocs.Subprg), Assocs.List.First, NULL_TREE)); end New_Function_Call; procedure New_Procedure_Call (Assocs : in out O_Assoc_List) is Res : Tree; begin Res := Build (CALL_EXPR, Get_TREE_TYPE (Get_TREE_TYPE (Assocs.Subprg)), Build_Function_Ptr (Assocs.Subprg), Assocs.List.First, NULL_TREE); Set_TREE_SIDE_EFFECTS (Res, C_True); Expand_Expr_Stmt (Res); end New_Procedure_Call; procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) is N : Tree; begin N := Build (MODIFY_EXPR, Get_TREE_TYPE (Tree (Target)), Tree (Target), Tree (Value)); Set_TREE_SIDE_EFFECTS (N, C_True); Expand_Expr_Stmt (N); end New_Assign_Stmt; procedure New_Return_Stmt (Value : O_Enode) is Assign : Tree; begin Assign := Build (MODIFY_EXPR, Get_TREE_TYPE (Tree (Value)), Get_DECL_RESULT (Current_Function_Decl), Tree (Value)); Set_TREE_SIDE_EFFECTS (Assign, C_True); --Set_TREE_USED (Assign, True); Expand_Expr_Stmt (Assign); Expand_Return (Value); end New_Return_Stmt; procedure New_Return_Stmt is begin Expand_Null_Return; end New_Return_Stmt; procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) is pragma Unreferenced (Block); begin Expand_Start_Cond (Cond, C_False); end Start_If_Stmt; procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode) is pragma Unreferenced (Block); begin Expand_Start_Elseif (Cond); end New_Elsif_Stmt; procedure New_Else_Stmt (Block : in out O_If_Block) is pragma Unreferenced (Block); begin Expand_Start_Else; end New_Else_Stmt; procedure Finish_If_Stmt (Block : in out O_If_Block) is pragma Unreferenced (Block); begin Expand_End_Cond; end Finish_If_Stmt; procedure Start_Loop_Stmt (Label : out O_Snode) is begin Label := Expand_Start_Loop (C_True); -- This is required to avoid crash with goto fixup. Expand_Start_Bindings (0); end Start_Loop_Stmt; procedure Finish_Loop_Stmt (Label : in out O_Snode) is pragma Unreferenced (Label); begin Expand_End_Bindings (NULL_TREE, C_False, C_False); Expand_End_Loop; end Finish_Loop_Stmt; procedure New_Exit_Stmt (L : O_Snode) is begin Expand_Exit_Loop (L); end New_Exit_Stmt; procedure New_Next_Stmt (L : O_Snode) is begin Expand_Continue_Loop (L); end New_Next_Stmt; procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is begin Expand_Start_Case (C_True, Value, Get_TREE_TYPE (Value), NULL_Chars); Block := O_Case_Block'(Expr => Tree (Value), First => True, Label => NULL_TREE); end Start_Case_Stmt; procedure Start_Choice (Block : in out O_Case_Block) is begin if Block.First then Block.First := False; else -- Add a "break" statement. if Expand_Exit_Something = 0 then raise Type_Error; end if; end if; if Block.Label /= NULL_TREE then raise Syntax_Error; end if; Block.Label := Build_Decl (LABEL_DECL, NULL_TREE, NULL_TREE); --Pushdecl (Choices.Label); end Start_Choice; procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is Duplicate : Tree; begin if Pushcase (Tree (Expr), Agcc.Trees.Convert'Address, Block.Label, Duplicate'Address) /= 0 then raise Syntax_Error; end if; end New_Expr_Choice; procedure New_Range_Choice (Block : in out O_Case_Block; Low, High : O_Cnode) is Duplicate : Tree; begin if Pushcase_Range (Tree (Low), Tree (High), Agcc.Trees.Convert'Address, Tree (Block.Label), Duplicate'Address) /= 0 then raise Syntax_Error; end if; end New_Range_Choice; procedure New_Default_Choice (Block : in out O_Case_Block) is Duplicate : Tree; begin if Pushcase (NULL_TREE, System.Null_Address, Block.Label, Duplicate'Address) /= 0 then raise Syntax_Error; end if; end New_Default_Choice; procedure Finish_Choice (Block : in out O_Case_Block) is begin Block.Label := NULL_TREE; end Finish_Choice; procedure Finish_Case_Stmt (Block: in out O_Case_Block) is begin Expand_End_Case_Type (Block.Expr, NULL_TREE); end Finish_Case_Stmt; end Ortho_Gcc;