diff options
| author | gingold | 2005-09-24 05:10:24 +0000 |
|---|---|---|
| committer | gingold | 2005-09-24 05:10:24 +0000 |
| commit | 977ff5e02c6d2f9bfdabcf8b4e98b81e2d83e849 (patch) | |
| tree | 7bcf8e7aff40a8b54d4af83e90cccd73568e77bb /ortho/gcc | |
| download | ghdl-977ff5e02c6d2f9bfdabcf8b4e98b81e2d83e849.tar.gz ghdl-977ff5e02c6d2f9bfdabcf8b4e98b81e2d83e849.tar.bz2 ghdl-977ff5e02c6d2f9bfdabcf8b4e98b81e2d83e849.zip | |
First import from sources
Diffstat (limited to 'ortho/gcc')
| -rw-r--r-- | ortho/gcc/Makefile | 50 | ||||
| -rw-r--r-- | ortho/gcc/agcc-fe.adb | 776 | ||||
| -rw-r--r-- | ortho/gcc/lang.opt | 88 | ||||
| -rw-r--r-- | ortho/gcc/ortho_gcc-main.adb | 44 | ||||
| -rw-r--r-- | ortho/gcc/ortho_gcc-main.ads | 18 | ||||
| -rw-r--r-- | ortho/gcc/ortho_gcc.adb | 1362 | ||||
| -rw-r--r-- | ortho/gcc/ortho_gcc.ads | 557 | ||||
| -rw-r--r-- | ortho/gcc/ortho_gcc.private.ads | 122 | ||||
| -rw-r--r-- | ortho/gcc/ortho_gcc_front.ads | 19 | ||||
| -rw-r--r-- | ortho/gcc/ortho_ident.adb | 52 | ||||
| -rw-r--r-- | ortho/gcc/ortho_ident.ads | 30 | ||||
| -rw-r--r-- | ortho/gcc/ortho_nodes.ads | 20 |
12 files changed, 3138 insertions, 0 deletions
diff --git a/ortho/gcc/Makefile b/ortho/gcc/Makefile new file mode 100644 index 0000000..9f8b327 --- /dev/null +++ b/ortho/gcc/Makefile @@ -0,0 +1,50 @@ +# Makefile of 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. +ortho_srcdir=.. +orthobe_srcdir=$(ortho_srcdir)/gcc +agcc_srcdir=$(ortho_srcdir)/agcc +agcc_objdir=. +AGCC_GCCSRC_DIR:=$(HOME)/dist/gcc-3.4.3 +AGCC_GCCOBJ_DIR:=$(AGCC_GCCSRC_DIR)-objs +SED=sed + +all: $(ortho_exec) + +include $(agcc_srcdir)/Makefile.inc + +ORTHO_BASENAME=$(orthobe_srcdir)/ortho_gcc +ORTHO_PACKAGE=Ortho_Gcc + +include $(ortho_srcdir)/Makefile.inc + +$(ortho_exec): $(AGCC_DEPS) $(ORTHO_BASENAME).ads force + gnatmake -m -o $@ -g -aI$(agcc_srcdir) -aI$(ortho_srcdir) \ + -aI$(ortho_srcdir)/gcc $(GNAT_FLAGS) ortho_gcc-main \ + -bargs -E -largs $(AGCC_OBJS) #-static + +clean: agcc-clean + $(RM) -f *.o *.ali ortho_nodes-main + $(RM) b~*.ad? *~ + +distclean: clean agcc-clean + + +force: + +.PHONY: force all clean + diff --git a/ortho/gcc/agcc-fe.adb b/ortho/gcc/agcc-fe.adb new file mode 100644 index 0000000..75ba795 --- /dev/null +++ b/ortho/gcc/agcc-fe.adb @@ -0,0 +1,776 @@ +-- 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; diff --git a/ortho/gcc/lang.opt b/ortho/gcc/lang.opt new file mode 100644 index 0000000..b2f650a --- /dev/null +++ b/ortho/gcc/lang.opt @@ -0,0 +1,88 @@ +; Options for the VHDL front-end. +; Copyright (C) 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. + +Language +vhdl + +-std= +vhdl Joined +Select the vhdl standard + +-compile-standard +vhdl +Used during compiler build to compile the std.standard package + +-bootstrap +vhdl +Used during compiler build to compile std packages + +-work= +vhdl Joined +Set the name of the work library + +-workdir= +vhdl Joined +Set the directory of the work library + +P +vhdl Joined +-P<dir> Add <dir> to the end of the vhdl library path + +-elab +vhdl Separate +--elab <name> Used internally during elaboration of <name> + +-anaelab +vhdl Separate +--anaelab <name> Used internally during elaboration of <name> + +c +vhdl Separate +-c <filename> Analyze <filename> for --anaelab + +v +vhdl +Verbose + +-warn- +vhdl Joined +--warn-<name> Warn about <name> + +-ghdl +vhdl Joined +--ghdl-<option> Pass <option> to vhdl front-end + +-expect-failure +vhdl +Expect a compiler error (used for testsuite) + +-no-vital-checks +vhdl +Disable VITAL checks + +-vital-checks +vhdl +Enable VITAL checks + +fexplicit +vhdl +Explicit functions override implicit functions + +l +vhdl Joined Separate +-l<filename> Put list of files for link in <filename> diff --git a/ortho/gcc/ortho_gcc-main.adb b/ortho/gcc/ortho_gcc-main.adb new file mode 100644 index 0000000..5ee7a76 --- /dev/null +++ b/ortho/gcc/ortho_gcc-main.adb @@ -0,0 +1,44 @@ +-- 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 System; +with Ortho_Gcc_Front; +with Agcc.Toplev; +with Ada.Command_Line; use Ada.Command_Line; + +procedure Ortho_Gcc.Main +is + gnat_argc : Integer; + gnat_argv : System.Address; + gnat_envp : System.Address; + + pragma Import (C, gnat_argc); + pragma Import (C, gnat_argv); + pragma Import (C, gnat_envp); + + Status : Exit_Status; +begin + Ortho_Gcc_Front.Init; + + -- Note: GCC set signal handlers... + Status := Exit_Status (Agcc.Toplev.Toplev_Main (gnat_argc, gnat_argv)); + Set_Exit_Status (Status); +exception + when others => + Set_Exit_Status (2); + return; +end Ortho_Gcc.Main; diff --git a/ortho/gcc/ortho_gcc-main.ads b/ortho/gcc/ortho_gcc-main.ads new file mode 100644 index 0000000..fd79cf4 --- /dev/null +++ b/ortho/gcc/ortho_gcc-main.ads @@ -0,0 +1,18 @@ +-- 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. +procedure Ortho_Gcc.Main; diff --git a/ortho/gcc/ortho_gcc.adb b/ortho/gcc/ortho_gcc.adb new file mode 100644 index 0000000..66a3f1a --- /dev/null +++ b/ortho/gcc/ortho_gcc.adb @@ -0,0 +1,1362 @@ +-- 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; diff --git a/ortho/gcc/ortho_gcc.ads b/ortho/gcc/ortho_gcc.ads new file mode 100644 index 0000000..e7c3679 --- /dev/null +++ b/ortho/gcc/ortho_gcc.ads @@ -0,0 +1,557 @@ +-- 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 Interfaces; use Interfaces; +with Ortho_Ident; +use Ortho_Ident; +with Agcc.Trees; use Agcc.Trees; + + +-- Interface to create nodes. +package Ortho_Gcc is + --- PUBLIC DECLARATIONS + -- PUBLIC PART is defined in ortho_nodes.common.ads + type O_Cnode is private; + type O_Dnode is private; + type O_Enode is private; + type O_Fnode is private; + type O_Lnode is private; + type O_Tnode is private; + type O_Snode is private; + + -- Alloca builtin, to be set during initialization. + Alloca_Function_Ptr : Tree; + + -- Must be called during initialization, before use of any subprograms. + procedure Init; + + O_Cnode_Null : constant O_Cnode; + O_Dnode_Null : constant O_Dnode; + O_Enode_Null : constant O_Enode; + O_Fnode_Null : constant O_Fnode; + O_Lnode_Null : constant O_Lnode; + O_Snode_Null : constant O_Snode; + O_Tnode_Null : constant O_Tnode; + + + ------------------------ + -- Type definitions -- + ------------------------ + + type Bitsize_Type is range 0 .. 1024; + + -- Standard types metrics. 0 means unknown. + Metric_Char : Bitsize_Type := 0; + Metric_Short : Bitsize_Type := 0; + Metric_Int : Bitsize_Type := 0; + Metric_Long : Bitsize_Type := 0; + Metric_Long_Long : Bitsize_Type := 0; + Metric_Enum : Bitsize_Type := 0; + Metric_Float : Bitsize_Type := 0; + Metric_Double : Bitsize_Type := 0; + Metric_Long_Double : Bitsize_Type := 0; + + type O_Element_List is limited private; + + -- Build a record type. + procedure Start_Record_Type (Elements : out O_Element_List); + -- Add a field in the record; not constrained array are prohibited, since + -- its size is unlimited. + procedure New_Record_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; Etype : O_Tnode); + -- Finish the record type. + procedure Finish_Record_Type + (Elements : in out O_Element_List; Res : out O_Tnode); + + -- Build an uncomplete record type: + -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type. + -- This type can be declared or used to define access types on it. + -- Then, complete (if necessary) the record type, by calling + -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE. + procedure New_Uncomplete_Record_Type (Res : out O_Tnode); + procedure Start_Uncomplete_Record_Type (Res : O_Tnode; + Elements : out O_Element_List); + + -- Build an union type. + procedure Start_Union_Type (Elements : out O_Element_List); + procedure New_Union_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; + Etype : O_Tnode); + procedure Finish_Union_Type + (Elements : in out O_Element_List; Res : out O_Tnode); + + -- Build an access type. + -- DTYPE may be O_tnode_null in order to build an incomplete access type. + -- It is completed with finish_access_type. + function New_Access_Type (Dtype : O_Tnode) return O_Tnode; + procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode); + + -- Build an array type. + -- The array is not constrained and unidimensional. + function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) + return O_Tnode; + + -- Build a constrained array type. + function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) + return O_Tnode; + + -- Build a scalar type; size may be 8, 16, 32 or 64. + function New_Unsigned_Type (Size : Natural) return O_Tnode; + function New_Signed_Type (Size : Natural) return O_Tnode; + + -- Build a float type. + function New_Float_Type return O_Tnode; + + -- Build a boolean 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); + + -- Create an enumeration + type O_Enum_List is limited private; + + -- Elements are declared in order, the first is ordered from 0. + procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural); + procedure New_Enum_Literal (List : in out O_Enum_List; + Ident : O_Ident; Res : out O_Cnode); + procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode); + + ---------------- + -- Literals -- + ---------------- + + -- Create a literal from an integer. + function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) + return O_Cnode; + function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) + return O_Cnode; + + function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) + return O_Cnode; + + -- Create a null access literal. + function New_Null_Access (Ltype : O_Tnode) return O_Cnode; + + -- Build a record/array aggregate. + -- The aggregate is constant, and therefore can be only used to initialize + -- constant declaration. + -- ATYPE must be either a record type or an array subtype. + -- Elements must be added in the order, and must be literals or aggregates. + type O_Record_Aggr_List is limited private; + type O_Array_Aggr_List is limited private; + + procedure Start_Record_Aggr (List : out O_Record_Aggr_List; + Atype : O_Tnode); + procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; + Value : O_Cnode); + procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; + Res : out O_Cnode); + + procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode); + procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; + Value : O_Cnode); + procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; + Res : out O_Cnode); + + -- Build an union aggregate. + function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) + return O_Cnode; + + -- Returns the size in bytes of ATYPE. The result is a literal of + -- unsigned type RTYPE + -- ATYPE cannot be an unconstrained array type. + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; + + -- Returns the offset of FIELD in its record. The result is a literal + -- of unsigned type RTYPE. + function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Cnode; + + -- Get the address of a subprogram. + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Cnode; + + -- Get the address of LVALUE. + -- ATYPE must be a type access whose designated type is the type of LVALUE. + -- FIXME: what about arrays. + function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode; + + -- Same as New_Address but without any restriction. + function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode; + + ------------------- + -- Expressions -- + ------------------- + + type ON_Op_Kind is + ( + -- Not an operation; invalid. + ON_Nil, + + -- Dyadic operations. + ON_Add_Ov, -- ON_Dyadic_Op_Kind + ON_Sub_Ov, -- ON_Dyadic_Op_Kind + ON_Mul_Ov, -- ON_Dyadic_Op_Kind + ON_Div_Ov, -- ON_Dyadic_Op_Kind + ON_Rem_Ov, -- ON_Dyadic_Op_Kind + ON_Mod_Ov, -- ON_Dyadic_Op_Kind + + -- Binary operations. + ON_And, -- ON_Dyadic_Op_Kind + ON_Or, -- ON_Dyadic_Op_Kind + ON_Xor, -- ON_Dyadic_Op_Kind + ON_And_Then, -- ON_Dyadic_Op_Kind + ON_Or_Else, -- ON_Dyadic_Op_Kind + + -- Monadic operations. + ON_Not, -- ON_Monadic_Op_Kind + ON_Neg_Ov, -- ON_Monadic_Op_Kind + ON_Abs_Ov, -- ON_Monadic_Op_Kind + + -- Comparaisons + ON_Eq, -- ON_Compare_Op_Kind + ON_Neq, -- ON_Compare_Op_Kind + ON_Le, -- ON_Compare_Op_Kind + ON_Lt, -- ON_Compare_Op_Kind + ON_Ge, -- ON_Compare_Op_Kind + ON_Gt -- ON_Compare_Op_Kind + ); + + subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Or_Else; + subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov; + subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt; + + type O_Storage is (O_Storage_External, + O_Storage_Public, + O_Storage_Private, + O_Storage_Local); + -- Specifies the storage kind of a declaration. + -- O_STORAGE_EXTERNAL: + -- The declaration do not either reserve memory nor generate code, and + -- is imported either from an other file or from a later place in the + -- current file. + -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE: + -- The declaration reserves memory or generates code. + -- With O_STORAGE_PUBLIC, the declaration is exported outside of the + -- file while with O_STORAGE_PRIVATE, the declaration is local to the + -- file. + + Type_Error : exception; + Syntax_Error : exception; + + -- Create a value from a literal. + function New_Lit (Lit : O_Cnode) return O_Enode; + + -- Create a dyadic operation. + -- Left and right nodes must have the same type. + -- Binary operation is allowed only on boolean types. + -- The result is of the type of the operands. + function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) + return O_Enode; + + -- Create a monadic operation. + -- Result is of the type of operand. + function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) + return O_Enode; + + -- Create a comparaison operator. + -- NTYPE is the type of the result and must be a boolean type. + function New_Compare_Op + (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) + return O_Enode; + + + type O_Inter_List is limited private; + type O_Assoc_List is limited private; + type O_If_Block is limited private; + type O_Case_Block is limited private; + + + -- Get an element of an array. + -- INDEX must be of the type of the array index. + function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) + return O_Lnode; + + -- Get a slice of an array; this is equivalent to a conversion between + -- an array or an array subtype and an array subtype. + -- RES_TYPE must be an array_sub_type whose base type is the same as the + -- base type of ARR. + -- INDEX must be of the type of the array index. + function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) + return O_Lnode; + + -- Get an element of a record. + -- Type of REC must be a record type. + function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) + return O_Lnode; + + -- Reference an access. + -- Type of ACC must be an access type. + function New_Access_Element (Acc : O_Enode) return O_Lnode; + + -- Do a conversion. + -- Allowed conversions are: + -- FIXME: to write. + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode; + + -- Get the address of LVALUE. + -- ATYPE must be a type access whose designated type is the type of LVALUE. + -- FIXME: what about arrays. + function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode; + + -- Same as New_Address but without any restriction. + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode; + + -- Get the value of an Lvalue. + function New_Value (Lvalue : O_Lnode) return O_Enode; + function New_Obj_Value (Obj : O_Dnode) return O_Enode; + + -- Get an lvalue from a declaration. + function New_Obj (Obj : O_Dnode) return O_Lnode; + + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. + function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; + + -- Declare a type. + -- This simply gives a name to a type. + procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode); + + --------------------- + -- Declarations. -- + --------------------- + + -- Filename of the next declaration. + procedure New_Debug_Filename_Decl (Filename : String); + + -- Line number of the next declaration. + procedure New_Debug_Line_Decl (Line : Natural); + + -- Add a comment in the declarative region. + procedure New_Debug_Comment_Decl (Comment : String); + + -- Declare a constant. + -- This simply gives a name to a constant value or aggregate. + -- A constant cannot be modified and its storage cannot be local. + -- ATYPE must be constrained. + procedure New_Const_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode); + + -- Set the value of a non-external constant. + procedure Start_Const_Value (Const : in out O_Dnode); + procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode); + + -- Create a variable declaration. + -- A variable can be local only inside a function. + -- ATYPE must be constrained. + procedure New_Var_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode); + + -- Start a subprogram declaration. + -- Note: nested subprograms are allowed, ie o_storage_local subprograms can + -- be declared inside a subprograms. It is not allowed to declare + -- o_storage_external subprograms inside a subprograms. + -- Return type and interfaces cannot be a composite type. + procedure Start_Function_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage; + Rtype : O_Tnode); + -- For a subprogram without return value. + procedure Start_Procedure_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage); + + -- Add an interface declaration to INTERFACES. + procedure New_Interface_Decl + (Interfaces : in out O_Inter_List; + Res : out O_Dnode; + Ident : O_Ident; + Atype : O_Tnode); + -- Finish the function declaration, get the node and a statement list. + procedure Finish_Subprogram_Decl + (Interfaces : in out O_Inter_List; Res : out O_Dnode); + -- Start a subprogram body. + -- Note: the declaration may have an external storage, in this case it + -- becomes public. + procedure Start_Subprogram_Body (Func : O_Dnode); + -- Finish a subprogram body. + procedure Finish_Subprogram_Body; + + + ------------------- + -- Statements. -- + ------------------- + + -- Add a line number as a statement. + procedure New_Debug_Line_Stmt (Line : Natural); + + -- Add a comment as a statement. + procedure New_Debug_Comment_Stmt (Comment : String); + + -- Start a declarative region. + procedure Start_Declare_Stmt; + procedure Finish_Declare_Stmt; + + -- Create a function call or a procedure call. + procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode); + procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode); + function New_Function_Call (Assocs : O_Assoc_List) return O_Enode; + procedure New_Procedure_Call (Assocs : in out O_Assoc_List); + + -- Assign VALUE to TARGET, type must be the same or compatible. + -- FIXME: what about slice assignment? + procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode); + + -- Exit from the subprogram and return VALUE. + procedure New_Return_Stmt (Value : O_Enode); + -- Exit from the subprogram, which doesn't return value. + procedure New_Return_Stmt; + + -- Build an IF statement. + procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode); + -- COND is NULL for the final else statement. + procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode); + procedure New_Else_Stmt (Block : in out O_If_Block); + procedure Finish_If_Stmt (Block : in out O_If_Block); + + -- Create a infinite loop statement. + procedure Start_Loop_Stmt (Label : out O_Snode); + procedure Finish_Loop_Stmt (Label : in out O_Snode); + + -- Exit from a loop stmt or from a for stmt. + procedure New_Exit_Stmt (L : O_Snode); + -- Go to the start of a loop stmt or of a for stmt. + -- Loops/Fors between L and the current points are exited. + procedure New_Next_Stmt (L : O_Snode); + + -- Case statement. + -- VALUE is the selector and must be a discrete type. + procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode); + -- A choice branch is composed of expr, range or default choices. + -- A choice branch is enclosed between a Start_Choice and a Finish_Choice. + -- The statements are after the finish_choice. + procedure Start_Choice (Block : in out O_Case_Block); + procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode); + procedure New_Range_Choice (Block : in out O_Case_Block; + Low, High : O_Cnode); + procedure New_Default_Choice (Block : in out O_Case_Block); + procedure Finish_Choice (Block : in out O_Case_Block); + procedure Finish_Case_Stmt (Block : in out O_Case_Block); + +private + type O_Cnode is new Tree; + type O_Dnode is new Tree; + type O_Enode is new Tree; + type O_Fnode is new Tree; + type O_Lnode is new Tree; + type O_Tnode is new Tree; + type O_Snode is new Nesting; + + O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE); + O_Dnode_Null : constant O_Dnode := O_Dnode (NULL_TREE); + O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE); + O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE); + O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE); + O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE); + O_Snode_Null : constant O_Snode := O_Snode (Nesting_Null); + + + -- Efficiently append element EL to a chain. + -- FIRST is the first element of the chain (must NULL_TREE if the chain + -- is empty), + -- LAST is the last element of the chain (idem). + type Chain_Constr_Type is record + First : Tree; + Last : Tree; + end record; + procedure Chain_Init (Constr : out Chain_Constr_Type); + procedure Chain_Append (Constr : in out Chain_Constr_Type; El : Tree); + + -- Efficiently append element EL to a list. + type List_Constr_Type is record + First : Tree; + Last : Tree; + end record; + procedure List_Init (Constr : out List_Constr_Type); + procedure List_Append (Constr : in out List_Constr_Type; El : Tree); + + type O_Inter_List is record + Ident : O_Ident; + Storage : O_Storage; + -- Return type. + Rtype : O_Tnode; + -- List of parameter types. + Param_List : List_Constr_Type; + -- Chain of parameters declarations. + Param_Chain : Chain_Constr_Type; + end record; + + type O_Element_List is record + Res : Tree; + Chain : Chain_Constr_Type; + end record; + + type O_Case_Block is record + Expr : Tree; + First : Boolean; + Label : Tree; + end record; + + type O_If_Block is record + null; + end record; + + type O_Aggr_List is record + Atype : Tree; + Chain : Chain_Constr_Type; + end record; + + type O_Record_Aggr_List is new O_Aggr_List; + type O_Array_Aggr_List is new O_Aggr_List; + + type O_Assoc_List is record + Subprg : Tree; + List : List_Constr_Type; + end record; + + type O_Enum_List is record + -- The enumeral_type node. + Res : Tree; + -- Chain of literals. + Chain : Chain_Constr_Type; + -- Numeral value (from 0 to nbr - 1) of the next literal to be declared. + Num : Natural; + -- Size of the enumeration type. + Size : Natural; + end record; + +end Ortho_Gcc; diff --git a/ortho/gcc/ortho_gcc.private.ads b/ortho/gcc/ortho_gcc.private.ads new file mode 100644 index 0000000..c4a0135 --- /dev/null +++ b/ortho/gcc/ortho_gcc.private.ads @@ -0,0 +1,122 @@ +-- 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 Agcc.Trees; use Agcc.Trees; + +package Ortho_Nodes is + -- PUBLIC PART is defined in ortho_nodes.common.ads + type O_Cnode is private; + type O_Dnode is private; + type O_Enode is private; + type O_Fnode is private; + type O_Lnode is private; + type O_Tnode is private; + type O_Snode is private; + + -- Alloca builtin, to be set during initialization. + Alloca_Function_Ptr : Tree; + + -- Must be called during initialization, before use of any subprograms. + procedure Init; +private + type O_Cnode is new Tree; + type O_Dnode is new Tree; + type O_Enode is new Tree; + type O_Fnode is new Tree; + type O_Lnode is new Tree; + type O_Tnode is new Tree; + type O_Snode is new Nesting; + + O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE); + O_Dnode_Null : constant O_Dnode := O_Dnode (NULL_TREE); + O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE); + O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE); + O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE); + O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE); + O_Snode_Null : constant O_Snode := O_Snode (Nesting_Null); + + + -- Efficiently append element EL to a chain. + -- FIRST is the first element of the chain (must NULL_TREE if the chain + -- is empty), + -- LAST is the last element of the chain (idem). + type Chain_Constr_Type is record + First : Tree; + Last : Tree; + end record; + procedure Chain_Init (Constr : out Chain_Constr_Type); + procedure Chain_Append (Constr : in out Chain_Constr_Type; El : Tree); + + -- Efficiently append element EL to a list. + type List_Constr_Type is record + First : Tree; + Last : Tree; + end record; + procedure List_Init (Constr : out List_Constr_Type); + procedure List_Append (Constr : in out List_Constr_Type; El : Tree); + + type O_Inter_List is record + Ident : O_Ident; + Storage : O_Storage; + -- Return type. + Rtype : O_Tnode; + -- List of parameter types. + Param_List : List_Constr_Type; + -- Chain of parameters declarations. + Param_Chain : Chain_Constr_Type; + end record; + + type O_Element_List is record + Res : Tree; + Chain : Chain_Constr_Type; + end record; + + type O_Case_Block is record + Expr : Tree; + First : Boolean; + Label : Tree; + end record; + + type O_If_Block is record + null; + end record; + + type O_Aggr_List is record + Atype : Tree; + Chain : Chain_Constr_Type; + end record; + + type O_Record_Aggr_List is new O_Aggr_List; + type O_Array_Aggr_List is new O_Aggr_List; + + type O_Assoc_List is record + Subprg : Tree; + List : List_Constr_Type; + end record; + + type O_Enum_List is record + -- The enumeral_type node. + Res : Tree; + -- Chain of literals. + Chain : Chain_Constr_Type; + -- Numeral value (from 0 to nbr - 1) of the next literal to be declared. + Num : Natural; + -- Size of the enumeration type. + Size : Natural; + end record; + +end Ortho_Nodes; diff --git a/ortho/gcc/ortho_gcc_front.ads b/ortho/gcc/ortho_gcc_front.ads new file mode 100644 index 0000000..0b98f45 --- /dev/null +++ b/ortho/gcc/ortho_gcc_front.ads @@ -0,0 +1,19 @@ +-- 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 Ortho_Front; +package Ortho_Gcc_Front renames Ortho_Front; diff --git a/ortho/gcc/ortho_ident.adb b/ortho/gcc/ortho_ident.adb new file mode 100644 index 0000000..a3779f3 --- /dev/null +++ b/ortho/gcc/ortho_ident.adb @@ -0,0 +1,52 @@ +-- 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 Agcc; use Agcc; +with Agcc.Trees; +with C; use C; + +package body Ortho_Ident is + function Get_Identifier (Str : String) return O_Ident + is + Str_Nul : String := Str & Nul; + begin + return Get_Identifier (Str_Nul'Address); + end Get_Identifier; + + function Get_String (Id : O_Ident) return String + is + use Agcc.Trees; + Str : C_Str_Len; + begin + Str.Len := Get_IDENTIFIER_LENGTH (Id); + Str.Str := To_C_String (Get_IDENTIFIER_POINTER (Id)); + return Image (Str); + end Get_String; + + function Is_Equal (Id : O_Ident; Str : String) return Boolean + is + S : C_String; + begin + if Get_IDENTIFIER_LENGTH (Id) /= Str'Length then + return False; + end if; + S := To_C_String (Get_IDENTIFIER_POINTER (Id)); + return S.all (1 .. Str'Length) = Str; + end Is_Equal; + +end Ortho_Ident; + diff --git a/ortho/gcc/ortho_ident.ads b/ortho/gcc/ortho_ident.ads new file mode 100644 index 0000000..84a330e --- /dev/null +++ b/ortho/gcc/ortho_ident.ads @@ -0,0 +1,30 @@ +-- 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 Agcc.Trees; use Agcc.Trees; + +package Ortho_Ident is + subtype O_Ident is Tree; + function Get_Identifier (Str : String) return O_Ident; + function Get_String (Id : O_Ident) return String; + function Is_Equal (L, R : O_Ident) return Boolean renames + Agcc.Trees."="; + function Is_Equal (Id : O_Ident; Str : String) return Boolean; + O_Ident_Nul : constant O_Ident; +private + O_Ident_Nul : constant O_Ident := NULL_TREE; +end Ortho_Ident; diff --git a/ortho/gcc/ortho_nodes.ads b/ortho/gcc/ortho_nodes.ads new file mode 100644 index 0000000..04d9018 --- /dev/null +++ b/ortho/gcc/ortho_nodes.ads @@ -0,0 +1,20 @@ +-- 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 Ortho_Gcc; + +package Ortho_Nodes renames Ortho_Gcc; |