diff options
| -rw-r--r-- | ortho/Makefile.inc | 35 | ||||
| -rw-r--r-- | ortho/debug/Makefile | 7 | ||||
| -rw-r--r-- | ortho/debug/ortho_debug.adb | 11 | ||||
| -rw-r--r-- | ortho/debug/ortho_debug.private.ads | 39 | ||||
| -rw-r--r-- | ortho/gcc/Makefile | 10 | ||||
| -rw-r--r-- | ortho/gcc/ortho-lang.c | 31 | ||||
| -rw-r--r-- | ortho/gcc/ortho_gcc.adb | 27 | ||||
| -rw-r--r-- | ortho/gcc/ortho_gcc.ads | 205 | ||||
| -rw-r--r-- | ortho/gcc/ortho_gcc.private.ads | 265 | ||||
| -rw-r--r-- | ortho/llvm/Makefile | 9 | ||||
| -rw-r--r-- | ortho/llvm/ortho_llvm.adb | 3 | ||||
| -rw-r--r-- | ortho/llvm/ortho_llvm.ads | 35 | ||||
| -rw-r--r-- | ortho/llvm/ortho_llvm.private.ads | 295 | ||||
| -rw-r--r-- | ortho/mcode/Makefile | 6 | ||||
| -rw-r--r-- | ortho/mcode/binary_file-coff.adb | 2 | ||||
| -rw-r--r-- | ortho/mcode/ortho_jit.adb | 19 | ||||
| -rw-r--r-- | ortho/mcode/ortho_mcode-jit.adb | 28 | ||||
| -rw-r--r-- | ortho/mcode/ortho_mcode-jit.ads | 9 | ||||
| -rw-r--r-- | ortho/mcode/ortho_mcode.adb | 668 | ||||
| -rw-r--r-- | ortho/mcode/ortho_mcode.ads | 620 | ||||
| -rw-r--r-- | ortho/mcode/ortho_mcode.private.ads | 149 | ||||
| -rw-r--r-- | ortho/ortho_nodes.common.ads | 31 | ||||
| -rw-r--r-- | translate/Makefile | 24 |
23 files changed, 1972 insertions, 556 deletions
diff --git a/ortho/Makefile.inc b/ortho/Makefile.inc index 6836000..597aaef 100644 --- a/ortho/Makefile.inc +++ b/ortho/Makefile.inc @@ -20,22 +20,19 @@ # SED: sed the stream editor # ORTHO_BASENAME -$(ORTHO_BASENAME).ads: $(ortho_srcdir)/ortho_nodes.common.ads \ - $(ORTHO_BASENAME).private.ads - $(SED) -e '/^package/,$$d' \ - < $(ORTHO_BASENAME).private.ads \ - > tmp.prv.hdr - $(SED) -e '1,/^private/d' -e '/^end/d' \ - < $(ORTHO_BASENAME).private.ads \ - > tmp.prv.dcl - $(SED) -e '1,/^package/d' -e '/^private/,$$d' \ - < $(ORTHO_BASENAME).private.ads \ - > tmp.prv.pub - $(SED) \ - -e '/^ --- PRIVATE/r tmp.prv.dcl' \ - -e '/^--- PRIVATE CONTEXT CLAUSES/r tmp.prv.hdr' \ - -e '/^ --- PUBLIC DECLARATIONS/r tmp.prv.pub' \ - -e '/--- PRIVATE/d' \ - -e 's/ORTHO_NODES/$(ORTHO_PACKAGE)/g' < $< > $@ - $(RM) -f tmp.prv.dcl tmp.prv.hdr tmp.prv.pub - +$(ortho_srcdir)/$(BE)/$(ORTHO_BASENAME).ads: \ + $(ortho_srcdir)/ortho_nodes.common.ads \ + $(ortho_srcdir)/$(BE)/$(ORTHO_BASENAME).private.ads + $(RM) -f $@ + echo "-- DO NOT MODIFY - this file was generated from:" > $@ + echo "-- ortho_nodes.common.ads and $(ORTHO_BASENAME).private.ads" \ + >> $@ + echo "--" >> $@ + $(SED) -e '/^private/,$$d' \ + < $(ortho_srcdir)/$(BE)/$(ORTHO_BASENAME).private.ads >> $@ + echo "-- Start of common part" >> $@ + $(SED) -e '1,/^package/d' -e '/^private/,$$d' < $< >> $@ + echo "-- End of common part" >> $@ + $(SED) -n -e '/^private/,$$p' \ + < $(ortho_srcdir)/$(BE)/$(ORTHO_BASENAME).private.ads >> $@ + chmod a-w $@ diff --git a/ortho/debug/Makefile b/ortho/debug/Makefile index 7ebaf9d..0c15111 100644 --- a/ortho/debug/Makefile +++ b/ortho/debug/Makefile @@ -31,17 +31,16 @@ SED=sed all: $(ortho_exec) -$(ortho_exec): force $(orthobe_srcdir)/ortho_debug.ads +$(ortho_exec): force $(ortho_srcdir)/$(BE)/ortho_debug.ads gnatmake -o $@ $(GNATMAKE_FLAGS) ortho_debug-main -bargs -E $(LARGS) clean: $(RM) -f *.o *.ali *~ b~*.ad? ortho_nodes-main - $(RM) $(orthobe_srcdir)/ortho_debug.ads + $(RM) ortho_debug.ads force: -ORTHO_PACKAGE=Ortho_Debug -ORTHO_BASENAME=$(orthobe_srcdir)/ortho_debug +ORTHO_BASENAME=ortho_debug # Automatically build ortho_debug.ads from ortho_node.common.ads and # ortho_debug.private.ads diff --git a/ortho/debug/ortho_debug.adb b/ortho/debug/ortho_debug.adb index a1ef7b8..8285a64 100644 --- a/ortho/debug/ortho_debug.adb +++ b/ortho/debug/ortho_debug.adb @@ -39,8 +39,6 @@ package body Ortho_Debug is ON_And => OE_And, ON_Or => OE_Or, ON_Xor => OE_Xor, - ON_And_Then => OE_And_Then, - ON_Or_Else => OE_Or_Else, -- Monadic operations. ON_Not => OE_Not, @@ -439,7 +437,7 @@ package body Ortho_Debug is S_Type => Atype); end New_Alignof; - function New_Offsetof (Rec_Type : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) + function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) return O_Cnode is subtype O_Cnode_Offsetof_Type is O_Cnode_Type (OC_Offsetof_Lit); @@ -449,7 +447,7 @@ package body Ortho_Debug is then raise Type_Error; end if; - if Field.Parent /= Rec_Type then + if Field.Parent /= Atype then raise Type_Error; end if; return new O_Cnode_Offsetof_Type'(Kind => OC_Offsetof_Lit, @@ -1269,9 +1267,6 @@ package body Ortho_Debug is Add_Decl (Res); end New_Const_Decl; - -- Const is not modified - pragma Warnings (Off, "*is not modified"); - procedure Start_Const_Value (Const : in out O_Dnode) is subtype O_Dnode_Const_Value is O_Dnode_Type (ON_Const_Value); @@ -1321,8 +1316,6 @@ package body Ortho_Debug is Const.Const_Value.Value := Val; end Finish_Const_Value; - pragma Warnings (On, "*is not modified"); - procedure New_Var_Decl (Res : out O_Dnode; Ident : O_Ident; diff --git a/ortho/debug/ortho_debug.private.ads b/ortho/debug/ortho_debug.private.ads index 09d9b4c..98424ef 100644 --- a/ortho/debug/ortho_debug.private.ads +++ b/ortho/debug/ortho_debug.private.ads @@ -1,5 +1,5 @@ -- Ortho debug back-end declarations. --- Copyright (C) 2005 Tristan Gingold +-- Copyright (C) 2005-2014 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 @@ -16,27 +16,26 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. +with Interfaces; use Interfaces; +with Ortho_Ident; +use Ortho_Ident; + +-- Interface to create nodes. package Ortho_Debug is - type O_Enode is private; - type O_Cnode is private; - type O_Lnode is private; + procedure Init; + procedure Finish; + +private -- A node for a type. - type O_Tnode_Type (<>) is private; + type O_Tnode_Type (<>); type O_Tnode is access O_Tnode_Type; + -- A node for a statement. - type O_Snode_Type (<>) is private; + type O_Snode_Type (<>); type O_Snode is access O_Snode_Type; - -- A node for a function. - type O_Dnode_Type (<>) is private; - type O_Dnode is access O_Dnode_Type; - -- A node for a record element. - type O_Fnode_Type is private; - type O_Fnode is access O_Fnode_Type; - procedure Init; - procedure Finish; Top : O_Snode; -private + type Str_Acc is access String; type Decl_Scope_Type; @@ -48,7 +47,12 @@ private ON_Function_Decl, ON_Function_Body, ON_Const_Value, ON_Debug_Line_Decl, ON_Debug_Comment_Decl, ON_Debug_Filename_Decl); + + type O_Dnode_Type (<>); + type O_Dnode is access O_Dnode_Type; + O_Dnode_Null : constant O_Dnode := null; + type O_Dnode_Type (Kind : On_Decl_Kind) is record Next : O_Dnode; Name : O_Ident; @@ -88,7 +92,12 @@ private end case; end record; + -- A node for a record element. + type O_Fnode_Type; + type O_Fnode is access O_Fnode_Type; + O_Fnode_Null : constant O_Fnode := null; + type O_Fnode_Type is record -- Record type. Parent : O_Tnode; diff --git a/ortho/gcc/Makefile b/ortho/gcc/Makefile index 01a33d0..36ff842 100644 --- a/ortho/gcc/Makefile +++ b/ortho/gcc/Makefile @@ -3,6 +3,7 @@ orthobe_srcdir=$(ortho_srcdir)/gcc agcc_objdir=. agcc_srcdir=$(ortho_srcdir)/gcc SED=sed +BE=gcc GNATMAKE=gnatmake CC=gcc CXX=g++ @@ -28,10 +29,9 @@ ZLIB=-lz all: $(ortho_exec) +ORTHO_BASENAME=ortho_gcc include $(orthobe_srcdir)/Makefile.inc - -ORTHO_BASENAME=$(orthobe_srcdir)/ortho_gcc -ORTHO_PACKAGE=Ortho_Gcc +include $(ortho_srcdir)/Makefile.inc LIBBACKTRACE = $(AGCC_GCCOBJ_DIR)/libbacktrace/.libs/libbacktrace.a LIBDECNUMBER = $(AGCC_GCCOBJ_DIR)/libdecnumber/libdecnumber.a @@ -47,10 +47,10 @@ LIBS = $(AGCC_GCCOBJ_DIR)/gcc/libcommon.a \ $(CPPLIB) $(LIBINTL) $(LIBICONV) $(LIBBACKTRACE) \ $(LIBIBERTY) $(LIBDECNUMBER) $(HOST_LIBS) -$(ortho_exec): $(AGCC_DEPS) $(ORTHO_BASENAME).ads force +$(ortho_exec): $(AGCC_DEPS) $(orthobe_srcdir)/ortho_gcc.ads force $(GNATMAKE) -m -o $@ -g -aI$(ortho_srcdir) \ -aI$(ortho_srcdir)/gcc $(GNAT_FLAGS) ortho_gcc-main \ - -bargs -E -largs --GCC=$(LINKER) $(AGCC_OBJS) \ + -bargs -E -largs --LINK=$(LINKER) $(AGCC_OBJS) \ $(BACKEND) $(LIBS) $(BACKENDLIBS) clean: agcc-clean diff --git a/ortho/gcc/ortho-lang.c b/ortho/gcc/ortho-lang.c index fe02dbc..6b4b8a5 100644 --- a/ortho/gcc/ortho-lang.c +++ b/ortho/gcc/ortho-lang.c @@ -268,7 +268,6 @@ append_stmt (tree stmt) static GTY(()) tree top; static GTY(()) tree stack_alloc_function_ptr; -extern "C" void ortho_fe_init (void); static bool global_bindings_p (void) @@ -367,8 +366,6 @@ ortho_init (void) REAL_VALUE_FROM_INT (fp_const_zero, 0, 0, DFmode); } - ortho_fe_init (); - build_common_builtin_nodes (); // FIXME: this MAY remove the need for creating the builtins above... // Evaluate tree.c / build_common_builtin_nodes (); for each in turn. @@ -849,8 +846,6 @@ enum ON_op_kind { ON_And, ON_Or, ON_Xor, - ON_And_Then, - ON_Or_Else, /* Monadic operations. */ ON_Not, @@ -882,8 +877,6 @@ static enum tree_code ON_op_to_TREE_CODE[ON_LAST] = { BIT_AND_EXPR, BIT_IOR_EXPR, BIT_XOR_EXPR, - TRUTH_ANDIF_EXPR, - TRUTH_ORIF_EXPR, BIT_NOT_EXPR, NEGATE_EXPR, @@ -902,6 +895,9 @@ new_dyadic_op (enum ON_op_kind kind, tree left, tree right) { tree left_type; enum tree_code code; + + /* Truncate to avoid representations issue. */ + kind = (enum ON_op_kind)((unsigned)kind & 0xff); left_type = TREE_TYPE (left); gcc_assert (left_type == TREE_TYPE (right)); @@ -924,6 +920,9 @@ new_dyadic_op (enum ON_op_kind kind, tree left, tree right) tree new_monadic_op (enum ON_op_kind kind, tree operand) { + /* Truncate to avoid representations issue. */ + kind = (enum ON_op_kind)((unsigned)kind & 0xff); + return build1 (ON_op_to_TREE_CODE[kind], TREE_TYPE (operand), operand); } @@ -932,6 +931,10 @@ new_compare_op (enum ON_op_kind kind, tree left, tree right, tree ntype) { gcc_assert (TREE_CODE (ntype) == BOOLEAN_TYPE); gcc_assert (TREE_TYPE (left) == TREE_TYPE (right)); + + /* Truncate to avoid representations issue. */ + kind = (enum ON_op_kind)((unsigned)kind & 0xff); + return build2 (ON_op_to_TREE_CODE[kind], ntype, left, right); } @@ -2025,20 +2028,6 @@ start_if_stmt (struct o_if_block *block, tree cond) } void -new_elsif_stmt (struct o_if_block *block, tree cond) -{ - tree stmts; - tree stmt; - - pop_stmts (); - stmts = alloc_stmt_list (); - stmt = build3 (COND_EXPR, void_type_node, cond, stmts, NULL_TREE); - COND_EXPR_ELSE (block->stmt) = stmt; - block->stmt = stmt; - push_stmts (stmts); -} - -void new_else_stmt (struct o_if_block *block) { tree stmts; diff --git a/ortho/gcc/ortho_gcc.adb b/ortho/gcc/ortho_gcc.adb index c5234fc..ae7b4f5 100644 --- a/ortho/gcc/ortho_gcc.adb +++ b/ortho/gcc/ortho_gcc.adb @@ -1,3 +1,20 @@ +-- GCC back-end for ortho. +-- Copyright (C) 2002-1014 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 Ortho_Gcc_Front; use Ortho_Gcc_Front; @@ -8,9 +25,9 @@ package body Ortho_Gcc is return O_Enode (Lit); end New_Lit; - function New_Obj (Decl : O_Dnode) return O_Lnode is + function New_Obj (Obj : O_Dnode) return O_Lnode is begin - return O_Lnode (Decl); + return O_Lnode (Obj); end New_Obj; function New_Obj_Value (Obj : O_Dnode) return O_Enode is @@ -18,12 +35,6 @@ package body Ortho_Gcc is return O_Enode (Obj); end New_Obj_Value; - procedure Init - is - begin - null; - end Init; - procedure New_Debug_Filename_Decl (Filename : String) is begin null; diff --git a/ortho/gcc/ortho_gcc.ads b/ortho/gcc/ortho_gcc.ads index d01caee..f0a4724 100644 --- a/ortho/gcc/ortho_gcc.ads +++ b/ortho/gcc/ortho_gcc.ads @@ -1,3 +1,23 @@ +-- DO NOT MODIFY - this file was generated from: +-- ortho_nodes.common.ads and ortho_gcc.private.ads +-- +-- GCC back-end for ortho. +-- Copyright (C) 2002-1014 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 Interfaces; use Interfaces; with Ortho_Ident; @@ -5,26 +25,25 @@ use Ortho_Ident; -- Interface to create nodes. package Ortho_Gcc is - --- PUBLIC DECLARATIONS - -- PUBLIC PART is defined in ortho_nodes.common.ads - type O_Cnode is private; + +-- Start of common part + type O_Enode is private; + type O_Cnode is private; type O_Lnode is private; type O_Tnode is private; - type O_Fnode is private; - type O_Dnode is private; type O_Snode is private; - - -- Must be called during initialization, before use of any subprograms. - procedure Init; + type O_Dnode is private; + type O_Fnode is private; O_Cnode_Null : constant O_Cnode; + O_Dnode_Null : constant O_Dnode; O_Enode_Null : constant O_Enode; - O_Lnode_Null : constant O_Lnode; - O_Tnode_Null : constant O_Tnode; O_Fnode_Null : constant O_Fnode; + O_Lnode_Null : constant O_Lnode; O_Snode_Null : constant O_Snode; - O_Dnode_Null : constant O_Dnode; + O_Tnode_Null : constant O_Tnode; + ------------------------ -- Type definitions -- @@ -101,6 +120,75 @@ package Ortho_Gcc is 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 alignment in bytes for ATYPE. The result is a literal of + -- unsgined type RTYPE. + function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; + + -- Returns the offset of FIELD in its record ATYPE. The result is a + -- literal of unsigned type or access type RTYPE. + function New_Offsetof (Atype : O_Tnode; 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 -- ------------------- @@ -122,8 +210,6 @@ package Ortho_Gcc is 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 @@ -139,9 +225,7 @@ package Ortho_Gcc is ON_Gt -- ON_Compare_Op_Kind ); - pragma Convention (C, ON_Op_Kind); - - subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Or_Else; + subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor; 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; @@ -149,7 +233,6 @@ package Ortho_Gcc is O_Storage_Public, O_Storage_Private, O_Storage_Local); - pragma Convention (C, O_Storage); -- Specifies the storage kind of a declaration. -- O_STORAGE_EXTERNAL: -- The declaration do not either reserve memory nor generate code, and @@ -164,8 +247,8 @@ package Ortho_Gcc is Type_Error : exception; Syntax_Error : exception; + -- Create a value from a literal. function New_Lit (Lit : O_Cnode) return O_Enode; - pragma Inline (New_Lit); -- Create a dyadic operation. -- Left and right nodes must have the same type. @@ -185,63 +268,13 @@ package Ortho_Gcc is (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) return O_Enode; - -- 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; type O_Inter_List is limited private; - type O_Record_Aggr_List is limited private; - type O_Array_Aggr_List is limited private; type O_Assoc_List is limited private; - type O_Loop_Block is limited private; type O_If_Block is limited private; type O_Case_Block is limited private; - -- 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. - 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 alignment in bytes for ATYPE. The result is a literal of - -- unsgined type RTYPE. - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the offset of FIELD in its record REC_TYPE. The result is a - -- literal of unsigned type or access type RTYPE. - function New_Offsetof (Rec_Type : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode; - -- 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) @@ -273,24 +306,17 @@ package Ortho_Gcc is -- 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; - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; -- Same as New_Address but without any restriction. function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode; - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : 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 value of an Lvalue. function New_Value (Lvalue : O_Lnode) return O_Enode; - -- Get the value of an object. function New_Obj_Value (Obj : O_Dnode) return O_Enode; - pragma Inline (New_Obj_Value); + + -- 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; @@ -303,7 +329,7 @@ package Ortho_Gcc is -- Declarations. -- --------------------- - -- Filename. + -- Filename of the next declaration. procedure New_Debug_Filename_Decl (Filename : String); -- Line number of the next declaration. @@ -335,9 +361,6 @@ package Ortho_Gcc is Storage : O_Storage; Atype : O_Tnode); - function New_Obj (Decl : O_Dnode) return O_Lnode; - pragma Inline (New_Obj); - -- 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 @@ -402,14 +425,12 @@ package Ortho_Gcc is -- 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 (Block : in 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); @@ -420,6 +441,9 @@ package Ortho_Gcc is -- 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; @@ -428,7 +452,11 @@ package Ortho_Gcc is procedure Finish_Choice (Block : in out O_Case_Block); procedure Finish_Case_Stmt (Block : in out O_Case_Block); +-- End of common part private + pragma Convention (C, O_Storage); + -- pragma Convention (C, ON_Op_Kind); + subtype Tree is System.Address; NULL_TREE : constant Tree := System.Null_Address; @@ -446,8 +474,6 @@ private end record; pragma Convention (C, O_Snode); - pragma Export (C, Init, "ortho_fe_init"); - O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE); O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE); O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE); @@ -456,6 +482,10 @@ private O_Snode_Null : constant O_Snode := (NULL_TREE, NULL_TREE); O_Dnode_Null : constant O_Dnode := O_Dnode (NULL_TREE); + pragma Inline (New_Lit); + pragma Inline (New_Obj); + pragma Inline (New_Obj_Value); + -- Efficiently append element EL to a chain. -- FIRST is the first element of the chain (must NULL_TREE if the chain -- is empty), @@ -641,7 +671,6 @@ private pragma Import (C, New_Assign_Stmt); pragma Import (C, Start_If_Stmt); - pragma Import (C, New_Elsif_Stmt); pragma Import (C, New_Else_Stmt); pragma Import (C, Finish_If_Stmt); diff --git a/ortho/gcc/ortho_gcc.private.ads b/ortho/gcc/ortho_gcc.private.ads new file mode 100644 index 0000000..c113f2f --- /dev/null +++ b/ortho/gcc/ortho_gcc.private.ads @@ -0,0 +1,265 @@ +-- GCC back-end for ortho. +-- Copyright (C) 2002-1014 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 Interfaces; use Interfaces; +with Ortho_Ident; +use Ortho_Ident; + +-- Interface to create nodes. +package Ortho_Gcc is + +private + pragma Convention (C, O_Storage); + -- pragma Convention (C, ON_Op_Kind); + + subtype Tree is System.Address; + NULL_TREE : constant Tree := System.Null_Address; + + subtype Vec_Ptr is System.Address; + + type O_Cnode is new Tree; + type O_Enode is new Tree; + type O_Lnode is new Tree; + type O_Tnode is new Tree; + type O_Fnode is new Tree; + type O_Dnode is new Tree; + type O_Snode is record + Beg_Label : Tree; + End_Label : Tree; + end record; + pragma Convention (C, O_Snode); + + O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE); + O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE); + O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE); + O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE); + O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE); + O_Snode_Null : constant O_Snode := (NULL_TREE, NULL_TREE); + O_Dnode_Null : constant O_Dnode := O_Dnode (NULL_TREE); + + pragma Inline (New_Lit); + pragma Inline (New_Obj); + pragma Inline (New_Obj_Value); + + -- 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; + pragma Convention (C, Chain_Constr_Type); + procedure Chain_Init (Constr : out Chain_Constr_Type); + pragma Import (C, Chain_Init); + procedure Chain_Append (Constr : in out Chain_Constr_Type; El : Tree); + pragma Import (C, Chain_Append); + + -- Efficiently append element EL to a list. + type List_Constr_Type is record + First : Tree; + Last : Tree; + end record; + pragma Convention (C, List_Constr_Type); + procedure List_Init (Constr : out List_Constr_Type); + pragma Import (C, List_Init); + procedure List_Append (Constr : in out List_Constr_Type; El : Tree); + pragma Import (C, List_Append, "ortho_list_append"); + + type O_Loop_Block is record + Beg_Label : Tree; + End_Label : Tree; + end record; + pragma Convention (C, O_Loop_Block); + + 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; + pragma Convention (C, O_Inter_List); + + type O_Element_List is record + Res : Tree; + Chain : Chain_Constr_Type; + end record; + pragma Convention (C, O_Element_List); + + type O_Case_Block is record + End_Label : Tree; + Add_Break : Integer; + end record; + pragma Convention (C, O_Case_Block); + + type O_If_Block is record + Stmt : Tree; + end record; + pragma Convention (C, O_If_Block); + + type O_Aggr_List is record + Atype : Tree; + Chain : Chain_Constr_Type; + end record; + + type O_Record_Aggr_List is record + Atype : Tree; + Afield : Tree; + Vec : Vec_Ptr; + end record; + pragma Convention (C, O_Record_Aggr_List); + + type O_Array_Aggr_List is record + Atype : Tree; + Vec : Vec_Ptr; + end record; + pragma Convention (C, O_Array_Aggr_List); + + type O_Assoc_List is record + Subprg : Tree; + List : List_Constr_Type; + end record; + pragma Convention (C, O_Assoc_List); + + 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; + pragma Convention (C, O_Enum_List); + + pragma Import (C, New_Dyadic_Op); + pragma Import (C, New_Monadic_Op); + pragma Import (C, New_Compare_Op); + + pragma Import (C, New_Convert_Ov); + pragma Import (C, New_Alloca); + + pragma Import (C, New_Signed_Literal); + pragma Import (C, New_Unsigned_Literal); + pragma Import (C, New_Float_Literal); + pragma Import (C, New_Null_Access); + + pragma Import (C, Start_Record_Type); + pragma Import (C, New_Record_Field); + pragma Import (C, Finish_Record_Type); + pragma Import (C, New_Uncomplete_Record_Type); + pragma Import (C, Start_Uncomplete_Record_Type); + + pragma Import (C, Start_Union_Type); + pragma Import (C, New_Union_Field); + pragma Import (C, Finish_Union_Type); + + pragma Import (C, New_Unsigned_Type); + pragma Import (C, New_Signed_Type); + pragma Import (C, New_Float_Type); + + pragma Import (C, New_Access_Type); + pragma Import (C, Finish_Access_Type); + + pragma Import (C, New_Array_Type); + pragma Import (C, New_Constrained_Array_Type); + + pragma Import (C, New_Boolean_Type); + pragma Import (C, Start_Enum_Type); + pragma Import (C, New_Enum_Literal); + pragma Import (C, Finish_Enum_Type); + + pragma Import (C, Start_Record_Aggr); + pragma Import (C, New_Record_Aggr_El); + pragma Import (C, Finish_Record_Aggr); + pragma Import (C, Start_Array_Aggr); + pragma Import (C, New_Array_Aggr_El); + pragma Import (C, Finish_Array_Aggr); + pragma Import (C, New_Union_Aggr); + + pragma Import (C, New_Indexed_Element); + pragma Import (C, New_Slice); + pragma Import (C, New_Selected_Element); + pragma Import (C, New_Access_Element); + + pragma Import (C, New_Sizeof); + pragma Import (C, New_Alignof); + pragma Import (C, New_Offsetof); + + pragma Import (C, New_Address); + pragma Import (C, New_Global_Address); + pragma Import (C, New_Unchecked_Address); + pragma Import (C, New_Global_Unchecked_Address); + pragma Import (C, New_Subprogram_Address); + + pragma Import (C, New_Value); + + pragma Import (C, New_Type_Decl); + pragma Import (C, New_Debug_Line_Decl); + pragma Import (C, New_Const_Decl); + pragma Import (C, New_Var_Decl); + + pragma Import (C, Start_Const_Value); + pragma Import (C, Finish_Const_Value); + + pragma Import (C, Start_Function_Decl); + pragma Import (C, Start_Procedure_Decl); + pragma Import (C, New_Interface_Decl); + pragma Import (C, Finish_Subprogram_Decl); + + pragma Import (C, Start_Subprogram_Body); + pragma Import (C, Finish_Subprogram_Body); + + pragma Import (C, New_Debug_Line_Stmt); + pragma Import (C, Start_Declare_Stmt); + pragma Import (C, Finish_Declare_Stmt); + pragma Import (C, Start_Association); + pragma Import (C, New_Association); + pragma Import (C, New_Function_Call); + pragma Import (C, New_Procedure_Call); + + pragma Import (C, New_Assign_Stmt); + + pragma Import (C, Start_If_Stmt); + pragma Import (C, New_Else_Stmt); + pragma Import (C, Finish_If_Stmt); + + pragma Import (C, New_Return_Stmt); + pragma Import_Procedure (New_Return_Stmt, + "new_func_return_stmt", (O_Enode)); + pragma Import_Procedure (New_Return_Stmt, + "new_proc_return_stmt", null); + + pragma Import (C, Start_Loop_Stmt); + pragma Import (C, Finish_Loop_Stmt); + pragma Import (C, New_Exit_Stmt); + pragma Import (C, New_Next_Stmt); + + pragma Import (C, Start_Case_Stmt); + pragma Import (C, Start_Choice); + pragma Import (C, New_Expr_Choice); + pragma Import (C, New_Range_Choice); + pragma Import (C, New_Default_Choice); + pragma Import (C, Finish_Choice); + pragma Import (C, Finish_Case_Stmt); +end Ortho_Gcc; diff --git a/ortho/llvm/Makefile b/ortho/llvm/Makefile index b5c2798..2a4d7bd 100644 --- a/ortho/llvm/Makefile +++ b/ortho/llvm/Makefile @@ -2,17 +2,16 @@ ortho_srcdir=.. GNAT_FLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwael CC=clang LLVM_CONFIG=llvm-config +SED=sed +BE=llvm all: $(ortho_exec) -$(ortho_exec): force llvm-cbindings.o +$(ortho_exec): $(ortho_srcdir)/llvm/ortho_llvm.ads force llvm-cbindings.o gnatmake -m -o $@ -g -aI$(ortho_srcdir)/llvm -aI$(ortho_srcdir) \ $(GNAT_FLAGS) ortho_code_main -bargs -E \ -largs llvm-cbindings.o `$(LLVM_CONFIG) --ldflags --libs --system-libs` -lc++ #-static -llvm-bindings.o: $(ortho_srcdir)/llvm/llvm-bindings.cpp - $(CXX) -c -m64 -I`$(LLVM_CONFIG) --includedir --cxxflags` -g -o $@ $< - llvm-cbindings.o: $(ortho_srcdir)/llvm/llvm-cbindings.cpp $(CC) -c -I`$(LLVM_CONFIG) --includedir --cflags` -g -o $@ $< @@ -27,3 +26,5 @@ force: .PHONY: force all clean +ORTHO_BASENAME=ortho_llvm +include $(ortho_srcdir)/Makefile.inc diff --git a/ortho/llvm/ortho_llvm.adb b/ortho/llvm/ortho_llvm.adb index b18eae3..be9364f 100644 --- a/ortho/llvm/ortho_llvm.adb +++ b/ortho/llvm/ortho_llvm.adb @@ -1177,9 +1177,6 @@ package body Ortho_LLVM is when others => null; end case; - - when others => - null; end case; when ON_Float_Type => diff --git a/ortho/llvm/ortho_llvm.ads b/ortho/llvm/ortho_llvm.ads index 070bec6..30245b8 100644 --- a/ortho/llvm/ortho_llvm.ads +++ b/ortho/llvm/ortho_llvm.ads @@ -1,3 +1,6 @@ +-- DO NOT MODIFY - this file was generated from: +-- ortho_nodes.common.ads and ortho_llvm.private.ads +-- -- LLVM back-end for ortho. -- Copyright (C) 2014 Tristan Gingold -- @@ -24,27 +27,26 @@ with LLVM.Core; -- Interface to create nodes. package Ortho_LLVM is - --- PUBLIC DECLARATIONS + procedure Finish_Debug; + +-- Start of common part + type O_Enode is private; - O_Enode_Null : constant O_Enode; type O_Cnode is private; - O_Cnode_Null : constant O_Cnode; type O_Lnode is private; - O_Lnode_Null : constant O_Lnode; - -- A node for a type. type O_Tnode is private; - O_Tnode_Null : constant O_Tnode; - -- A node for a statement. type O_Snode is private; - O_Snode_Null : constant O_Snode; - -- A node for a function. type O_Dnode is private; - O_Dnode_Null : constant O_Dnode; - -- A node for a record element. type O_Fnode is private; + + 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; - procedure Finish_Debug; ------------------------ -- Type definitions -- @@ -171,8 +173,8 @@ package Ortho_LLVM is -- unsgined type RTYPE. function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - -- Returns the offset of FIELD in record ATYPE. The result is a literal - -- of unsigned type RTYPE. + -- Returns the offset of FIELD in its record ATYPE. The result is a + -- literal of unsigned type or access type RTYPE. function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) return O_Cnode; @@ -211,8 +213,6 @@ package Ortho_LLVM is 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 @@ -228,7 +228,7 @@ package Ortho_LLVM is ON_Gt -- ON_Compare_Op_Kind ); - subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Or_Else; + subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor; 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; @@ -455,6 +455,7 @@ package Ortho_LLVM is procedure Finish_Choice (Block : in out O_Case_Block); procedure Finish_Case_Stmt (Block : in out O_Case_Block); +-- End of common part private use LLVM.Core; diff --git a/ortho/llvm/ortho_llvm.private.ads b/ortho/llvm/ortho_llvm.private.ads new file mode 100644 index 0000000..976de00 --- /dev/null +++ b/ortho/llvm/ortho_llvm.private.ads @@ -0,0 +1,295 @@ +-- LLVM back-end for ortho. +-- Copyright (C) 2014 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 Interfaces.C; use Interfaces.C; +with Ortho_Ident; +use Ortho_Ident; +with LLVM.Core; + +-- Interface to create nodes. +package Ortho_LLVM is + procedure Finish_Debug; + +private + use LLVM.Core; + + type O_Tnode_Type (<>); + type O_Tnode is access O_Tnode_Type; + O_Tnode_Null : constant O_Tnode := null; + + type ON_Type_Kind is + (ON_No_Type, + ON_Unsigned_Type, ON_Signed_Type, ON_Enum_Type, ON_Boolean_Type, + ON_Float_Type, + ON_Array_Type, ON_Array_Sub_Type, + ON_Incomplete_Record_Type, + ON_Record_Type, ON_Union_Type, + ON_Incomplete_Access_Type, ON_Access_Type); + + subtype ON_Scalar_Types is ON_Type_Kind range + ON_Unsigned_Type .. ON_Float_Type; + + subtype ON_Integer_Types is ON_Type_Kind range + ON_Unsigned_Type .. ON_Boolean_Type; + + type O_Tnode_Type (Kind : ON_Type_Kind := ON_No_Type) is record + LLVM : TypeRef; + Dbg : ValueRef; + case Kind is + when ON_No_Type => + null; + when ON_Union_Type => + Un_Size : unsigned; + Un_Main_Field : TypeRef; + when ON_Access_Type + | ON_Incomplete_Access_Type => + Acc_Type : O_Tnode; + when ON_Scalar_Types => + Scal_Size : Natural; + when ON_Array_Type + | ON_Array_Sub_Type => + -- Type of the element + Arr_El_Type : O_Tnode; + when ON_Record_Type + | ON_Incomplete_Record_Type => + null; + end case; + end record; + + type O_Inter; + type O_Inter_Acc is access O_Inter; + type O_Inter is record + Itype : O_Tnode; + Ival : ValueRef; + Ident : O_Ident; + Next : O_Inter_Acc; + end record; + + type On_Decl_Kind is + (ON_Type_Decl, ON_Completed_Type_Decl, + ON_Const_Decl, + ON_Var_Decl, ON_Local_Decl, ON_Interface_Decl, + ON_Subprg_Decl, + ON_No_Decl); + + type O_Dnode (Kind : On_Decl_Kind := ON_No_Decl) is record + Dtype : O_Tnode; + LLVM : ValueRef; + case Kind is + when ON_Var_Decl + | ON_Const_Decl + | ON_Local_Decl => + null; + when ON_Subprg_Decl => + Subprg_Id : O_Ident; + Nbr_Args : unsigned; + Subprg_Inters : O_Inter_Acc; + when ON_Interface_Decl => + Inter : O_Inter_Acc; + when others => + null; + end case; + end record; + + O_Dnode_Null : constant O_Dnode := (Kind => ON_No_Decl, + Dtype => O_Tnode_Null, + LLVM => Null_ValueRef); + + type OF_Kind is (OF_None, OF_Record, OF_Union); + type O_Fnode (Kind : OF_Kind := OF_None) is record + Ftype : O_Tnode; + case Kind is + when OF_None => + null; + when OF_Record => + Index : Natural; + when OF_Union => + Utype : TypeRef; + end case; + end record; + + O_Fnode_Null : constant O_Fnode := (Kind => OF_None, + Ftype => O_Tnode_Null); + + type O_Anode_Type; + type O_Anode is access O_Anode_Type; + type O_Anode_Type is record + Next : O_Anode; + Formal : O_Dnode; + Actual : O_Enode; + end record; + + type O_Cnode is record + LLVM : ValueRef; + Ctype : O_Tnode; + end record; + O_Cnode_Null : constant O_Cnode := (LLVM => Null_ValueRef, + Ctype => O_Tnode_Null); + + type O_Enode is record + LLVM : ValueRef; + Etype : O_Tnode; + end record; + O_Enode_Null : constant O_Enode := (LLVM => Null_ValueRef, + Etype => O_Tnode_Null); + + + type O_Lnode is record + -- If True, the LLVM component is the value (used for arguments). + -- If False, the LLVM component is the address of the value (used + -- for everything else). + Direct : Boolean; + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + + type O_Snode is record + -- First BB in the loop body. + Bb_Entry : BasicBlockRef; + + -- BB after the loop. + Bb_Exit : BasicBlockRef; + end record; + + O_Snode_Null : constant O_Snode := (Null_BasicBlockRef, + Null_BasicBlockRef); + + type O_Inter_List is record + Ident : O_Ident; + Storage : O_Storage; + Res_Type : O_Tnode; + Nbr_Inter : Natural; + First_Inter, Last_Inter : O_Inter_Acc; + end record; + + type O_Element; + type O_Element_Acc is access O_Element; + type O_Element is record + -- Identifier for the element + Ident : O_Ident; + + -- Type of the element + Etype : O_Tnode; + + -- Next element (in the linked list) + Next : O_Element_Acc; + end record; + + -- Record and union builder. + type O_Element_List is record + Nbr_Elements : Natural; + + -- For record: the access to the incomplete (but named) type. + Rec_Type : O_Tnode; + + -- For unions: biggest for size and alignment + Size : unsigned; + Align : Unsigned_32; + Align_Type : TypeRef; + + First_Elem, Last_Elem : O_Element_Acc; + end record; + + type ValueRefArray_Acc is access ValueRefArray; + + type O_Record_Aggr_List is record + -- Current number of elements in Vals. + Len : unsigned; + + -- Value of elements. + Vals : ValueRefArray_Acc; + + -- Type of the aggregate. + Atype : O_Tnode; + end record; + + type O_Array_Aggr_List is record + -- Current number of elements in Vals. + Len : unsigned; + + -- Value of elements. + Vals : ValueRefArray_Acc; + El_Type : TypeRef; + + -- Type of the aggregate. + Atype : O_Tnode; + end record; + + type O_Assoc_List is record + Subprg : O_Dnode; + Idx : unsigned; + Vals : ValueRefArray_Acc; + end record; + + type O_Enum_List is record + LLVM : TypeRef; + Num : Natural; + Etype : O_Tnode; + end record; + + type O_Choice_Type is record + Low, High : ValueRef; + Bb : BasicBlockRef; + end record; + + type O_Choice_Array is array (Natural range <>) of O_Choice_Type; + type O_Choice_Array_Acc is access O_Choice_Array; + + type O_Case_Block is record + -- BB before the case. + BB_Prev : BasicBlockRef; + + -- Select expression + Value : ValueRef; + Vtype : O_Tnode; + + -- BB after the case statement. + BB_Next : BasicBlockRef; + + -- BB for others + BB_Others : BasicBlockRef; + + -- BB for the current choice + BB_Choice : BasicBlockRef; + + -- List of choices. + Nbr_Choices : Natural; + Choices : O_Choice_Array_Acc; + end record; + + type O_If_Block is record + -- The next basic block. + -- After the 'If', this is the BB for the else part. If there is no + -- else part, this is the BB for statements after the if. + -- After the 'else', this is the BB for statements after the if. + Bb : BasicBlockRef; + end record; + + function Get_LLVM_Type (Atype : O_Tnode) return TypeRef; + + -- Builder for statements. + Builder : BuilderRef; + + -- Builder for declarations (local variables). + Decl_Builder : BuilderRef; + + Llvm_Dbg_Declare : ValueRef; +end Ortho_LLVM; diff --git a/ortho/mcode/Makefile b/ortho/mcode/Makefile index 3b5a596..2970d60 100644 --- a/ortho/mcode/Makefile +++ b/ortho/mcode/Makefile @@ -1,10 +1,12 @@ ortho_srcdir=.. GNAT_FLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwlcru CC=gcc +BE=mcode +SED=sed all: $(ortho_exec) -$(ortho_exec): memsegs_c.o force +$(ortho_exec): $(ortho_srcdir)/mcode/ortho_mcode.ads memsegs_c.o force gnatmake -m -o $@ -g -aI$(ortho_srcdir)/mcode -aI$(ortho_srcdir) \ $(GNAT_FLAGS) ortho_code_main -bargs -E -largs memsegs_c.o #-static @@ -31,3 +33,5 @@ force: .PHONY: force all clean +ORTHO_BASENAME=ortho_mcode +include $(ortho_srcdir)/Makefile.inc diff --git a/ortho/mcode/binary_file-coff.adb b/ortho/mcode/binary_file-coff.adb index a49c024..cf3cba3 100644 --- a/ortho/mcode/binary_file-coff.adb +++ b/ortho/mcode/binary_file-coff.adb @@ -393,7 +393,7 @@ package body Binary_File.Coff is for I in Symbols.First .. Symbols.Last loop declare - Str : String := Get_Symbol_Name (I); + Str : constant String := Get_Symbol_Name (I); begin Write_String (Str & NUL); end; diff --git a/ortho/mcode/ortho_jit.adb b/ortho/mcode/ortho_jit.adb index 92109f1..c924542 100644 --- a/ortho/mcode/ortho_jit.adb +++ b/ortho/mcode/ortho_jit.adb @@ -17,14 +17,13 @@ -- 02111-1307, USA. with GNAT.OS_Lib; use GNAT.OS_Lib; -with Ada.Unchecked_Conversion; with Ada.Text_IO; with Binary_File; use Binary_File; with Binary_File.Memory; with Ortho_Mcode; use Ortho_Mcode; +with Ortho_Mcode.Jit; with Ortho_Code.Flags; use Ortho_Code.Flags; -with Ortho_Code.Binary; with Ortho_Code.Debug; with Ortho_Code.Abi; with Binary_File.Elf; @@ -41,22 +40,11 @@ package body Ortho_Jit is -- Set address of non-defined global variables or functions. procedure Set_Address (Decl : O_Dnode; Addr : Address) - is - use Ortho_Code.Binary; - begin - Binary_File.Memory.Set_Symbol_Address (Get_Decl_Symbol (Decl), Addr); - end Set_Address; + renames Ortho_Mcode.Jit.Set_Address; -- Get address of a global. function Get_Address (Decl : O_Dnode) return Address - is - use Ortho_Code.Binary; - - function Conv is new Ada.Unchecked_Conversion - (Source => Pc_Type, Target => Address); - begin - return Conv (Get_Symbol_Vaddr (Get_Decl_Symbol (Decl))); - end Get_Address; + renames Ortho_Mcode.Jit.Get_Address; -- Do link. procedure Link (Status : out Boolean) is @@ -130,4 +118,3 @@ package body Ortho_Jit is end Disp_Help; end Ortho_Jit; - diff --git a/ortho/mcode/ortho_mcode-jit.adb b/ortho/mcode/ortho_mcode-jit.adb new file mode 100644 index 0000000..7e845cc --- /dev/null +++ b/ortho/mcode/ortho_mcode-jit.adb @@ -0,0 +1,28 @@ +with Ada.Unchecked_Conversion; + +with Ortho_Code.Binary; +with Binary_File; use Binary_File; +with Binary_File.Memory; + +package body Ortho_Mcode.Jit is + -- Set address of non-defined global variables or functions. + procedure Set_Address (Decl : O_Dnode; Addr : Address) + is + use Ortho_Code.Binary; + begin + Binary_File.Memory.Set_Symbol_Address + (Get_Decl_Symbol (Ortho_Code.O_Dnode (Decl)), Addr); + end Set_Address; + + -- Get address of a global. + function Get_Address (Decl : O_Dnode) return Address + is + use Ortho_Code.Binary; + + function Conv is new Ada.Unchecked_Conversion + (Source => Pc_Type, Target => Address); + begin + return Conv (Get_Symbol_Vaddr + (Get_Decl_Symbol (Ortho_Code.O_Dnode (Decl)))); + end Get_Address; +end Ortho_Mcode.Jit; diff --git a/ortho/mcode/ortho_mcode-jit.ads b/ortho/mcode/ortho_mcode-jit.ads new file mode 100644 index 0000000..c689a1e --- /dev/null +++ b/ortho/mcode/ortho_mcode-jit.ads @@ -0,0 +1,9 @@ +with System; use System; + +package Ortho_Mcode.Jit is + -- Set address of non-defined global variables or functions. + procedure Set_Address (Decl : O_Dnode; Addr : Address); + + -- Get address of a global. + function Get_Address (Decl : O_Dnode) return Address; +end Ortho_Mcode.Jit; diff --git a/ortho/mcode/ortho_mcode.adb b/ortho/mcode/ortho_mcode.adb index 722e884..55e890b 100644 --- a/ortho/mcode/ortho_mcode.adb +++ b/ortho/mcode/ortho_mcode.adb @@ -18,23 +18,10 @@ with Ada.Text_IO; with Ortho_Code.Debug; with Ortho_Ident; +with Ortho_Code.Abi; -- with Binary_File; package body Ortho_Mcode is - procedure New_Debug_Line_Decl (Line : Natural) - is - pragma Unreferenced (Line); - begin - null; - 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_Debug_Comment_Stmt (Comment : String) is pragma Unreferenced (Comment); @@ -49,34 +36,671 @@ package body Ortho_Mcode is null; end Start_Const_Value; + procedure Start_Record_Type (Elements : out O_Element_List) is + begin + Ortho_Code.Types.Start_Record_Type + (Ortho_Code.Types.O_Element_List (Elements)); + end Start_Record_Type; + + procedure New_Record_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; Etype : O_Tnode) is + begin + Ortho_Code.Types.New_Record_Field + (Ortho_Code.Types.O_Element_List (Elements), + Ortho_Code.O_Fnode (El), Ident, Ortho_Code.O_Tnode (Etype)); + end New_Record_Field; + + procedure Finish_Record_Type + (Elements : in out O_Element_List; Res : out O_Tnode) is + begin + Ortho_Code.Types.Finish_Record_Type + (Ortho_Code.Types.O_Element_List (Elements), + Ortho_Code.O_Tnode (Res)); + end Finish_Record_Type; + + procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is + begin + Ortho_Code.Types.New_Uncomplete_Record_Type (Ortho_Code.O_Tnode (Res)); + end New_Uncomplete_Record_Type; + + procedure Start_Uncomplete_Record_Type (Res : O_Tnode; + Elements : out O_Element_List) is + begin + Ortho_Code.Types.Start_Uncomplete_Record_Type + (Ortho_Code.O_Tnode (Res), + Ortho_Code.Types.O_Element_List (Elements)); + end Start_Uncomplete_Record_Type; + + procedure Start_Union_Type (Elements : out O_Element_List) is + begin + Ortho_Code.Types.Start_Union_Type + (Ortho_Code.Types.O_Element_List (Elements)); + end Start_Union_Type; + + procedure New_Union_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; + Etype : O_Tnode) is + begin + Ortho_Code.Types.New_Union_Field + (Ortho_Code.Types.O_Element_List (Elements), + Ortho_Code.O_Fnode (El), + Ident, + Ortho_Code.O_Tnode (Etype)); + end New_Union_Field; + + procedure Finish_Union_Type + (Elements : in out O_Element_List; Res : out O_Tnode) is + begin + Ortho_Code.Types.Finish_Union_Type + (Ortho_Code.Types.O_Element_List (Elements), + Ortho_Code.O_Tnode (Res)); + end Finish_Union_Type; + + function New_Access_Type (Dtype : O_Tnode) return O_Tnode is + begin + return O_Tnode + (Ortho_Code.Types.New_Access_Type (Ortho_Code.O_Tnode (Dtype))); + end New_Access_Type; + + procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is + begin + Ortho_Code.Types.Finish_Access_Type (Ortho_Code.O_Tnode (Atype), + Ortho_Code.O_Tnode (Dtype)); + end Finish_Access_Type; + procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) is pragma Warnings (Off, Const); begin - New_Const_Value (Const, Val); + New_Const_Value (Ortho_Code.O_Dnode (Const), Ortho_Code.O_Cnode (Val)); end Finish_Const_Value; - function New_Obj_Value (Obj : O_Dnode) return O_Enode is + function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) + return O_Tnode is begin - return New_Value (New_Obj (Obj)); - end New_Obj_Value; + return O_Tnode + (Ortho_Code.Types.New_Array_Type (Ortho_Code.O_Tnode (El_Type), + Ortho_Code.O_Tnode (Index_Type))); + end New_Array_Type; function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) return O_Tnode is - L_Type : O_Tnode; + Len : constant Ortho_Code.O_Cnode := Ortho_Code.O_Cnode (Length); + L_Type : Ortho_Code.O_Tnode; begin - L_Type := Get_Const_Type (Length); + L_Type := Get_Const_Type (Len); if Get_Type_Kind (L_Type) /= OT_Unsigned then raise Syntax_Error; end if; - return New_Constrained_Array_Type (Atype, Get_Const_U32 (Length)); + return O_Tnode (New_Constrained_Array_Type + (Ortho_Code.O_Tnode (Atype), Get_Const_U32 (Len))); end New_Constrained_Array_Type; + function New_Unsigned_Type (Size : Natural) return O_Tnode is + begin + return O_Tnode (Ortho_Code.Types.New_Unsigned_Type (Size)); + end New_Unsigned_Type; + + function New_Signed_Type (Size : Natural) return O_Tnode is + begin + return O_Tnode (Ortho_Code.Types.New_Signed_Type (Size)); + end New_Signed_Type; + + function New_Float_Type return O_Tnode is + begin + return O_Tnode (Ortho_Code.Types.New_Float_Type); + end New_Float_Type; + + procedure New_Boolean_Type (Res : out O_Tnode; + False_Id : O_Ident; + False_E : out O_Cnode; + True_Id : O_Ident; + True_E : out O_Cnode) is + begin + Ortho_Code.Types.New_Boolean_Type (Ortho_Code.O_Tnode (Res), + False_Id, + Ortho_Code.O_Cnode (False_E), + True_Id, + Ortho_Code.O_Cnode (True_E)); + end New_Boolean_Type; + + procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) is + begin + Ortho_Code.Types.Start_Enum_Type (Ortho_Code.Types.O_Enum_List (List), + Size); + end Start_Enum_Type; + + procedure New_Enum_Literal (List : in out O_Enum_List; + Ident : O_Ident; Res : out O_Cnode) is + begin + Ortho_Code.Types.New_Enum_Literal (Ortho_Code.Types.O_Enum_List (List), + Ident, Ortho_Code.O_Cnode (Res)); + end New_Enum_Literal; + + procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is + begin + Ortho_Code.Types.Finish_Enum_Type (Ortho_Code.Types.O_Enum_List (List), + Ortho_Code.O_Tnode (Res)); + end Finish_Enum_Type; + + ------------------- + -- Expressions -- + ------------------- + + To_Op : constant array (ON_Op_Kind) of Ortho_Code.ON_Op_Kind := + ( + ON_Nil => ON_Nil, + + -- Dyadic operations. + ON_Add_Ov => ON_Add_Ov, + ON_Sub_Ov => ON_Sub_Ov, + ON_Mul_Ov => ON_Mul_Ov, + ON_Div_Ov => ON_Div_Ov, + ON_Rem_Ov => ON_Rem_Ov, + ON_Mod_Ov => ON_Mod_Ov, + + -- Binary operations. + ON_And => ON_And, + ON_Or => ON_Or, + ON_Xor => ON_Xor, + + -- Monadic operations. + ON_Not => ON_Not, + ON_Neg_Ov => ON_Neg_Ov, + ON_Abs_Ov => ON_Abs_Ov, + + -- Comparaisons + ON_Eq => ON_Eq, + ON_Neq => ON_Neq, + ON_Le => ON_Le, + ON_Lt => ON_Lt, + ON_Ge => ON_Ge, + ON_Gt => ON_Gt + ); + + function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Signed_Literal (Ortho_Code.O_Tnode (Ltype), + Value)); + end New_Signed_Literal; + + function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Unsigned_Literal (Ortho_Code.O_Tnode (Ltype), + Value)); + end New_Unsigned_Literal; + + function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Float_Literal (Ortho_Code.O_Tnode (Ltype), + Value)); + end New_Float_Literal; + + function New_Null_Access (Ltype : O_Tnode) return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Null_Access (Ortho_Code.O_Tnode (Ltype))); + end New_Null_Access; + + procedure Start_Record_Aggr (List : out O_Record_Aggr_List; + Atype : O_Tnode) is + begin + Ortho_Code.Consts.Start_Record_Aggr + (Ortho_Code.Consts.O_Record_Aggr_List (List), + Ortho_Code.O_Tnode (Atype)); + end Start_Record_Aggr; + + procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; + Value : O_Cnode) is + begin + Ortho_Code.Consts.New_Record_Aggr_El + (Ortho_Code.Consts.O_Record_Aggr_List (List), + Ortho_Code.O_Cnode (Value)); + end New_Record_Aggr_El; + + procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; + Res : out O_Cnode) is + begin + Ortho_Code.Consts.Finish_Record_Aggr + (Ortho_Code.Consts.O_Record_Aggr_List (List), + Ortho_Code.O_Cnode (Res)); + end Finish_Record_Aggr; + + procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) + is + begin + Ortho_Code.Consts.Start_Array_Aggr + (Ortho_Code.Consts.O_Array_Aggr_List (List), + Ortho_Code.O_Tnode (Atype)); + end Start_Array_Aggr; + + procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; + Value : O_Cnode) is + begin + Ortho_Code.Consts.New_Array_Aggr_El + (Ortho_Code.Consts.O_Array_Aggr_List (List), + Ortho_Code.O_Cnode (Value)); + end New_Array_Aggr_El; + + procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; + Res : out O_Cnode) is + begin + Ortho_Code.Consts.Finish_Array_Aggr + (Ortho_Code.Consts.O_Array_Aggr_List (List), + Ortho_Code.O_Cnode (Res)); + end Finish_Array_Aggr; + + function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Union_Aggr (Ortho_Code.O_Tnode (Atype), + Ortho_Code.O_Fnode (Field), + Ortho_Code.O_Cnode (Value))); + end New_Union_Aggr; + + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Sizeof (Ortho_Code.O_Tnode (Atype), + Ortho_Code.O_Tnode (Rtype))); + end New_Sizeof; + + function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Alignof (Ortho_Code.O_Tnode (Atype), + Ortho_Code.O_Tnode (Rtype))); + end New_Alignof; + + function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Offsetof (Ortho_Code.O_Tnode (Atype), + Ortho_Code.O_Fnode (Field), + Ortho_Code.O_Tnode (Rtype))); + end New_Offsetof; + + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Subprogram_Address + (Ortho_Code.O_Dnode (Subprg), Ortho_Code.O_Tnode (Atype))); + end New_Subprogram_Address; + + function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Global_Address + (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype))); + end New_Global_Address; + + function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode is + begin + return O_Cnode + (Ortho_Code.Consts.New_Global_Unchecked_Address + (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype))); + end New_Global_Unchecked_Address; + + function New_Lit (Lit : O_Cnode) return O_Enode is + begin + return O_Enode (Ortho_Code.Exprs.New_Lit (Ortho_Code.O_Cnode (Lit))); + end New_Lit; + + function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) + return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Dyadic_Op (To_Op (Kind), + Ortho_Code.O_Enode (Left), + Ortho_Code.O_Enode (Right))); + end New_Dyadic_Op; + + function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) + return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Monadic_Op (To_Op (Kind), + Ortho_Code.O_Enode (Operand))); + end New_Monadic_Op; + + function New_Compare_Op + (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) + return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Compare_Op (To_Op (Kind), + Ortho_Code.O_Enode (Left), + Ortho_Code.O_Enode (Right), + Ortho_Code.O_Tnode (Ntype))); + end New_Compare_Op; + + function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) + return O_Lnode is + begin + return O_Lnode + (Ortho_Code.Exprs.New_Indexed_Element (Ortho_Code.O_Lnode (Arr), + Ortho_Code.O_Enode (Index))); + end New_Indexed_Element; + + function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) + return O_Lnode is + begin + return O_Lnode + (Ortho_Code.Exprs.New_Slice (Ortho_Code.O_Lnode (Arr), + Ortho_Code.O_Tnode (Res_Type), + Ortho_Code.O_Enode (Index))); + end New_Slice; + + function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) + return O_Lnode is + begin + return O_Lnode + (Ortho_Code.Exprs.New_Selected_Element (Ortho_Code.O_Lnode (Rec), + Ortho_Code.O_Fnode (El))); + end New_Selected_Element; + + function New_Access_Element (Acc : O_Enode) return O_Lnode is + begin + return O_Lnode + (Ortho_Code.Exprs.New_Access_Element (Ortho_Code.O_Enode (Acc))); + end New_Access_Element; + + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Convert_Ov (Ortho_Code.O_Enode (Val), + Ortho_Code.O_Tnode (Rtype))); + end New_Convert_Ov; + + function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Address (Ortho_Code.O_Lnode (Lvalue), + Ortho_Code.O_Tnode (Atype))); + end New_Address; + + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Unchecked_Address (Ortho_Code.O_Lnode (Lvalue), + Ortho_Code.O_Tnode (Atype))); + end New_Unchecked_Address; + + function New_Value (Lvalue : O_Lnode) return O_Enode is + begin + return O_Enode + (Ortho_Code.Exprs.New_Value (Ortho_Code.O_Lnode (Lvalue))); + end New_Value; + + function New_Obj_Value (Obj : O_Dnode) return O_Enode is + begin + return New_Value (New_Obj (Obj)); + end New_Obj_Value; + + function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode is + begin + return O_Enode (Ortho_Code.Exprs.New_Alloca (Ortho_Code.O_Tnode (Rtype), + Ortho_Code.O_Enode (Size))); + end New_Alloca; + + --------------------- + -- Declarations. -- + --------------------- + + procedure New_Debug_Filename_Decl (Filename : String) + renames Ortho_Code.Abi.New_Debug_Filename_Decl; + + procedure New_Debug_Line_Decl (Line : Natural) + is + pragma Unreferenced (Line); + begin + null; + end New_Debug_Line_Decl; + + procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is + begin + Ortho_Code.Decls.New_Type_Decl (Ident, Ortho_Code.O_Tnode (Atype)); + end New_Type_Decl; + + To_Storage : constant array (O_Storage) of Ortho_Code.O_Storage := + (O_Storage_External => O_Storage_External, + O_Storage_Public => O_Storage_Public, + O_Storage_Private => O_Storage_Private, + O_Storage_Local => O_Storage_Local); + + procedure New_Const_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode) is + begin + Ortho_Code.Decls.New_Const_Decl + (Ortho_Code.O_Dnode (Res), Ident, To_Storage (Storage), + Ortho_Code.O_Tnode (Atype)); + end New_Const_Decl; + + procedure New_Var_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode) is + begin + Ortho_Code.Decls.New_Var_Decl + (Ortho_Code.O_Dnode (Res), Ident, To_Storage (Storage), + Ortho_Code.O_Tnode (Atype)); + end New_Var_Decl; + + function New_Obj (Obj : O_Dnode) return O_Lnode is + begin + return O_Lnode (Ortho_Code.Exprs.New_Obj (Ortho_Code.O_Dnode (Obj))); + end New_Obj; + + procedure Start_Function_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage; + Rtype : O_Tnode) is + begin + Ortho_Code.Decls.Start_Function_Decl + (Ortho_Code.Decls.O_Inter_List (Interfaces), + Ident, To_Storage (Storage), Ortho_Code.O_Tnode (Rtype)); + end Start_Function_Decl; + + procedure Start_Procedure_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage) is + begin + Ortho_Code.Decls.Start_Procedure_Decl + (Ortho_Code.Decls.O_Inter_List (Interfaces), + Ident, To_Storage (Storage)); + end Start_Procedure_Decl; + + procedure New_Interface_Decl + (Interfaces : in out O_Inter_List; + Res : out O_Dnode; + Ident : O_Ident; + Atype : O_Tnode) is + begin + Ortho_Code.Decls.New_Interface_Decl + (Ortho_Code.Decls.O_Inter_List (Interfaces), + Ortho_Code.O_Dnode (Res), + Ident, + Ortho_Code.O_Tnode (Atype)); + end New_Interface_Decl; + + procedure Finish_Subprogram_Decl + (Interfaces : in out O_Inter_List; Res : out O_Dnode) is + begin + Ortho_Code.Decls.Finish_Subprogram_Decl + (Ortho_Code.Decls.O_Inter_List (Interfaces), Ortho_Code.O_Dnode (Res)); + end Finish_Subprogram_Decl; + + procedure Start_Subprogram_Body (Func : O_Dnode) is + begin + Ortho_Code.Exprs.Start_Subprogram_Body (Ortho_Code.O_Dnode (Func)); + end Start_Subprogram_Body; + + procedure Finish_Subprogram_Body + renames Ortho_Code.Exprs.Finish_Subprogram_Body; + + ------------------- + -- Statements. -- + ------------------- + + procedure New_Debug_Line_Stmt (Line : Natural) + renames Ortho_Code.Exprs.New_Debug_Line_Stmt; + + procedure New_Debug_Comment_Decl (Comment : String) + is + pragma Unreferenced (Comment); + begin + null; + end New_Debug_Comment_Decl; + + procedure Start_Declare_Stmt renames + Ortho_Code.Exprs.Start_Declare_Stmt; + procedure Finish_Declare_Stmt renames + Ortho_Code.Exprs.Finish_Declare_Stmt; + + procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) is + begin + Ortho_Code.Exprs.Start_Association + (Ortho_Code.Exprs.O_Assoc_List (Assocs), Ortho_Code.O_Dnode (Subprg)); + end Start_Association; + + procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is + begin + Ortho_Code.Exprs.New_Association + (Ortho_Code.Exprs.O_Assoc_List (Assocs), Ortho_Code.O_Enode (Val)); + end New_Association; + + function New_Function_Call (Assocs : O_Assoc_List) return O_Enode is + begin + return O_Enode (Ortho_Code.Exprs.New_Function_Call + (Ortho_Code.Exprs.O_Assoc_List (Assocs))); + end New_Function_Call; + + procedure New_Procedure_Call (Assocs : in out O_Assoc_List) is + begin + Ortho_Code.Exprs.New_Procedure_Call + (Ortho_Code.Exprs.O_Assoc_List (Assocs)); + end New_Procedure_Call; + + procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) is + begin + Ortho_Code.Exprs.New_Assign_Stmt (Ortho_Code.O_Lnode (Target), + Ortho_Code.O_Enode (Value)); + end New_Assign_Stmt; + + procedure New_Return_Stmt (Value : O_Enode) is + begin + Ortho_Code.Exprs.New_Return_Stmt (Ortho_Code.O_Enode (Value)); + end New_Return_Stmt; + + procedure New_Return_Stmt + renames Ortho_Code.Exprs.New_Return_Stmt; + + procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) is + begin + Ortho_Code.Exprs.Start_If_Stmt (Ortho_Code.Exprs.O_If_Block (Block), + Ortho_Code.O_Enode (Cond)); + end Start_If_Stmt; + + procedure New_Else_Stmt (Block : in out O_If_Block) is + begin + Ortho_Code.Exprs.New_Else_Stmt (Ortho_Code.Exprs.O_If_Block (Block)); + end New_Else_Stmt; + + procedure Finish_If_Stmt (Block : in out O_If_Block) is + begin + Ortho_Code.Exprs.Finish_If_Stmt (Ortho_Code.Exprs.O_If_Block (Block)); + end Finish_If_Stmt; + + procedure Start_Loop_Stmt (Label : out O_Snode) is + begin + Ortho_Code.Exprs.Start_Loop_Stmt (Ortho_Code.Exprs.O_Snode (Label)); + end Start_Loop_Stmt; + + procedure Finish_Loop_Stmt (Label : in out O_Snode) is + begin + Ortho_Code.Exprs.Finish_Loop_Stmt (Ortho_Code.Exprs.O_Snode (Label)); + end Finish_Loop_Stmt; + + procedure New_Exit_Stmt (L : O_Snode) is + begin + Ortho_Code.Exprs.New_Exit_Stmt (Ortho_Code.Exprs.O_Snode (L)); + end New_Exit_Stmt; + + procedure New_Next_Stmt (L : O_Snode) is + begin + Ortho_Code.Exprs.New_Next_Stmt (Ortho_Code.Exprs.O_Snode (L)); + end New_Next_Stmt; + + procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is + begin + Ortho_Code.Exprs.Start_Case_Stmt + (Ortho_Code.Exprs.O_Case_Block (Block), Ortho_Code.O_Enode (Value)); + end Start_Case_Stmt; + + procedure Start_Choice (Block : in out O_Case_Block) is + begin + Ortho_Code.Exprs.Start_Choice (Ortho_Code.Exprs.O_Case_Block (Block)); + end Start_Choice; + + procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is + begin + Ortho_Code.Exprs.New_Expr_Choice (Ortho_Code.Exprs.O_Case_Block (Block), + Ortho_Code.O_Cnode (Expr)); + end New_Expr_Choice; + + procedure New_Range_Choice (Block : in out O_Case_Block; + Low, High : O_Cnode) is + begin + Ortho_Code.Exprs.New_Range_Choice + (Ortho_Code.Exprs.O_Case_Block (Block), + Ortho_Code.O_Cnode (Low), Ortho_Code.O_Cnode (High)); + end New_Range_Choice; + + procedure New_Default_Choice (Block : in out O_Case_Block) is + begin + Ortho_Code.Exprs.New_Default_Choice + (Ortho_Code.Exprs.O_Case_Block (Block)); + end New_Default_Choice; + + procedure Finish_Choice (Block : in out O_Case_Block) is + begin + Ortho_Code.Exprs.Finish_Choice (Ortho_Code.Exprs.O_Case_Block (Block)); + end Finish_Choice; + + procedure Finish_Case_Stmt (Block : in out O_Case_Block) is + begin + Ortho_Code.Exprs.Finish_Case_Stmt + (Ortho_Code.Exprs.O_Case_Block (Block)); + end Finish_Case_Stmt; + procedure Init is begin -- Create an anonymous pointer type. - if New_Access_Type (O_Tnode_Null) /= O_Tnode_Ptr then + if New_Access_Type (O_Tnode_Null) /= O_Tnode (O_Tnode_Ptr) then raise Program_Error; end if; -- Do not finish the access, since this creates an infinite recursion diff --git a/ortho/mcode/ortho_mcode.ads b/ortho/mcode/ortho_mcode.ads index 369e743..1ee9d7e 100644 --- a/ortho/mcode/ortho_mcode.ads +++ b/ortho/mcode/ortho_mcode.ads @@ -1,3 +1,6 @@ +-- DO NOT MODIFY - this file was generated from: +-- ortho_nodes.common.ads and ortho_mcode.private.ads +-- -- Mcode back-end for ortho. -- Copyright (C) 2006 Tristan Gingold -- @@ -21,276 +24,268 @@ with Ortho_Code.Types; use Ortho_Code.Types; with Ortho_Code.Consts; use Ortho_Code.Consts; with Ortho_Code.Decls; use Ortho_Code.Decls; with Ortho_Code.Exprs; use Ortho_Code.Exprs; -with Ortho_Code.Abi; -- Interface to create nodes. package Ortho_Mcode is - --- PUBLIC DECLARATIONS - subtype O_Tnode is Ortho_Code.O_Tnode; - subtype O_Cnode is Ortho_Code.O_Cnode; - subtype O_Dnode is Ortho_Code.O_Dnode; - subtype O_Enode is Ortho_Code.O_Enode; - subtype O_Fnode is Ortho_Code.O_Fnode; - subtype O_Lnode is Ortho_Code.O_Lnode; - subtype O_Snode is Ortho_Code.Exprs.O_Snode; - - O_Lnode_Null : constant O_Lnode := Ortho_Code.O_Lnode_Null; - O_Cnode_Null : constant O_Cnode := Ortho_Code.O_Cnode_Null; - O_Dnode_Null : constant O_Dnode := Ortho_Code.O_Dnode_Null; - O_Enode_Null : constant O_Enode := Ortho_Code.O_Enode_Null; - O_Fnode_Null : constant O_Fnode := Ortho_Code.O_Fnode_Null; - O_Snode_Null : O_Snode renames Ortho_Code.Exprs.O_Snode_Null; - O_Tnode_Null : constant O_Tnode := Ortho_Code.O_Tnode_Null; - function "=" (L, R : O_Tnode) return Boolean renames Ortho_Code."="; - function "=" (L, R : O_Cnode) return Boolean renames Ortho_Code."="; - function "=" (L, R : O_Snode) return Boolean renames Ortho_Code.Exprs."="; - function "=" (L, R : O_Dnode) return Boolean renames Ortho_Code."="; - function "=" (L, R : O_Enode) return Boolean renames Ortho_Code."="; - function "=" (L, R : O_Fnode) return Boolean renames Ortho_Code."="; - function "=" (L, R : O_Lnode) return Boolean renames Ortho_Code."="; - -- Initialize nodes. procedure Init; procedure Finish; procedure Free_All; - subtype O_Element_List is Ortho_Code.Types.O_Element_List; +-- Start of common part - -- Build a record type. - procedure Start_Record_Type (Elements : out O_Element_List) - renames Ortho_Code.Types.Start_Record_Type; + type O_Enode is private; + type O_Cnode is private; + type O_Lnode is private; + type O_Tnode is private; + type O_Snode is private; + type O_Dnode is private; + type O_Fnode is private; + + 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 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) - renames Ortho_Code.Types.New_Record_Field; - + Ident : O_Ident; Etype : O_Tnode); -- Finish the record type. procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode) - renames Ortho_Code.Types.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) - renames Ortho_Code.Types.New_Uncomplete_Record_Type; + procedure New_Uncomplete_Record_Type (Res : out O_Tnode); procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List) - renames Ortho_Code.Types.Start_Uncomplete_Record_Type; + Elements : out O_Element_List); -- Build an union type. - procedure Start_Union_Type (Elements : out O_Element_List) - renames Ortho_Code.Types.Start_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) - renames Ortho_Code.Types.New_Union_Field; + Etype : O_Tnode); procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode) - renames Ortho_Code.Types.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 - renames Ortho_Code.Types.New_Access_Type; - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) - renames Ortho_Code.Types.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 - renames Ortho_Code.Types.New_Array_Type; + return O_Tnode; -- Build a constrained array type. function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) - return O_Tnode; + return O_Tnode; -- Build a scalar type; size may be 8, 16, 32 or 64. - function New_Unsigned_Type (Size : Natural) return O_Tnode - renames Ortho_Code.Types.New_Unsigned_Type; - function New_Signed_Type (Size : Natural) return O_Tnode - renames Ortho_Code.Types.New_Signed_Type; + 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 - renames Ortho_Code.Types.New_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) - renames Ortho_Code.Types.New_Boolean_Type; + True_E : out O_Cnode); -- Create an enumeration - subtype O_Enum_List is Ortho_Code.Types.O_Enum_List; + 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) - renames Ortho_Code.Types.Start_Enum_Type; + 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) - renames Ortho_Code.Types.New_Enum_Literal; - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) - renames Ortho_Code.Types.Finish_Enum_Type; + Ident : O_Ident; Res : out O_Cnode); + procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode); - ------------------- - -- Expressions -- - ------------------- + ---------------- + -- 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; - subtype ON_Op_Kind is Ortho_Code.ON_Op_Kind; - function "=" (L, R : ON_Op_Kind) return Boolean renames Ortho_Code."="; + -- Returns the alignment in bytes for ATYPE. The result is a literal of + -- unsgined type RTYPE. + function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - ON_Nil : constant ON_Op_Kind := Ortho_Code.ON_Nil; + -- Returns the offset of FIELD in its record ATYPE. The result is a + -- literal of unsigned type or access type RTYPE. + function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) + return O_Cnode; - ON_Add_Ov : constant ON_Op_Kind := Ortho_Code.ON_Add_Ov; - ON_Sub_Ov : constant ON_Op_Kind := Ortho_Code.ON_Sub_Ov; - ON_Mul_Ov : constant ON_Op_Kind := Ortho_Code.ON_Mul_Ov; - ON_Div_Ov : constant ON_Op_Kind := Ortho_Code.ON_Div_Ov; - ON_Rem_Ov : constant ON_Op_Kind := Ortho_Code.ON_Rem_Ov; - ON_Mod_Ov : constant ON_Op_Kind := Ortho_Code.ON_Mod_Ov; + -- Get the address of a subprogram. + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Cnode; - ON_And : constant ON_Op_Kind := Ortho_Code.ON_And; - ON_Or : constant ON_Op_Kind := Ortho_Code.ON_Or; - ON_Xor : constant ON_Op_Kind := Ortho_Code.ON_Xor; + -- 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; - -- Monadic operations. - ON_Not : constant ON_Op_Kind := Ortho_Code.ON_Not; - ON_Neg_Ov : constant ON_Op_Kind := Ortho_Code.ON_Neg_Ov; - ON_Abs_Ov : constant ON_Op_Kind := Ortho_Code.ON_Abs_Ov; + ------------------- + -- Expressions -- + ------------------- - -- Comparaisons - ON_Eq : constant ON_Op_Kind := Ortho_Code.ON_Eq; - ON_Neq : constant ON_Op_Kind := Ortho_Code.ON_Neq; - ON_Le : constant ON_Op_Kind := Ortho_Code.ON_Le; - ON_Lt : constant ON_Op_Kind := Ortho_Code.ON_Lt; - ON_Ge : constant ON_Op_Kind := Ortho_Code.ON_Ge; - ON_Gt : constant ON_Op_Kind := Ortho_Code.ON_Gt; + 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 + + -- 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_Xor; 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; - subtype O_Storage is Ortho_Code.O_Storage; - O_Storage_Private : constant O_Storage := Ortho_Code.O_Storage_Private; - O_Storage_Local : constant O_Storage := Ortho_Code.O_Storage_Local; - O_Storage_Public : constant O_Storage := Ortho_Code.O_Storage_Public; - O_Storage_External : constant O_Storage := Ortho_Code.O_Storage_External; - function "=" (L, R : O_Storage) return Boolean renames Ortho_Code."="; + 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; - function New_Lit (Lit : O_Cnode) return O_Enode - renames Ortho_Code.Exprs.New_Lit; + -- 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 - renames Ortho_Code.Exprs.New_Dyadic_Op; + 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 - renames Ortho_Code.Exprs.New_Monadic_Op; + 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 - renames Ortho_Code.Exprs.New_Compare_Op; - - -- Create a literal from an integer. - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode - renames Ortho_Code.Consts.New_Signed_Literal; - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode - renames Ortho_Code.Consts.New_Unsigned_Literal; - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode - renames Ortho_Code.Consts.New_Float_Literal; - - -- Create a null access literal. - function New_Null_Access (Ltype : O_Tnode) return O_Cnode - renames Ortho_Code.Consts.New_Null_Access; - - subtype O_Inter_List is Ortho_Code.Decls.O_Inter_List; - subtype O_Record_Aggr_List is Ortho_Code.Consts.O_Record_Aggr_List; - subtype O_Array_Aggr_List is Ortho_Code.Consts.O_Array_Aggr_List; - subtype O_Assoc_List is Ortho_Code.Exprs.O_Assoc_List; - subtype O_If_Block is Ortho_Code.Exprs.O_If_Block; - subtype O_Case_Block is Ortho_Code.Exprs.O_Case_Block; - - - -- 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. - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; - Atype : O_Tnode) - renames Ortho_Code.Consts.Start_Record_Aggr; - procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; - Value : O_Cnode) - renames Ortho_Code.Consts.New_Record_Aggr_El; - procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; - Res : out O_Cnode) - renames Ortho_Code.Consts.Finish_Record_Aggr; - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) - renames Ortho_Code.Consts.Start_Array_Aggr; - procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; - Value : O_Cnode) - renames Ortho_Code.Consts.New_Array_Aggr_El; - procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; - Res : out O_Cnode) - renames Ortho_Code.Consts.Finish_Array_Aggr; - - -- Build an union aggregate. - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode - renames Ortho_Code.Consts.New_Union_Aggr; + return O_Enode; - -- 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 - renames Ortho_Code.Consts.New_Sizeof; - -- Returns the alignment in bytes for ATYPE. The result is a literal of - -- unsgined type RTYPE. - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode - renames Ortho_Code.Consts.New_Alignof; + 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; - -- Returns the offset of FIELD in its record REC_TYPE. The result is a - -- literal of unsigned type or access type RTYPE. - function New_Offsetof (Rec_Type : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode - renames Ortho_Code.Consts.New_Offsetof; -- 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 - renames Ortho_Code.Exprs.New_Indexed_Element; + 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. @@ -298,66 +293,51 @@ package Ortho_Mcode is -- 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 - renames Ortho_Code.Exprs.New_Slice; + 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 - renames Ortho_Code.Exprs.New_Selected_Element; + return O_Lnode; -- Reference an access. -- Type of ACC must be an access type. - function New_Access_Element (Acc : O_Enode) return O_Lnode - renames Ortho_Code.Exprs.New_Access_Element; + 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 - renames Ortho_Code.Exprs.New_Convert_Ov; + 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 - renames Ortho_Code.Exprs.New_Address; - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - renames Ortho_Code.Consts.New_Global_Address; + 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 - renames Ortho_Code.Exprs.New_Unchecked_Address; - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - renames Ortho_Code.Consts.New_Global_Unchecked_Address; - - -- Get the address of a subprogram. - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode - renames Ortho_Code.Consts.New_Subprogram_Address; + return O_Enode; -- Get the value of an Lvalue. - function New_Value (Lvalue : O_Lnode) return O_Enode - renames Ortho_Code.Exprs.New_Value; - - -- Get the value of object OBJ. + 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 - renames Ortho_Code.Exprs.New_Alloca; + 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. -- --------------------- - -- Following lines applies to FILENAME. - procedure New_Debug_Filename_Decl (Filename : String) - renames Ortho_Code.Abi.New_Debug_Filename_Decl; + -- 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); @@ -365,11 +345,6 @@ package Ortho_Mcode is -- Add a comment in the declarative region. procedure New_Debug_Comment_Decl (Comment : String); - -- Declare a type. - -- This simply gives a name to a type. - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) - renames Ortho_Code.Decls.New_Type_Decl; - -- 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. @@ -378,8 +353,7 @@ package Ortho_Mcode is (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; - Atype : O_Tnode) - renames Ortho_Code.Decls.New_Const_Decl; + Atype : O_Tnode); -- Set the value of a non-external constant. procedure Start_Const_Value (Const : in out O_Dnode); @@ -392,11 +366,7 @@ package Ortho_Mcode is (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; - Atype : O_Tnode) - renames Ortho_Code.Decls.New_Var_Decl; - - function New_Obj (Decl : O_Dnode) return O_Lnode - renames Ortho_Code.Exprs.New_Obj; + Atype : O_Tnode); -- Start a subprogram declaration. -- Note: nested subprograms are allowed, ie o_storage_local subprograms can @@ -407,34 +377,28 @@ package Ortho_Mcode is (Interfaces : out O_Inter_List; Ident : O_Ident; Storage : O_Storage; - Rtype : O_Tnode) - renames Ortho_Code.Decls.Start_Function_Decl; + Rtype : O_Tnode); -- For a subprogram without return value. procedure Start_Procedure_Decl (Interfaces : out O_Inter_List; Ident : O_Ident; - Storage : O_Storage) - renames Ortho_Code.Decls.Start_Procedure_Decl; + 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) - renames Ortho_Code.Decls.New_Interface_Decl; + 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) - renames Ortho_Code.Decls.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) - renames Ortho_Code.Exprs.Start_Subprogram_Body; + procedure Start_Subprogram_Body (Func : O_Dnode); -- Finish a subprogram body. - procedure Finish_Subprogram_Body - renames Ortho_Code.Exprs.Finish_Subprogram_Body; + procedure Finish_Subprogram_Body; ------------------- @@ -442,80 +406,174 @@ package Ortho_Mcode is ------------------- -- Add a line number as a statement. - procedure New_Debug_Line_Stmt (Line : Natural) - renames Ortho_Code.Exprs.New_Debug_Line_Stmt; + 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 renames - Ortho_Code.Exprs.Start_Declare_Stmt; - procedure Finish_Declare_Stmt renames - Ortho_Code.Exprs.Finish_Declare_Stmt; + 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) - renames Ortho_Code.Exprs.Start_Association; - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) - renames Ortho_Code.Exprs.New_Association; - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode - renames Ortho_Code.Exprs.New_Function_Call; - procedure New_Procedure_Call (Assocs : in out O_Assoc_List) - renames Ortho_Code.Exprs.New_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) - renames Ortho_Code.Exprs.New_Assign_Stmt; + procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode); -- Exit from the subprogram and return VALUE. - procedure New_Return_Stmt (Value : O_Enode) - renames Ortho_Code.Exprs.New_Return_Stmt; + procedure New_Return_Stmt (Value : O_Enode); -- Exit from the subprogram, which doesn't return value. - procedure New_Return_Stmt - renames Ortho_Code.Exprs.New_Return_Stmt; + procedure New_Return_Stmt; -- Build an IF statement. - procedure Start_If_Stmt (Block : out O_If_Block; Cond : O_Enode) - renames Ortho_Code.Exprs.Start_If_Stmt; - procedure New_Else_Stmt (Block : in out O_If_Block) - renames Ortho_Code.Exprs.New_Else_Stmt; - procedure Finish_If_Stmt (Block : in out O_If_Block) - renames Ortho_Code.Exprs.Finish_If_Stmt; + procedure Start_If_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) - renames Ortho_Code.Exprs.Start_Loop_Stmt; - procedure Finish_Loop_Stmt (Label : in out O_Snode) - renames Ortho_Code.Exprs.Finish_Loop_Stmt; + 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) - renames Ortho_Code.Exprs.New_Exit_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) - renames Ortho_Code.Exprs.New_Next_Stmt; + procedure New_Next_Stmt (L : O_Snode); -- Case statement. -- VALUE is the selector and must be a discrete type. - procedure Start_Case_Stmt (Block : out O_Case_Block; Value : O_Enode) - renames Ortho_Code.Exprs.Start_Case_Stmt; - - -- Start a branch before the choices. - procedure Start_Choice (Block : in out O_Case_Block) - renames Ortho_Code.Exprs.Start_Choice; - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) - renames Ortho_Code.Exprs.New_Expr_Choice; + 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) - renames Ortho_Code.Exprs.New_Range_Choice; - procedure New_Default_Choice (Block : in out O_Case_Block) - renames Ortho_Code.Exprs.New_Default_Choice; - -- Finish a branch after a choice, allow regular statements. - procedure Finish_Choice (Block : in out O_Case_Block) - renames Ortho_Code.Exprs.Finish_Choice; - procedure Finish_Case_Stmt (Block : in out O_Case_Block) - renames Ortho_Code.Exprs.Finish_Case_Stmt; + 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); + +-- End of common part +private + --- PUBLIC DECLARATIONS + type O_Tnode is new Ortho_Code.O_Tnode; + type O_Cnode is new Ortho_Code.O_Cnode; + type O_Dnode is new Ortho_Code.O_Dnode; + type O_Enode is new Ortho_Code.O_Enode; + type O_Fnode is new Ortho_Code.O_Fnode; + type O_Lnode is new Ortho_Code.O_Lnode; + type O_Snode is new Ortho_Code.Exprs.O_Snode; + + O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null); + O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null); + O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null); + O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null); + O_Fnode_Null : constant O_Fnode := O_Fnode (Ortho_Code.O_Fnode_Null); + O_Snode_Null : constant O_Snode := O_Snode (Ortho_Code.Exprs.O_Snode_Null); + O_Tnode_Null : constant O_Tnode := O_Tnode (Ortho_Code.O_Tnode_Null); + + type O_Element_List is new Ortho_Code.Types.O_Element_List; + type O_Enum_List is new Ortho_Code.Types.O_Enum_List; + type O_Inter_List is new Ortho_Code.Decls.O_Inter_List; + type O_Record_Aggr_List is new Ortho_Code.Consts.O_Record_Aggr_List; + type O_Array_Aggr_List is new Ortho_Code.Consts.O_Array_Aggr_List; + type O_Assoc_List is new Ortho_Code.Exprs.O_Assoc_List; + type O_If_Block is new Ortho_Code.Exprs.O_If_Block; + type O_Case_Block is new Ortho_Code.Exprs.O_Case_Block; + + pragma Inline (New_Lit); + pragma Inline (New_Dyadic_Op); + pragma Inline (New_Monadic_Op); + pragma Inline (New_Compare_Op); + pragma Inline (New_Signed_Literal); + pragma Inline (New_Unsigned_Literal); + pragma Inline (New_Float_Literal); + pragma Inline (New_Null_Access); + + pragma Inline (Start_Record_Aggr); + pragma Inline (New_Record_Aggr_El); + pragma Inline (Finish_Record_Aggr); + + pragma Inline (Start_Array_Aggr); + pragma Inline (New_Array_Aggr_El); + pragma Inline (Finish_Array_Aggr); + + pragma Inline (New_Union_Aggr); + pragma Inline (New_Sizeof); + pragma Inline (New_Alignof); + pragma Inline (New_Offsetof); + + pragma Inline (New_Indexed_Element); + pragma Inline (New_Slice); + pragma Inline (New_Selected_Element); + pragma Inline (New_Access_Element); + + pragma Inline (New_Convert_Ov); + + pragma Inline (New_Address); + pragma Inline (New_Global_Address); + pragma Inline (New_Unchecked_Address); + pragma Inline (New_Global_Unchecked_Address); + pragma Inline (New_Subprogram_Address); + + pragma Inline (New_Value); + pragma Inline (New_Obj_Value); + + pragma Inline (New_Alloca); + + pragma Inline (New_Debug_Filename_Decl); + pragma Inline (New_Debug_Line_Decl); + pragma Inline (New_Debug_Comment_Decl); + + pragma Inline (New_Type_Decl); + pragma Inline (New_Const_Decl); + + pragma Inline (Start_Const_Value); + pragma Inline (Finish_Const_Value); + pragma Inline (New_Var_Decl); + + pragma Inline (New_Obj); + pragma Inline (Start_Function_Decl); + pragma Inline (Start_Procedure_Decl); + pragma Inline (New_Interface_Decl); + pragma Inline (Finish_Subprogram_Decl); + pragma Inline (Start_Subprogram_Body); + pragma Inline (Finish_Subprogram_Body); + + pragma Inline (New_Debug_Line_Stmt); + pragma Inline (New_Debug_Comment_Stmt); + + pragma Inline (Start_Declare_Stmt); + pragma Inline (Finish_Declare_Stmt); + + -- Create a function call or a procedure call. + pragma Inline (Start_Association); + pragma Inline (New_Association); + pragma Inline (New_Function_Call); + pragma Inline (New_Procedure_Call); + + pragma Inline (New_Assign_Stmt); + pragma Inline (New_Return_Stmt); + pragma Inline (Start_If_Stmt); + pragma Inline (New_Else_Stmt); + pragma Inline (Finish_If_Stmt); + + pragma Inline (Start_Loop_Stmt); + pragma Inline (Finish_Loop_Stmt); + pragma Inline (New_Exit_Stmt); + pragma Inline (New_Next_Stmt); + + pragma Inline (Start_Case_Stmt); + pragma Inline (Start_Choice); + pragma Inline (New_Expr_Choice); + pragma Inline (New_Range_Choice); + pragma Inline (New_Default_Choice); + pragma Inline (Finish_Choice); + pragma Inline (Finish_Case_Stmt); end Ortho_Mcode; diff --git a/ortho/mcode/ortho_mcode.private.ads b/ortho/mcode/ortho_mcode.private.ads new file mode 100644 index 0000000..5d3f70e --- /dev/null +++ b/ortho/mcode/ortho_mcode.private.ads @@ -0,0 +1,149 @@ +-- Mcode back-end for ortho. +-- Copyright (C) 2006 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Interfaces; use Interfaces; +with Ortho_Code; use Ortho_Code; +with Ortho_Code.Types; use Ortho_Code.Types; +with Ortho_Code.Consts; use Ortho_Code.Consts; +with Ortho_Code.Decls; use Ortho_Code.Decls; +with Ortho_Code.Exprs; use Ortho_Code.Exprs; + +-- Interface to create nodes. +package Ortho_Mcode is + -- Initialize nodes. + procedure Init; + procedure Finish; + + procedure Free_All; + +private + --- PUBLIC DECLARATIONS + type O_Tnode is new Ortho_Code.O_Tnode; + type O_Cnode is new Ortho_Code.O_Cnode; + type O_Dnode is new Ortho_Code.O_Dnode; + type O_Enode is new Ortho_Code.O_Enode; + type O_Fnode is new Ortho_Code.O_Fnode; + type O_Lnode is new Ortho_Code.O_Lnode; + type O_Snode is new Ortho_Code.Exprs.O_Snode; + + O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null); + O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null); + O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null); + O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null); + O_Fnode_Null : constant O_Fnode := O_Fnode (Ortho_Code.O_Fnode_Null); + O_Snode_Null : constant O_Snode := O_Snode (Ortho_Code.Exprs.O_Snode_Null); + O_Tnode_Null : constant O_Tnode := O_Tnode (Ortho_Code.O_Tnode_Null); + + type O_Element_List is new Ortho_Code.Types.O_Element_List; + type O_Enum_List is new Ortho_Code.Types.O_Enum_List; + type O_Inter_List is new Ortho_Code.Decls.O_Inter_List; + type O_Record_Aggr_List is new Ortho_Code.Consts.O_Record_Aggr_List; + type O_Array_Aggr_List is new Ortho_Code.Consts.O_Array_Aggr_List; + type O_Assoc_List is new Ortho_Code.Exprs.O_Assoc_List; + type O_If_Block is new Ortho_Code.Exprs.O_If_Block; + type O_Case_Block is new Ortho_Code.Exprs.O_Case_Block; + + pragma Inline (New_Lit); + pragma Inline (New_Dyadic_Op); + pragma Inline (New_Monadic_Op); + pragma Inline (New_Compare_Op); + pragma Inline (New_Signed_Literal); + pragma Inline (New_Unsigned_Literal); + pragma Inline (New_Float_Literal); + pragma Inline (New_Null_Access); + + pragma Inline (Start_Record_Aggr); + pragma Inline (New_Record_Aggr_El); + pragma Inline (Finish_Record_Aggr); + + pragma Inline (Start_Array_Aggr); + pragma Inline (New_Array_Aggr_El); + pragma Inline (Finish_Array_Aggr); + + pragma Inline (New_Union_Aggr); + pragma Inline (New_Sizeof); + pragma Inline (New_Alignof); + pragma Inline (New_Offsetof); + + pragma Inline (New_Indexed_Element); + pragma Inline (New_Slice); + pragma Inline (New_Selected_Element); + pragma Inline (New_Access_Element); + + pragma Inline (New_Convert_Ov); + + pragma Inline (New_Address); + pragma Inline (New_Global_Address); + pragma Inline (New_Unchecked_Address); + pragma Inline (New_Global_Unchecked_Address); + pragma Inline (New_Subprogram_Address); + + pragma Inline (New_Value); + pragma Inline (New_Obj_Value); + + pragma Inline (New_Alloca); + + pragma Inline (New_Debug_Filename_Decl); + pragma Inline (New_Debug_Line_Decl); + pragma Inline (New_Debug_Comment_Decl); + + pragma Inline (New_Type_Decl); + pragma Inline (New_Const_Decl); + + pragma Inline (Start_Const_Value); + pragma Inline (Finish_Const_Value); + pragma Inline (New_Var_Decl); + + pragma Inline (New_Obj); + pragma Inline (Start_Function_Decl); + pragma Inline (Start_Procedure_Decl); + pragma Inline (New_Interface_Decl); + pragma Inline (Finish_Subprogram_Decl); + pragma Inline (Start_Subprogram_Body); + pragma Inline (Finish_Subprogram_Body); + + pragma Inline (New_Debug_Line_Stmt); + pragma Inline (New_Debug_Comment_Stmt); + + pragma Inline (Start_Declare_Stmt); + pragma Inline (Finish_Declare_Stmt); + + -- Create a function call or a procedure call. + pragma Inline (Start_Association); + pragma Inline (New_Association); + pragma Inline (New_Function_Call); + pragma Inline (New_Procedure_Call); + + pragma Inline (New_Assign_Stmt); + pragma Inline (New_Return_Stmt); + pragma Inline (Start_If_Stmt); + pragma Inline (New_Else_Stmt); + pragma Inline (Finish_If_Stmt); + + pragma Inline (Start_Loop_Stmt); + pragma Inline (Finish_Loop_Stmt); + pragma Inline (New_Exit_Stmt); + pragma Inline (New_Next_Stmt); + + pragma Inline (Start_Case_Stmt); + pragma Inline (Start_Choice); + pragma Inline (New_Expr_Choice); + pragma Inline (New_Range_Choice); + pragma Inline (New_Default_Choice); + pragma Inline (Finish_Choice); + pragma Inline (Finish_Case_Stmt); +end Ortho_Mcode; diff --git a/ortho/ortho_nodes.common.ads b/ortho/ortho_nodes.common.ads index ee26f60..bd573c0 100644 --- a/ortho/ortho_nodes.common.ads +++ b/ortho/ortho_nodes.common.ads @@ -18,11 +18,17 @@ with Interfaces; use Interfaces; with Ortho_Ident; use Ortho_Ident; ---- PRIVATE CONTEXT CLAUSES -- Interface to create nodes. package ORTHO_NODES is - --- PUBLIC DECLARATIONS + + type O_Enode is private; + type O_Cnode is private; + type O_Lnode is private; + type O_Tnode is private; + type O_Snode is private; + type O_Dnode is private; + type O_Fnode is private; O_Cnode_Null : constant O_Cnode; O_Dnode_Null : constant O_Dnode; @@ -37,19 +43,6 @@ package ORTHO_NODES is -- 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. @@ -171,9 +164,9 @@ package ORTHO_NODES is -- unsgined type RTYPE. function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - -- Returns the offset of FIELD in its record REC_TYPE. The result is a + -- Returns the offset of FIELD in its record ATYPE. The result is a -- literal of unsigned type or access type RTYPE. - function New_Offsetof (Rec_Type : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) + function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) return O_Cnode; -- Get the address of a subprogram. @@ -211,8 +204,6 @@ package ORTHO_NODES is 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 @@ -228,7 +219,7 @@ package ORTHO_NODES is ON_Gt -- ON_Compare_Op_Kind ); - subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Or_Else; + subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor; 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; diff --git a/translate/Makefile b/translate/Makefile index 3033b3a..b331b57 100644 --- a/translate/Makefile +++ b/translate/Makefile @@ -18,35 +18,15 @@ BE=gcc ortho_srcdir=../ortho -GNAT_FLAGS=-aI.. -aI../psl -gnaty3befhkmr -gnata -gnatf -gnatwael +GNAT_FLAGS=-aI.. -aI../psl -gnaty3befhkmr -gnata -gnatf -gnatwael -gnat05 #GNAT_FLAGS+=-O -gnatn LN=ln -s -compiler: force # ortho_nodes.ads ortho_$(BE)_front.ads +compiler: force # ortho_nodes.ads ortho_$(BE)_front.ads $(MAKE) -f $(ortho_srcdir)/$(BE)/Makefile \ ortho_srcdir=$(ortho_srcdir) GNAT_FLAGS="$(GNAT_FLAGS)" \ ortho_exec=ghdl1-$(BE) all -#ortho_nodes.ads: ortho_nodes.tmp -# if cmp -s $@ $< ; then \ -# rm -f $<; \ -# else \ -# mv $< $@; \ -# fi - -#BE_Case:=$(shell echo $(BE) | sed -e "h" -e "s/.\(.*\)/\1/" -e "x" -e "s/\(.\).*/\1/" -e "y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/" -e 'G' -e 's/\n//" - -#BE_Case:=$(shell echo $(BE) | sed -e "s/debug/Debug/" -e "s/regen/Regen/") - -#ortho_nodes.tmp: force -# echo "with Ortho_$(BE_Case);" > $@ -# echo "" >> $@ -# echo "package Ortho_Nodes renames Ortho_$(BE_Case);" >> $@ - -#ortho_$(BE)_front.ads: Makefile -# echo "with Ortho_Front;" > $@ -# echo "package Ortho_$(BE_Case)_Front renames Ortho_Front;" >> $@ - all: [ -d lib ] || mkdir lib $(MAKE) -f $(ortho_srcdir)/gcc/Makefile \ |