-- 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_Deallocation; --with Agcc.Ggc; use Agcc.Ggc; with Agcc.Tm; use Agcc.Tm; with Agcc.Machmode; use Agcc.Machmode; with Agcc.Diagnostic; with Agcc.Input; use Agcc.Input; with Agcc.Options; use Agcc.Options; with Ortho_Gcc; with Ortho_Gcc_Front; use Ortho_Gcc_Front; package body Agcc.Fe is File_Name : String_Acc; Stdin_Filename : String_Acc := new String'("*stdin*" & Nul); function Lang_Init_Options (Argc : Integer; Argv : C_String_Array) return Integer is pragma Unreferenced (Argc); pragma Unreferenced (Argv); begin return CL_vhdl; end Lang_Init_Options; function Lang_Handle_Option (Code : Opt_Code; Arg : C_String; Value : Integer) return Integer is pragma Unreferenced (Value); --type String_Acc_Array_Acc is access String_Acc_Array; procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation (Name => String_Acc, Object => String); --procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation -- (Name => String_Acc_Array_Acc, Object => String_Acc_Array); --C_Opt : C_String := Argv (0); --C_Arg : C_String; --Opt : String := C_Opt (1 .. C_String_Len (C_Opt)); Res : Natural; Opt : String_Acc; Opt_Arg : String_Acc; Len : Natural; begin if Arg /= C_String_Null then Len := C_String_Len (Arg); else Len := 0; end if; Opt_Arg := null; case Code is when OPT_U_std_U => Opt := new String'("--std=" & Arg (1 .. Len)); when OPT_U_compile_standard => Opt := new String'("--compile-standard"); when OPT_U_bootstrap => Opt := new String'("--bootstrap"); when OPT_U_work_U => Opt := new String'("--work=" & Arg (1 .. Len)); when OPT_U_workdir_U => Opt := new String'("--workdir=" & Arg (1 .. Len)); when OPT_UP => Opt := new String'("-P" & Arg (1 .. Len)); when OPT_U_elab => Opt := new String'("--elab"); Opt_Arg := new String'(Arg (1 .. Len)); when OPT_U_anaelab => Opt := new String'("--anaelab"); Opt_Arg := new String'(Arg (1 .. Len)); when OPT_l => Opt := new String'("-l"); Opt_Arg := new String'(Arg (1 .. Len)); when OPT_c => Opt := new String'("-c"); Opt_Arg := new String'(Arg (1 .. Len)); when OPT_U_ghdl => Opt := new String'(Arg (1 .. Len)); when OPT_U_warn_U => Opt := new String'("--warn-" & Arg (1 .. Len)); when OPT_U_expect_failure => Opt := new String'("--expect-failure"); when OPT_U_no_vital_checks => Opt := new String'("--no-vital-checks"); when OPT_U_vital_checks => Opt := new String'("--vital-checks"); when OPT_fexplicit => Opt := new String'("-fexplicit"); when OPT_v => Opt := new String'("-v"); when others => return 0; end case; Res := Ortho_Gcc_Front.Decode_Option (Opt, Opt_Arg); Unchecked_Deallocation (Opt); Unchecked_Deallocation (Opt_Arg); return Res; end Lang_Handle_Option; function Lang_Post_Options (Filename : C_String_Acc) return C_Bool is Filename_Len : Natural; begin if Filename.all = C_String_Null then File_Name := null; Filename.all := To_C_String (Stdin_Filename); else Filename_Len := C_String_Len (Filename.all); File_Name := new String'(Filename.all (1 .. Filename_Len)); end if; -- Run the back-end. return C_False; end Lang_Post_Options; procedure Lang_Parse_File (Debug : C_Bool) is pragma Unreferenced (Debug); begin if not Ortho_Gcc_Front.Parse (File_Name) then Agcc.Diagnostic.Set_Errorcount (1); end if; end Lang_Parse_File; function Lang_Get_Alias_Set (T : Tree) return HOST_WIDE_INT is pragma Unreferenced (T); begin return -1; end Lang_Get_Alias_Set; --function Lang_Safe_From_P (Target : Rtx; Exp : Tree) return Boolean; function Mark_Addressable (Exp : Tree) return C_Bool is N : Tree; Code : Tree_Code; begin N := Exp; loop Code := Get_TREE_CODE (N); case Code is when VAR_DECL | CONST_DECL | PARM_DECL | RESULT_DECL => Put_Var_Into_Stack (N, C_True); Set_TREE_ADDRESSABLE (N, C_True); return C_True; when COMPONENT_REF | ARRAY_REF => N := Get_TREE_OPERAND (N, 0); when FUNCTION_DECL | CONSTRUCTOR => Set_TREE_ADDRESSABLE (N, C_True); return C_True; when INDIRECT_REF => return C_True; when others => raise Program_Error; end case; end loop; end Mark_Addressable; procedure Insert_Default_Attributes (Func : Tree) is pragma Unreferenced (Func); begin null; end Insert_Default_Attributes; -- These functions and variables deal with binding contours. -- For each binding contour we allocate a binding_level structure which -- records the entities defined or declared in that contour. -- Contours include: -- -- the global one -- one for each subprogram definition -- one for each compound statement (declare block) -- -- Binding contours are used to create GCC tree BLOCK nodes. -- BE CAREFUL: this structure is also declared in agcc-bindings.c type Binding_Level; type Binding_Level_Acc is access Binding_Level; type Binding_Level is record -- A chain of ..._DECL nodes for all variables, constants, functions, -- parameters and type declarations. These ..._DECL nodes are chained -- through the TREE_CHAIN field. Note that these ..._DECL nodes are -- stored in the reverse of the order supplied to be compatible with -- the back-end. Names : Tree; -- For each level (except the global one), a chain of BLOCK nodes for -- all the levels that were entered and exited one level down from this -- one. Blocks : Tree; -- The back end may need, for its own internal processing, to create a -- BLOCK node. This field is set aside for this purpose. If this field -- is non-null when the level is popped, i.e. when poplevel is invoked, -- we will use such block instead of creating a new one from the -- 'names' field, that is the ..._DECL nodes accumulated so far. -- Typically the routine 'pushlevel' will be called before setting this -- field, so that if the front-end had inserted ..._DECL nodes in the -- current block they will not be lost. Block_Created_By_Back_End : Tree; -- The binding level containing this one (the enclosing binding level). Level_Chain : Binding_Level_Acc; end record; pragma Convention (C, Binding_Level_Acc); pragma Convention (C, Binding_Level); -- The binding level currently in effect. Current_Binding_Level : Binding_Level_Acc := null; pragma Export (C, Current_Binding_Level); -- The outermost binding level. This binding level is created when the -- compiler is started and it will exist through the entire compilation. Global_Binding_Level : Binding_Level_Acc; -- Chain of unused binding levels, since they are never deallocated. Old_Binding_Level : Binding_Level_Acc := null; pragma Export (C, Old_Binding_Level); function Alloc_Binding_Level return Binding_Level_Acc; pragma Import (C, Alloc_Binding_Level); -- Binding level structures are initialized by copying this one. Clear_Binding_Level : constant Binding_Level := (Names => NULL_TREE, Blocks => NULL_TREE, Block_Created_By_Back_End => NULL_TREE, Level_Chain => null); -- Return non-zero if we are currently in the global binding level. function Global_Bindings_P return Integer is begin if Current_Binding_Level = Global_Binding_Level then return 1; else return 0; end if; end Global_Bindings_P; -- Return the list of declarations in the current level. Note that this -- list is in reverse order (it has to be so for back-end compatibility). function Getdecls return Tree is begin return Current_Binding_Level.Names; end Getdecls; -- Nonzero if the current level needs to have a BLOCK made. -- function Kept_Level_P return Boolean is -- begin -- return Current_Binding_Level.Names /= NULL_TREE; -- end Kept_Level_P; -- Enter a new binding level. The input parameter is ignored, but has to -- be specified for back-end compatibility. procedure Pushlevel (Inside : C_Bool) is pragma Unreferenced (Inside); Newlevel : Binding_Level_Acc; begin if Old_Binding_Level /= null then Newlevel := Old_Binding_Level; Old_Binding_Level := Old_Binding_Level.Level_Chain; else Newlevel := Alloc_Binding_Level; end if; Newlevel.all := Clear_Binding_Level; -- Add this level to the front of the chain (stack) of levels that are -- active. Newlevel.Level_Chain := Current_Binding_Level; Current_Binding_Level := Newlevel; end Pushlevel; -- Exit a binding level. -- Pop the level off, and restore the state of the identifier-decl mappings -- that were in effect when this level was entered. -- -- If KEEP is nonzero, this level had explicit declarations, so -- and create a "block" (a BLOCK node) for the level -- to record its declarations and subblocks for symbol table output. -- -- If FUNCTIONBODY is nonzero, this level is the body of a function, -- so create a block as if KEEP were set and also clear out all -- label names. -- -- If REVERSE is nonzero, reverse the order of decls before putting -- them into the BLOCK. function Exported_Poplevel (Keep : C_Bool; Revers : C_Bool; Functionbody : C_Bool) return Tree is -- Points to a BLOCK tree node. This is the BLOCK node construted for -- the binding level that we are about to exit and which is returned -- by this routine. Block_Node : Tree := NULL_TREE; Decl_Chain : Tree; Subblock_Chain : Tree; Subblock_Node : Tree; Block_Created_By_Back_End : Tree; N : Tree; Tmp : Binding_Level_Acc; begin Decl_Chain := Current_Binding_Level.Names; Block_Created_By_Back_End := Current_Binding_Level.Block_Created_By_Back_End; Subblock_Chain := Current_Binding_Level.Blocks; -- Pop the current level, and save it on the chain of old binding -- levels. Tmp := Current_Binding_Level; Current_Binding_Level := Tmp.Level_Chain; Tmp.Level_Chain := Old_Binding_Level; Old_Binding_Level := Tmp; -- Reverse the list of XXXX_DECL nodes if desired. Note that -- the ..._DECL nodes chained through the `names' field of -- current_binding_level are in reverse order except for PARM_DECL node, -- which are explicitely stored in the right order. if Revers /= C_False then Decl_Chain := Nreverse (Decl_Chain); end if; if Block_Created_By_Back_End /= NULL_TREE then Block_Node := Block_Created_By_Back_End; -- Check if we are about to discard some information that was -- gathered by the front-end. Nameley check if the back-end created -- a new block without calling pushlevel first. To understand why -- things are lost just look at the next case (i.e. no block -- created by back-end. */ if (Keep /= C_False or Functionbody /= C_False) and then (Decl_Chain /= NULL_TREE or Subblock_Chain /= NULL_TREE) then raise Program_Error; end if; elsif Keep /= C_False or Functionbody /= C_False then -- If there were any declarations in the current binding level, or if -- this binding level is a function body, or if there are any nested -- blocks then create a BLOCK node to record them for the life of -- this function. if Keep /= C_False then N := Decl_Chain; else N := NULL_TREE; end if; Block_Node := Build_Block (N, NULL_TREE, Subblock_Chain, NULL_TREE, NULL_TREE); end if; -- Record the BLOCK node just built as the subblock its enclosing scope. Subblock_Node := Subblock_Chain; while Subblock_Node /= NULL_TREE loop Set_BLOCK_SUPERCONTEXT (Subblock_Node, Block_Node); Subblock_Node := Get_TREE_CHAIN (Subblock_Node); end loop; -- Clear out the meanings of the local variables of this level. Subblock_Node := Decl_Chain; while Subblock_Node /= NULL_TREE loop if Get_DECL_NAME (Subblock_Node) /= NULL_TREE then -- If the identifier was used or addressed via a local -- extern decl, don't forget that fact. if Get_DECL_EXTERNAL (Subblock_Node) /= C_False then if Get_TREE_USED (Subblock_Node) /= C_False then Set_TREE_USED (Get_DECL_NAME (Subblock_Node), C_True); end if; if Get_TREE_ADDRESSABLE (Subblock_Node) /= C_False then Set_TREE_ADDRESSABLE (Get_DECL_ASSEMBLER_NAME (Subblock_Node), C_True); end if; end if; end if; Subblock_Node := Get_TREE_CHAIN (Subblock_Node); end loop; if Functionbody /= C_False then -- This is the top level block of a function. The ..._DECL chain -- stored in BLOCK_VARS are the function's parameters (PARM_DECL -- nodes). Don't leave them in the BLOCK because they are found -- in the FUNCTION_DECL instead. Set_DECL_INITIAL (Current_Function_Decl, Block_Node); Set_BLOCK_VARS (Block_Node, NULL_TREE); elsif Block_Node /= NULL_TREE then if Block_Created_By_Back_End = NULL_TREE then Current_Binding_Level.Blocks := Chainon (Current_Binding_Level.Blocks, Block_Node); end if; elsif Subblock_Chain /= NULL_TREE then -- If we did not make a block for the level just exited, any blocks -- made for inner levels (since they cannot be recorded as subblocks -- in that level) must be carried forward so they will later become -- subblocks of something else. Current_Binding_Level.Blocks := Chainon (Current_Binding_Level.Blocks, Subblock_Chain); end if; if Block_Node /= NULL_TREE then Set_TREE_USED (Block_Node, C_True); end if; return Block_Node; end Exported_Poplevel; -- Insert BLOCK at the end of the list of subblocks of the -- current binding level. This is used when a BIND_EXPR is expanded, -- to handle the BLOCK node inside the BIND_EXPR. procedure Insert_Block (Block : Tree) is begin Set_TREE_USED (Block, C_True); Current_Binding_Level.Blocks := Chainon (Current_Binding_Level.Blocks, Block); end Insert_Block; -- Set the BLOCK node for the innermost scope (the one we are -- currently in). procedure Set_Block (Block : Tree) is begin Current_Binding_Level.Block_Created_By_Back_End := Block; end Set_Block; -- Records a ..._DECL node DECL as belonging to the current lexical scope. -- Returns the ..._DECL node. function Exported_Pushdecl (Decl : Tree) return Tree is begin -- External objects aren't nested, other objects may be. if Get_DECL_EXTERNAL (Decl) /= C_False then Set_DECL_CONTEXT (Decl, NULL_TREE); else Set_DECL_CONTEXT (Decl, Current_Function_Decl); end if; -- Put the declaration on the list. The list of declarations is in -- reverse order. The list will be reversed later if necessary. This -- needs to be this way for compatibility with the back-end. Set_TREE_CHAIN (Decl, Current_Binding_Level.Names); Current_Binding_Level.Names := Decl; -- For the declaration of a type, set its name if it is not already set. if Get_TREE_CODE (Decl) = TYPE_DECL and then Get_TYPE_NAME (Get_TREE_TYPE (Decl)) = NULL_TREE then Set_TYPE_NAME (Get_TREE_TYPE (Decl), Decl); -- DECL_NAME (decl); end if; return Decl; end Exported_Pushdecl; -- This variable keeps a table for types for each precision so that we only -- allocate each of them once. Signed and unsigned types are kept separate. type Signed_And_Unsigned_Types_Array_Type is array (Natural range 0 .. MAX_BITS_PER_WORD, C_Boolean) of Tree; Signed_And_Unsigned_Types : Signed_And_Unsigned_Types_Array_Type := (others => (others => NULL_TREE)); pragma Export (C, Signed_And_Unsigned_Types); -- Return an integer type with the number of bits of precision given by -- PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise -- it is a signed type. function Type_For_Size (Precision : Natural; Unsignedp : C_Bool) return Tree is T : Tree; begin if Precision <= MAX_BITS_PER_WORD and then Signed_And_Unsigned_Types (Precision, Unsignedp) /= NULL_TREE then return Signed_And_Unsigned_Types (Precision, Unsignedp); end if; if Unsignedp /= C_False then T := Make_Unsigned_Type (Precision); else T := Make_Signed_Type (Precision); end if; if Precision <= MAX_BITS_PER_WORD then Signed_And_Unsigned_Types (Precision, Unsignedp) := T; end if; return T; end Type_For_Size; -- Return a data type that has machine mode MODE. UNSIGNEDP selects -- an unsigned type; otherwise a signed type is returned. function Type_For_Mode (Mode : Machine_Mode; Unsignedp : C_Bool) return Tree is begin return Type_For_Size (GET_MODE_BITSIZE (Mode), Unsignedp); end Type_For_Mode; -- Return the unsigned version of a TYPE_NODE, a scalar type. function Unsigned_Type (Type_Node : Tree) return Tree is begin return Type_For_Size (Get_TYPE_PRECISION (Type_Node), C_True); end Unsigned_Type; -- Return the signed version of a TYPE_NODE, a scalar type. function Signed_Type (Type_Node : Tree) return Tree is begin return Type_For_Size (Get_TYPE_PRECISION (Type_Node), C_False); end Signed_Type; -- Return a type the same as TYPE except unsigned or signed according to -- UNSIGNEDP. function Signed_Or_Unsigned_Type (Unsignedp : C_Bool; Atype : Tree) return Tree is begin if INTEGRAL_TYPE_P (Atype) = C_False or else Get_TREE_UNSIGNED (Atype) = Unsignedp then return Atype; else return Type_For_Size (Get_TYPE_PRECISION (Atype), Unsignedp); end if; end Signed_Or_Unsigned_Type; --procedure Init_Type_For_Size; --pragma Import (C, Init_Type_For_Size); Int_Str : constant String := "int" & Nul; Char_Str : constant String := "char" & Nul; Builtin_Alloca_Str : constant String := "__builtin_alloca" & Nul; function Lang_Init return C_Bool is --File : String renames Filename (1 .. Filename_Len); Ptr_Ftype_Sizetype : Tree; Alloca_Function : Tree; begin --Error_Mark_Node := Make_Node (ERROR_MARK); --Set_TREE_TYPE (Error_Mark_Node, Error_Mark_Node); --Initialize_Sizetypes; -- The structure `tree_identifier' is the GCC tree data structure that -- holds IDENTIFIER_NODE nodes. We need to call `set_identifier_size' -- to tell GCC that we have not added any language specific fields to -- IDENTIFIER_NODE nodes. --Set_Identifier_Size (Tree_Identifier_Size); Input_Location.Line := 0; -- Make the binding_level structure for global names. Pushlevel (C_False); Global_Binding_Level := Current_Binding_Level; Build_Common_Tree_Nodes (C_False); Pushdecl (Build_Decl (TYPE_DECL, Get_Identifier (Int_Str'Address), Integer_Type_Node)); Pushdecl (Build_Decl (TYPE_DECL, Get_Identifier (Char_Str'Address), Char_Type_Node)); Set_Sizetype (Unsigned_Type_Node); Build_Common_Tree_Nodes_2 (C_False); --Init_Type_For_Size; -- Create alloc builtin. Ptr_Ftype_Sizetype := Build_Function_Type (Ptr_Type_Node, Tree_Cons (NULL_TREE, Get_TYPE_DOMAIN (Sizetype), NULL_TREE)); Alloca_Function := Builtin_Function (Builtin_Alloca_Str'Address, Ptr_Ftype_Sizetype, BUILT_IN_ALLOCA, BUILT_IN_NORMAL, System.Null_Address); Ortho_Gcc.Alloca_Function_Ptr := Build1 (ADDR_EXPR, Build_Pointer_Type (Ptr_Ftype_Sizetype), Alloca_Function); -- Ggc_Add_Tree_Root (Ortho_Gcc.Alloca_Function_Ptr'Address, 1); Ortho_Gcc.Init; -- Continue. return C_True; end Lang_Init; procedure Lang_Finish is begin null; end Lang_Finish; -- Return a definition for a builtin function named NAME and whose data -- type is TYPE. TYPE should be a function type with argument types. -- FUNCTION_CODE tells later passes how to compile calls to this function. -- See tree.h for its possible values. -- -- If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, -- the name to be called if we can't opencode the function. function Builtin_Function (Name: System.Address; Ftype : Tree; Function_Code : Built_In_Function; Class : Built_In_Class; Library_Name : System.Address) return Tree is use System; Decl : Tree; begin Decl := Build_Decl (FUNCTION_DECL, Get_Identifier (Name), Ftype); Set_DECL_EXTERNAL (Decl, C_True); Set_TREE_PUBLIC (Decl, C_True); if Library_Name /= Null_Address then Set_DECL_ASSEMBLER_NAME (Decl, Get_Identifier (Library_Name)); end if; Make_Decl_Rtl (Decl, NULL_Chars, C_True); Pushdecl (Decl); Set_DECL_BUILT_IN_CLASS (Decl, Class); Set_DECL_FUNCTION_CODE (Decl, Function_Code); return Decl; end Builtin_Function; procedure Set_Yydebug (Flag : C_Bool) is pragma Unreferenced (Flag); begin null; end Set_Yydebug; procedure Print_Lang_Decl (File : FILEs; Node : Tree; Indent : natural) is pragma Unreferenced (File); pragma Unreferenced (Node); pragma Unreferenced (Indent); begin null; end Print_Lang_Decl; procedure Print_Lang_Type (File : FILEs; Node : Tree; Indent : Natural) is pragma Unreferenced (File); pragma Unreferenced (Node); pragma Unreferenced (Indent); begin null; end Print_Lang_Type; procedure Print_Lang_Identifier (File : FILEs; Node : Tree; Indent : Natural) is pragma Unreferenced (File); pragma Unreferenced (Node); pragma Unreferenced (Indent); begin null; end Print_Lang_Identifier; procedure Lang_Print_Xnode (File : FILEs; Node : Tree; Indent : Natural) is pragma Unreferenced (File); pragma Unreferenced (Node); pragma Unreferenced (Indent); begin -- There is no X nodes. raise Program_Error; end Lang_Print_Xnode; procedure Print_Lang_Statistics is begin null; end Print_Lang_Statistics; procedure Copy_Lang_Decl (Node : Tree) is pragma Unreferenced (Node); begin null; end Copy_Lang_Decl; function Truthvalue_Conversion (Expr : Tree) return Tree is Expr_Type : Tree; type Conv_Array is array (Boolean) of Tree; Conv : Conv_Array; begin Expr_Type := Get_TREE_TYPE (Expr); if Get_TREE_CODE (Expr_Type) /= BOOLEAN_TYPE then Conv := (True => Integer_One_Node, False => Integer_Zero_Node); else Conv := (False => Get_TYPE_MIN_VALUE (Expr_Type), True => Get_TYPE_MAX_VALUE (Expr_Type)); end if; -- From java/decl.c -- It is simpler and generates better code to have only TRUTH_*_EXPR -- or comparison expressions as truth values at this level. case Get_TREE_CODE (Expr) is when EQ_EXPR | NE_EXPR | LE_EXPR | GE_EXPR | LT_EXPR | GT_EXPR | TRUTH_ANDIF_EXPR | TRUTH_ORIF_EXPR | TRUTH_AND_EXPR | TRUTH_OR_EXPR | ERROR_MARK => return Expr; when INTEGER_CST => if Integer_Zerop (Expr) = C_False then -- EXPR is not 0, so EXPR is interpreted as TRUE. return Conv (True); else return Conv (False); end if; when REAL_CST => if Real_Zerop (Expr) = C_False then return Conv (True); else return Conv (False); end if; when others => raise Program_Error; end case; end Truthvalue_Conversion; procedure Incomplete_Type_Error (Value : Tree; Atype : Tree) is pragma Unreferenced (Value); pragma Unreferenced (Atype); begin -- Can never happen. raise Program_Error; end Incomplete_Type_Error; function Maybe_Build_Cleanup (Decl : Tree) return Tree is pragma Unreferenced (Decl); begin return NULL_TREE; end Maybe_Build_Cleanup; Language_Name : constant String := "GNU vhdl" & Nul; pragma Export (C, Language_Name); end Agcc.Fe;