diff options
Diffstat (limited to 'ortho/gcc')
-rw-r--r-- | ortho/gcc/Makefile | 86 | ||||
-rw-r--r-- | ortho/gcc/Makefile.conf.linux | 4 | ||||
-rw-r--r-- | ortho/gcc/lang.opt | 96 | ||||
-rw-r--r-- | ortho/gcc/ortho-lang.c | 2191 | ||||
-rw-r--r-- | ortho/gcc/ortho_gcc-main.adb | 42 | ||||
-rw-r--r-- | ortho/gcc/ortho_gcc-main.ads | 1 | ||||
-rw-r--r-- | ortho/gcc/ortho_gcc.adb | 121 | ||||
-rw-r--r-- | ortho/gcc/ortho_gcc.ads | 701 | ||||
-rw-r--r-- | ortho/gcc/ortho_gcc.private.ads | 269 | ||||
-rw-r--r-- | ortho/gcc/ortho_gcc_front.ads | 2 | ||||
-rw-r--r-- | ortho/gcc/ortho_ident.adb | 56 | ||||
-rw-r--r-- | ortho/gcc/ortho_ident.ads | 30 | ||||
-rw-r--r-- | ortho/gcc/ortho_nodes.ads | 3 |
13 files changed, 0 insertions, 3602 deletions
diff --git a/ortho/gcc/Makefile b/ortho/gcc/Makefile deleted file mode 100644 index 5aafb31c7..000000000 --- a/ortho/gcc/Makefile +++ /dev/null @@ -1,86 +0,0 @@ -ortho_srcdir=.. -orthobe_srcdir=$(ortho_srcdir)/gcc -agcc_objdir=. -agcc_srcdir=$(ortho_srcdir)/gcc -SED=sed -BE=gcc -GNATMAKE=gnatmake -CC=gcc -CXX=g++ -COMPILER=$(CXX) -LINKER=$(CXX) - -# Modify AGCC_GCCSRC_DIR and AGCC_GCCOBJ_DIR for your environment -AGCC_GCCSRC_DIR:=$(HOME)/Projects/gcc4.9.2/source/gcc-4.9.2/ -AGCC_GCCOBJ_DIR:=$(HOME)/Projects/gcc4.9.2/build/ - -# Supplied by main GCC Makefile, copied here for compatibility with same -GMPLIBS = -L$(AGCC_GCCOBJ_DIR)./gmp/.libs -L$(AGCC_GCCOBJ_DIR)./mpfr/.libs \ - -L$(AGCC_GCCOBJ_DIR)./mpc/src/.libs -lmpc -lmpfr -lgmp -GMPINC = -I$(AGCC_GCCOBJ_DIR)./gmp -I$(AGCC_GCCSRC_DIR)/gmp \ - -I$(AGCC_GCCOBJ_DIR)./mpfr -I$(AGCC_GCCSRC_DIR)/mpfr \ - -I$(AGCC_GCCSRC_DIR)/mpc/src - -HOST_LIBS = -ZLIB=-lz - -# Override variables in Makefile.conf for your environment --include $(orthobe_srcdir)/Makefile.conf - -all: $(ortho_exec) - -ORTHO_BASENAME=ortho_gcc -include $(ortho_srcdir)/Makefile.inc - -AGCC_INC_FLAGS=-I$(AGCC_GCCOBJ_DIR)/gcc -I$(AGCC_GCCSRC_DIR)/include \ - -I$(AGCC_GCCSRC_DIR)/gcc -I$(AGCC_GCCSRC_DIR)/gcc/config \ - -I$(AGCC_GCCSRC_DIR)/libcpp/include $(GMPINC) -AGCC_CFLAGS=-g -Wall -DIN_GCC $(AGCC_INC_FLAGS) - -ortho-lang.o: $(agcc_srcdir)/ortho-lang.c \ - $(AGCC_GCCOBJ_DIR)gcc/gtype-vhdl.h \ - $(AGCC_GCCOBJ_DIR)gcc/gt-vhdl-ortho-lang.h - $(COMPILER) -c -o $@ $< $(AGCC_CFLAGS) $(INCLUDES) - -AGCC_LOCAL_OBJS=ortho-lang.o - -AGCC_DEPS := $(AGCC_LOCAL_OBJS) -AGCC_OBJS := $(AGCC_LOCAL_OBJS) \ - $(AGCC_GCCOBJ_DIR)gcc/attribs.o \ - $(AGCC_GCCOBJ_DIR)libcpp/libcpp.a \ - $(AGCC_GCCOBJ_DIR)libiberty/libiberty.a - -LIBBACKTRACE = $(AGCC_GCCOBJ_DIR)/libbacktrace/.libs/libbacktrace.a -LIBDECNUMBER = $(AGCC_GCCOBJ_DIR)/libdecnumber/libdecnumber.a -LIBIBERTY = $(AGCC_GCCOBJ_DIR)/libiberty/libiberty.a -CPPLIB= # Not needed for GHDL - -BACKEND = $(AGCC_GCCOBJ_DIR)/gcc/libbackend.a \ - $(AGCC_GCCOBJ_DIR)/gcc/libcommon-target.a - -BACKENDLIBS = $(CLOOGLIBS) $(GMPLIBS) $(PLUGINLIBS) $(HOST_LIBS) \ - $(ZLIB) -LIBS = $(AGCC_GCCOBJ_DIR)/gcc/libcommon.a \ - $(CPPLIB) $(LIBINTL) $(LIBICONV) $(LIBBACKTRACE) \ - $(LIBIBERTY) $(LIBDECNUMBER) $(HOST_LIBS) - -$(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 --LINK=$(LINKER) $(AGCC_OBJS) \ - $(BACKEND) $(LIBS) $(BACKENDLIBS) - -agcc-clean: force - $(RM) -f $(agcc_objdir)/*.o - $(RM) -f $(agcc_srcdir)/*~ - -clean: agcc-clean - $(RM) -f *.o *.ali ortho_nodes-main - $(RM) b~*.ad? *~ - -distclean: clean agcc-clean - - -force: - -.PHONY: force all clean agcc-clean diff --git a/ortho/gcc/Makefile.conf.linux b/ortho/gcc/Makefile.conf.linux deleted file mode 100644 index 00ea91728..000000000 --- a/ortho/gcc/Makefile.conf.linux +++ /dev/null @@ -1,4 +0,0 @@ -# Example Makefile.conf -# Copy this file to Makefile.conf and edit as necessary for your platform - -HOST_LIBS = -ldl -lstdc++ diff --git a/ortho/gcc/lang.opt b/ortho/gcc/lang.opt deleted file mode 100644 index 562fbe08d..000000000 --- a/ortho/gcc/lang.opt +++ /dev/null @@ -1,96 +0,0 @@ -Language -vhdl - --std= -vhdl Joined -Select the vhdl standard - --compile-standard -vhdl -Used during compiler build to compile the std.standard package - --bootstrap -vhdl -Used during compiler build to compile std packages - --work= -vhdl Joined -Set the name of the work library - --workdir= -vhdl Joined -Set the directory of the work library - -P -vhdl JoinedOrMissing -;-P<dir> Add <dir> to the end of the vhdl library path - --elab -vhdl Separate ---elab <name> Used internally during elaboration of <name> - --anaelab -vhdl Separate ---anaelab <name> Used internally during elaboration of <name> - -; -c is a driver option for gcc. --ghdl-source is used instead. -;c -;vhdl Separate -;-c <filename> Analyze <filename> for --anaelab - -;v -;vhdl -;Verbose - --warn- -vhdl Joined ---warn-<name> Warn about <name> - --ghdl -vhdl Joined ---ghdl-<option> Pass <option> to vhdl front-end - --expect-failure -vhdl -Expect a compiler error (used for testsuite) - --no-vital-checks -vhdl -Disable VITAL checks - --vital-checks -vhdl -Enable VITAL checks - -fexplicit -vhdl -Explicit function declarations override implicit one in use - -frelaxed-rules -vhdl -Relax some LRM rules to compile vendor libraries - -fpsl -vhdl -Allow PSL asserts in comments - --no-direct-drivers -vhdl -Disable direct drivers optimization - --syn-binding -vhdl -Use synthetizer rules for default bindings - -l -vhdl Joined Separate --l<filename> Put list of files for link in <filename> - -; -C was commented out, as it is already defined for C/C++. -;C -;vhdl -;Allow any character in comments - --mb-comments -vhdl -Allow any character in comments diff --git a/ortho/gcc/ortho-lang.c b/ortho/gcc/ortho-lang.c deleted file mode 100644 index c19012e6e..000000000 --- a/ortho/gcc/ortho-lang.c +++ /dev/null @@ -1,2191 +0,0 @@ -/* GCC back-end for ortho - Copyright (C) 2002-1014 Tristan Gingold and al. - - 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. */ - -#include <stddef.h> -#include <math.h> -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "tree.h" -#include "tm_p.h" -#include "defaults.h" -#include "ggc.h" -#include "diagnostic.h" -#include "langhooks.h" -#include "langhooks-def.h" -#include "toplev.h" -#include "opts.h" -#include "options.h" -#include "real.h" -#include "tree-iterator.h" -#include "function.h" -#include "cgraph.h" -#include "target.h" -#include "convert.h" -#include "tree-pass.h" -#include "tree-dump.h" - -/* Undefine for gcc-4.8 */ -#define GCC49 - -#ifdef GCC49 - -#include "print-tree.h" -#include "stringpool.h" -#include "stor-layout.h" -#include "varasm.h" - -/* Returns the number of FIELD_DECLs in TYPE. - Copied here from expr.c in gcc4.9 as it is no longer exported by tree.h. */ - -static int -fields_length (const_tree type) -{ - tree t = TYPE_FIELDS (type); - int count = 0; - - for (; t; t = DECL_CHAIN (t)) - if (TREE_CODE (t) == FIELD_DECL) - ++count; - - return count; -} - -#else - -// adapt gcc4.9 practice to gcc4.8 functions -bool -tree_fits_uhwi_p (const_tree t) -{ - return host_integerp (t, 1); -} - -unsigned HOST_WIDE_INT -tree_to_uhwi (const_tree t) -{ - return tree_low_cst (t, 1); -} - -#endif - -/* TODO: - * remove stmt_list_stack, save in if/case/loop block - * Re-add -v (if necessary) - */ - -static tree type_for_size (unsigned int precision, int unsignedp); - -const int tree_identifier_size = sizeof (struct tree_identifier); - -struct GTY(()) binding_level -{ - /* The BIND_EXPR node for this binding. */ - tree bind; - - /* The BLOCK node for this binding. */ - tree block; - - /* If true, stack must be saved (alloca is used). */ - int save_stack; - - /* Parent binding level. */ - struct binding_level *prev; - - /* Decls in this binding. */ - tree first_decl; - tree last_decl; - - /* Blocks in this binding. */ - tree first_block; - tree last_block; -}; - -/* The current binding level. */ -static GTY(()) struct binding_level *cur_binding_level = NULL; - -/* Chain of unused binding levels. */ -static GTY(()) struct binding_level *old_binding_levels = NULL; - -/* Chain of statements currently generated. */ -static GTY(()) tree cur_stmts = NULL_TREE; - -static void -push_binding (void) -{ - struct binding_level *res; - - if (old_binding_levels == NULL) - res = ggc_alloc_binding_level (); - else - { - res = old_binding_levels; - old_binding_levels = res->prev; - } - - /* Init. */ - res->first_decl = NULL_TREE; - res->last_decl = NULL_TREE; - - res->first_block = NULL_TREE; - res->last_block = NULL_TREE; - - res->save_stack = 0; - - res->bind = make_node (BIND_EXPR); - res->block = make_node (BLOCK); - BIND_EXPR_BLOCK (res->bind) = res->block; - TREE_SIDE_EFFECTS (res->bind) = true; - TREE_TYPE (res->bind) = void_type_node; - TREE_USED (res->block) = true; - - if (cur_binding_level != NULL) - { - /* Append the block created. */ - if (cur_binding_level->first_block == NULL) - cur_binding_level->first_block = res->block; - else - BLOCK_CHAIN (cur_binding_level->last_block) = res->block; - cur_binding_level->last_block = res->block; - - BLOCK_SUPERCONTEXT (res->block) = cur_binding_level->block; - } - - res->prev = cur_binding_level; - cur_binding_level = res; -} - -static void -push_decl (tree decl) -{ - DECL_CONTEXT (decl) = current_function_decl; - - if (cur_binding_level->first_decl == NULL) - cur_binding_level->first_decl = decl; - else - TREE_CHAIN (cur_binding_level->last_decl) = decl; - cur_binding_level->last_decl = decl; -} - -static tree -pop_binding (void) -{ - tree res; - struct binding_level *cur; - - cur = cur_binding_level; - res = cur->bind; - - if (cur->save_stack) - { - tree tmp_var; - tree save; - tree save_call; - tree restore; - tree t; - - /* Create an artificial var to save the stack pointer. */ - tmp_var = build_decl (input_location, VAR_DECL, NULL, ptr_type_node); - DECL_ARTIFICIAL (tmp_var) = true; - DECL_IGNORED_P (tmp_var) = true; - TREE_USED (tmp_var) = true; - push_decl (tmp_var); - - /* Create the save stmt. */ - save_call = build_call_expr - (builtin_decl_implicit (BUILT_IN_STACK_SAVE), 0); - save = build2 (MODIFY_EXPR, ptr_type_node, tmp_var, save_call); - TREE_SIDE_EFFECTS (save) = true; - - /* Create the restore stmt. */ - restore = build_call_expr - (builtin_decl_implicit (BUILT_IN_STACK_RESTORE), 1, tmp_var); - - /* Build a try-finally block. - The statement list is the block of current statements. */ - t = build2 (TRY_FINALLY_EXPR, void_type_node, cur_stmts, NULL_TREE); - TREE_SIDE_EFFECTS (t) = true; - - /* The finally block is the restore stmt. */ - append_to_statement_list (restore, &TREE_OPERAND (t, 1)); - - /* The body of the BIND_BLOCK is the save stmt, followed by the - try block. */ - BIND_EXPR_BODY (res) = NULL_TREE; - append_to_statement_list (save, &BIND_EXPR_BODY (res)); - append_to_statement_list (t, &BIND_EXPR_BODY (res)); - } - else - { - /* The body of the BIND_BLOCK is the statement block. */ - BIND_EXPR_BODY (res) = cur_stmts; - } - BIND_EXPR_VARS (res) = cur->first_decl; - - BLOCK_SUBBLOCKS (cur->block) = cur->first_block; - BLOCK_VARS (cur->block) = cur->first_decl; - - cur_binding_level = cur->prev; - cur->prev = old_binding_levels; - old_binding_levels = cur; - - return res; -} - -// naive conversion to new vec API following the wiki at -// http://gcc.gnu.org/wiki/cxx-conversion/cxx-vec -// see also push_stmts, pop_stmts -static vec <tree> stmt_list_stack = vec<tree>(); - -static void -push_stmts (tree stmts) -{ - stmt_list_stack.safe_push(cur_stmts); - cur_stmts = stmts; -} - -static void -pop_stmts (void) -{ - cur_stmts = stmt_list_stack.pop(); -} - -static void -append_stmt (tree stmt) -{ - if (!EXPR_HAS_LOCATION (stmt)) - SET_EXPR_LOCATION (stmt, input_location); - TREE_SIDE_EFFECTS (stmt) = true; - append_to_statement_list (stmt, &cur_stmts); -} - -static GTY(()) tree top; - -static GTY(()) tree stack_alloc_function_ptr; - -static bool -global_bindings_p (void) -{ - return cur_binding_level->prev == NULL; -} - -static tree -pushdecl (tree t) -{ - //gcc_unreachable (); - // gcc4.8.2 we get here from build_common_builtin_nodes () call in ortho_init - return t; -} - -static tree -builtin_function (const char *name, - tree type, - int function_code, - enum built_in_class decl_class, - const char *library_name, - tree attrs ATTRIBUTE_UNUSED); - -REAL_VALUE_TYPE fp_const_p5; /* 0.5 */ -REAL_VALUE_TYPE fp_const_m_p5; /* -0.5 */ -REAL_VALUE_TYPE fp_const_zero; /* 0.0 */ - -static bool -ortho_init (void) -{ - tree n; - - input_location = BUILTINS_LOCATION; - - /* Create a global binding. */ - push_binding (); - - build_common_tree_nodes (0, 0); - - n = build_decl (input_location, - TYPE_DECL, get_identifier ("int"), integer_type_node); - push_decl (n); - n = build_decl (input_location, - TYPE_DECL, get_identifier ("char"), char_type_node); - push_decl (n); - - /* Create alloca builtin. */ - { - tree args_type = tree_cons (NULL_TREE, size_type_node, void_list_node); - tree func_type = build_function_type (ptr_type_node, args_type); - - set_builtin_decl - (BUILT_IN_ALLOCA, - builtin_function - ("__builtin_alloca", func_type, - BUILT_IN_ALLOCA, BUILT_IN_NORMAL, NULL, NULL_TREE), true); - - stack_alloc_function_ptr = build1 - (ADDR_EXPR, - build_pointer_type (func_type), - builtin_decl_implicit (BUILT_IN_ALLOCA)); - } - - { - tree ptr_ftype = build_function_type (ptr_type_node, NULL_TREE); - - set_builtin_decl - (BUILT_IN_STACK_SAVE, - builtin_function - ("__builtin_stack_save", ptr_ftype, - BUILT_IN_STACK_SAVE, BUILT_IN_NORMAL, NULL, NULL_TREE), true); - } - - { - tree ftype_ptr; - - ftype_ptr = build_function_type - (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, NULL_TREE)); - - set_builtin_decl - (BUILT_IN_STACK_RESTORE, - builtin_function - ("__builtin_stack_restore", ftype_ptr, - BUILT_IN_STACK_RESTORE, BUILT_IN_NORMAL, NULL, NULL_TREE), true); - } - { - REAL_VALUE_TYPE v; - - REAL_VALUE_FROM_INT (v, 1, 0, DFmode); - real_ldexp (&fp_const_p5, &v, -1); - - REAL_VALUE_FROM_INT (v, -1, -1, DFmode); - real_ldexp (&fp_const_m_p5, &v, -1); - - REAL_VALUE_FROM_INT (fp_const_zero, 0, 0, DFmode); - } - - 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. - - return true; -} - -static void -ortho_finish (void) -{ -} - -static unsigned int -ortho_option_lang_mask (void) -{ - return CL_vhdl; -} - -static bool -ortho_post_options (const char **pfilename) -{ - if (*pfilename == NULL || strcmp (*pfilename, "-") == 0) - *pfilename = "*stdin*"; - - /* Default hook. */ - lhd_post_options (pfilename); - - // This stops compile failures writing debug information when both -g and -O2 - // (or -O1, -O3 or -Os) options are present. - // Should really make it conditional on specific options - // FIXME : re-evaluate if this is still necessary with newer gccrevisions - dwarf_strict = 1; - - /* Run the back-end. */ - return false; -} - -extern "C" int lang_handle_option (const char *opt, const char *arg); - -static bool -ortho_handle_option (size_t code, const char *arg, - int value ATTRIBUTE_UNUSED, - int kind ATTRIBUTE_UNUSED, - location_t loc ATTRIBUTE_UNUSED, - const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED) -{ - const char *opt; - - opt = cl_options[code].opt_text; - - switch (code) - { - case OPT__elab: - case OPT_l: - case OPT_c: - case OPT__anaelab: - /* Only a few options have a real arguments. */ - return lang_handle_option (opt, arg) != 0; - default: - /* The other options must have a joint argument. */ - if (arg != NULL) - { - size_t len1; - size_t len2; - char *nopt; - - len1 = strlen (opt); - len2 = strlen (arg); - nopt = (char *) alloca (len1 + len2 + 1); - memcpy (nopt, opt, len1); - memcpy (nopt + len1, arg, len2); - nopt[len1 + len2] = 0; - opt = nopt; - } - return lang_handle_option (opt, NULL) != 0; - } -} - -extern "C" int lang_parse_file (const char *filename); - -static void -ortho_parse_file (void) -{ - const char *filename; - - if (num_in_fnames == 0) - filename = NULL; - else - filename = in_fnames[0]; - - linemap_add (line_table, LC_ENTER, 0, filename ? filename :"*no-file*", 1); - input_location = linemap_line_start (line_table, 1, 252); - - if (!lang_parse_file (filename)) - errorcount++; - linemap_add (line_table, LC_LEAVE, 0, NULL, 1); -} - -/* Called by the back-end or by the front-end when the address of EXP - must be taken. - This function should found the base object (if any), and mark it as - addressable (via TREE_ADDRESSABLE). It may emit a warning if this - object cannot be addressable (front-end restriction). - Returns TRUE in case of success, FALSE in case of failure. - Note that the status is never checked by the back-end. */ -static bool -ortho_mark_addressable (tree exp) -{ - tree n; - - n = exp; - - while (1) - switch (TREE_CODE (n)) - { - case VAR_DECL: - case CONST_DECL: - case PARM_DECL: - case RESULT_DECL: - TREE_ADDRESSABLE (n) = true; - return true; - - case COMPONENT_REF: - case ARRAY_REF: - case ARRAY_RANGE_REF: - n = TREE_OPERAND (n, 0); - break; - - case FUNCTION_DECL: - case CONSTRUCTOR: - TREE_ADDRESSABLE (n) = true; - return true; - - case INDIRECT_REF: - return true; - - default: - gcc_unreachable (); - } -} - -static tree -ortho_truthvalue_conversion (tree expr) -{ - tree expr_type; - tree t; - tree f; - - expr_type = TREE_TYPE (expr); - if (TREE_CODE (expr_type) != BOOLEAN_TYPE) - { - t = integer_one_node; - f = integer_zero_node; - } - else - { - f = TYPE_MIN_VALUE (expr_type); - t = TYPE_MAX_VALUE (expr_type); - } - - - switch (TREE_CODE (expr)) - { - case EQ_EXPR: - case NE_EXPR: - case LE_EXPR: - case GE_EXPR: - case LT_EXPR: - case GT_EXPR: - case TRUTH_ANDIF_EXPR: - case TRUTH_ORIF_EXPR: - case TRUTH_AND_EXPR: - case TRUTH_OR_EXPR: - case ERROR_MARK: - return expr; - - case INTEGER_CST: - /* Not 0 is true. */ - return integer_zerop (expr) ? f : t; - - case REAL_CST: - return real_zerop (expr) ? f : t; - - default: - gcc_unreachable (); - } -} - -/* The following function has been copied and modified from c-convert.c. */ - -/* Change of width--truncation and extension of integers or reals-- - is represented with NOP_EXPR. Proper functioning of many things - assumes that no other conversions can be NOP_EXPRs. - - Conversion between integer and pointer is represented with CONVERT_EXPR. - Converting integer to real uses FLOAT_EXPR - and real to integer uses FIX_TRUNC_EXPR. - - Here is a list of all the functions that assume that widening and - narrowing is always done with a NOP_EXPR: - In convert.c, convert_to_integer. - In c-typeck.c, build_binary_op (boolean ops), and - c_common_truthvalue_conversion. - In expr.c: expand_expr, for operands of a MULT_EXPR. - In fold-const.c: fold. - In tree.c: get_narrower and get_unwidened. */ - -/* Subroutines of `convert'. */ - - - -/* Create an expression whose value is that of EXPR, - converted to type TYPE. The TREE_TYPE of the value - is always TYPE. This function implements all reasonable - conversions; callers should filter out those that are - not permitted by the language being compiled. */ - -tree -convert (tree type, tree expr) -{ - tree e = expr; - enum tree_code code = TREE_CODE (type); - const char *invalid_conv_diag; - - if (type == error_mark_node - || expr == error_mark_node - || TREE_TYPE (expr) == error_mark_node) - return error_mark_node; - - if ((invalid_conv_diag - = targetm.invalid_conversion (TREE_TYPE (expr), type))) - { - error (invalid_conv_diag); - return error_mark_node; - } - - if (type == TREE_TYPE (expr)) - return expr; - - if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr))) - return fold_build1 (NOP_EXPR, type, expr); - if (TREE_CODE (TREE_TYPE (expr)) == ERROR_MARK) - return error_mark_node; - if (TREE_CODE (TREE_TYPE (expr)) == VOID_TYPE || code == VOID_TYPE) - { - gcc_unreachable (); - } - if (code == INTEGER_TYPE || code == ENUMERAL_TYPE) - return fold (convert_to_integer (type, e)); - if (code == BOOLEAN_TYPE) - { - tree t = ortho_truthvalue_conversion (expr); - if (TREE_CODE (t) == ERROR_MARK) - return t; - - /* If it returns a NOP_EXPR, we must fold it here to avoid - infinite recursion between fold () and convert (). */ - if (TREE_CODE (t) == NOP_EXPR) - return fold_build1 (NOP_EXPR, type, TREE_OPERAND (t, 0)); - else - return fold_build1 (NOP_EXPR, type, t); - } - if (code == POINTER_TYPE || code == REFERENCE_TYPE) - return fold (convert_to_pointer (type, e)); - if (code == REAL_TYPE) - return fold (convert_to_real (type, e)); - - gcc_unreachable (); -} - -/* Return a definition for a builtin function named NAME and whose data type - is TYPE. TYPE should be a function type with argument types. - FUNCTION_CODE tells later passes how to compile calls to this function. - See tree.h for its possible values. - - If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, - the name to be called if we can't opencode the function. If - ATTRS is nonzero, use that for the function's attribute list. */ -static tree -builtin_function (const char *name, - tree type, - int function_code, - enum built_in_class decl_class, - const char *library_name, - tree attrs ATTRIBUTE_UNUSED) -{ - tree decl = build_decl (input_location, - FUNCTION_DECL, get_identifier (name), type); - DECL_EXTERNAL (decl) = 1; - TREE_PUBLIC (decl) = 1; - if (library_name) - SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name)); - make_decl_rtl (decl); - DECL_BUILT_IN_CLASS (decl) = decl_class; - DECL_FUNCTION_CODE (decl) = (built_in_function) function_code; - DECL_SOURCE_LOCATION (decl) = input_location; - return decl; -} - -#ifndef MAX_BITS_PER_WORD -#define MAX_BITS_PER_WORD BITS_PER_WORD -#endif - -/* This variable keeps a table for types for each precision so that we only - allocate each of them once. Signed and unsigned types are kept separate. - */ -static GTY(()) tree signed_and_unsigned_types[MAX_BITS_PER_WORD + 1][2]; - -/* Return an integer type with the number of bits of precision given by - PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise - it is a signed type. */ -static tree -type_for_size (unsigned int precision, int unsignedp) -{ - tree t; - - if (precision <= MAX_BITS_PER_WORD - && signed_and_unsigned_types[precision][unsignedp] != NULL_TREE) - return signed_and_unsigned_types[precision][unsignedp]; - - if (unsignedp) - t = make_unsigned_type (precision); - else - t = make_signed_type (precision); - - if (precision <= MAX_BITS_PER_WORD) - signed_and_unsigned_types[precision][unsignedp] = t; - - return t; -} - -/* Return a data type that has machine mode MODE. UNSIGNEDP selects - an unsigned type; otherwise a signed type is returned. */ -static tree -type_for_mode (enum machine_mode mode, int unsignedp) -{ - if (SCALAR_INT_MODE_P (mode)) - return type_for_size (GET_MODE_BITSIZE (mode), unsignedp); - - if (mode == TYPE_MODE (void_type_node)) - return void_type_node; - - if (mode == TYPE_MODE (float_type_node)) - return float_type_node; - - if (mode == TYPE_MODE (double_type_node)) - return double_type_node; - - if (mode == TYPE_MODE (long_double_type_node)) - return long_double_type_node; - - return NULL_TREE; -} - -#undef LANG_HOOKS_NAME -#define LANG_HOOKS_NAME "vhdl" -#undef LANG_HOOKS_IDENTIFIER_SIZE -#define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier) -#undef LANG_HOOKS_INIT -#define LANG_HOOKS_INIT ortho_init -#undef LANG_HOOKS_FINISH -#define LANG_HOOKS_FINISH ortho_finish -#undef LANG_HOOKS_OPTION_LANG_MASK -#define LANG_HOOKS_OPTION_LANG_MASK ortho_option_lang_mask -#undef LANG_HOOKS_HANDLE_OPTION -#define LANG_HOOKS_HANDLE_OPTION ortho_handle_option -#undef LANG_HOOKS_POST_OPTIONS -#define LANG_HOOKS_POST_OPTIONS ortho_post_options -#undef LANG_HOOKS_HONOR_READONLY -#define LANG_HOOKS_HONOR_READONLY true -#undef LANG_HOOKS_MARK_ADDRESSABLE -#define LANG_HOOKS_MARK_ADDRESSABLE ortho_mark_addressable -#undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION -#define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION ortho_expand_function - -#undef LANG_HOOKS_TYPE_FOR_MODE -#define LANG_HOOKS_TYPE_FOR_MODE type_for_mode -#undef LANG_HOOKS_TYPE_FOR_SIZE -#define LANG_HOOKS_TYPE_FOR_SIZE type_for_size -#undef LANG_HOOKS_SIGNED_TYPE -#define LANG_HOOKS_SIGNED_TYPE signed_type -#undef LANG_HOOKS_UNSIGNED_TYPE -#define LANG_HOOKS_UNSIGNED_TYPE unsigned_type -#undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE -#define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE signed_or_unsigned_type -#undef LANG_HOOKS_PARSE_FILE -#define LANG_HOOKS_PARSE_FILE ortho_parse_file - -#define pushlevel lhd_do_nothing_i -#define poplevel lhd_do_nothing_iii_return_null_tree -#define set_block lhd_do_nothing_t -#undef LANG_HOOKS_GETDECLS -#define LANG_HOOKS_GETDECLS lhd_return_null_tree_v - -struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; - -union GTY((desc ("0"), - chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN (&%h.generic)) : NULL"))) - lang_tree_node -{ - union tree_node GTY((tag ("0"), - desc ("tree_node_structure (&%h)"))) generic; -}; - -/* GHDL does not use the lang_decl and lang_type. - - FIXME: the variable_size annotation here is needed because these types are - variable-sized in some other front-ends. Due to gengtype deficiency, the - GTY options of such types have to agree across all front-ends. */ - -struct GTY((variable_size)) lang_type { char dummy; }; -struct GTY((variable_size)) lang_decl { char dummy; }; - -struct GTY(()) language_function -{ - char dummy; -}; - - -extern "C" { - -struct GTY(()) chain_constr_type -{ - tree first; - tree last; -}; - -static void -chain_init (struct chain_constr_type *constr) -{ - constr->first = NULL_TREE; - constr->last = NULL_TREE; -} - -static void -chain_append (struct chain_constr_type *constr, tree el) -{ - if (constr->first == NULL_TREE) - { - gcc_assert (constr->last == NULL_TREE); - constr->first = el; - } - else - TREE_CHAIN (constr->last) = el; - constr->last = el; -} - -struct GTY(()) list_constr_type -{ - tree first; - tree last; -}; - -static void -list_init (struct list_constr_type *constr) -{ - constr->first = NULL_TREE; - constr->last = NULL_TREE; -} - -static void -ortho_list_append (struct list_constr_type *constr, tree el) -{ - tree res; - - res = tree_cons (NULL_TREE, el, NULL_TREE); - if (constr->first == NULL_TREE) - constr->first = res; - else - TREE_CHAIN (constr->last) = res; - constr->last = res; -} - -enum ON_op_kind { - /* Not an operation; invalid. */ - ON_Nil, - - /* Dyadic operations. */ - ON_Add_Ov, - ON_Sub_Ov, - ON_Mul_Ov, - ON_Div_Ov, - ON_Rem_Ov, - ON_Mod_Ov, - - /* Binary operations. */ - ON_And, - ON_Or, - ON_Xor, - - /* Monadic operations. */ - ON_Not, - ON_Neg_Ov, - ON_Abs_Ov, - - /* Comparaisons */ - ON_Eq, - ON_Neq, - ON_Le, - ON_Lt, - ON_Ge, - ON_Gt, - - ON_LAST -}; - -static enum tree_code ON_op_to_TREE_CODE[ON_LAST] = { - ERROR_MARK, - - PLUS_EXPR, - MINUS_EXPR, - MULT_EXPR, - ERROR_MARK, - TRUNC_MOD_EXPR, - FLOOR_MOD_EXPR, - - BIT_AND_EXPR, - BIT_IOR_EXPR, - BIT_XOR_EXPR, - - BIT_NOT_EXPR, - NEGATE_EXPR, - ABS_EXPR, - - EQ_EXPR, - NE_EXPR, - LE_EXPR, - LT_EXPR, - GE_EXPR, - GT_EXPR, -}; - -tree -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)); - - switch (kind) - { - case ON_Div_Ov: - if (TREE_CODE (left_type) == REAL_TYPE) - code = RDIV_EXPR; - else - code = TRUNC_DIV_EXPR; - break; - default: - code = ON_op_to_TREE_CODE[kind]; - break; - } - return build2 (code, left_type, left, 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); -} - -tree -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); -} - -tree -new_convert_ov (tree val, tree rtype) -{ - tree val_type; - enum tree_code val_code; - enum tree_code rtype_code; - enum tree_code code; - - val_type = TREE_TYPE (val); - if (val_type == rtype) - return val; - - /* FIXME: check conversions. */ - val_code = TREE_CODE (val_type); - rtype_code = TREE_CODE (rtype); - if (val_code == POINTER_TYPE && rtype_code == POINTER_TYPE) - code = NOP_EXPR; - else if (val_code == INTEGER_TYPE && rtype_code == INTEGER_TYPE) - code = CONVERT_EXPR; - else if (val_code == REAL_TYPE && rtype_code == INTEGER_TYPE) - { - /* REAL to INTEGER - Gcc only handles FIX_TRUNC_EXPR, but we need rounding. */ - tree m_p5; - tree p5; - tree zero; - tree saved; - tree comp; - tree adj; - tree res; - - m_p5 = build_real (val_type, fp_const_m_p5); - p5 = build_real (val_type, fp_const_p5); - zero = build_real (val_type, fp_const_zero); - saved = save_expr (val); - comp = build2 (GE_EXPR, integer_type_node, saved, zero); - /* FIXME: instead of res = res + (comp ? .5 : -.5) - do: res = res (comp ? + : -) .5 */ - adj = build3 (COND_EXPR, val_type, comp, p5, m_p5); - res = build2 (PLUS_EXPR, val_type, saved, adj); - res = build1 (FIX_TRUNC_EXPR, rtype, res); - return res; - } - else if (val_code == INTEGER_TYPE && rtype_code == ENUMERAL_TYPE) - code = CONVERT_EXPR; - else if (val_code == ENUMERAL_TYPE && rtype_code == INTEGER_TYPE) - code = CONVERT_EXPR; - else if (val_code == INTEGER_TYPE && rtype_code == REAL_TYPE) - code = FLOAT_EXPR; - else if (val_code == BOOLEAN_TYPE && rtype_code == BOOLEAN_TYPE) - code = NOP_EXPR; - else if (val_code == BOOLEAN_TYPE && rtype_code == INTEGER_TYPE) - code = CONVERT_EXPR; - else if (val_code == INTEGER_TYPE && rtype_code == BOOLEAN_TYPE) - code = NOP_EXPR; - else if (val_code == REAL_TYPE && rtype_code == REAL_TYPE) - code = NOP_EXPR; - else - gcc_unreachable (); - - return build1 (code, rtype, val); -} - -tree -new_alloca (tree rtype, tree size) -{ - tree res; - - /* Must save stack except when at function level. */ - if (cur_binding_level->prev != NULL - && cur_binding_level->prev->prev != NULL) - cur_binding_level->save_stack = 1; - - res = build_call_nary (ptr_type_node, stack_alloc_function_ptr, - 1, fold_convert (size_type_node, size)); - return fold_convert (rtype, res); -} - -tree -new_signed_literal (tree ltype, long long value) -{ - tree res; - HOST_WIDE_INT lo; - HOST_WIDE_INT hi; - - lo = value; - hi = (value >> 1) >> (8 * sizeof (HOST_WIDE_INT) - 1); - res = build_int_cst_wide (ltype, lo, hi); - return res; -} - -tree -new_unsigned_literal (tree ltype, unsigned long long value) -{ - tree res; - unsigned HOST_WIDE_INT lo; - unsigned HOST_WIDE_INT hi; - - lo = value; - hi = (value >> 1) >> (8 * sizeof (HOST_WIDE_INT) - 1); - res = build_int_cst_wide (ltype, lo, hi); - return res; -} - -tree -new_null_access (tree ltype) -{ - tree res; - - res = build_int_cst_wide (ltype, 0, 0); - return res; -} - -tree -new_float_literal (tree ltype, double value) -{ - signed long long s; - double frac; - int ex; - REAL_VALUE_TYPE r_sign; - REAL_VALUE_TYPE r_exp; - REAL_VALUE_TYPE r; - tree res; - HOST_WIDE_INT lo; - HOST_WIDE_INT hi; - - frac = frexp (value, &ex); - - s = ldexp (frac, 60); - lo = s; - hi = (s >> 1) >> (8 * sizeof (HOST_WIDE_INT) - 1); - res = build_int_cst_wide (long_integer_type_node, lo, hi); - REAL_VALUE_FROM_INT (r_sign, lo, hi, DFmode); - real_2expN (&r_exp, ex - 60, DFmode); - real_arithmetic (&r, MULT_EXPR, &r_sign, &r_exp); - res = build_real (ltype, r); - return res; -} - -struct GTY(()) o_element_list -{ - tree res; - struct chain_constr_type chain; -}; - -void -new_uncomplete_record_type (tree *res) -{ - *res = make_node (RECORD_TYPE); -} - -void -start_record_type (struct o_element_list *elements) -{ - elements->res = make_node (RECORD_TYPE); - chain_init (&elements->chain); -} - -void -start_uncomplete_record_type (tree res, struct o_element_list *elements) -{ - elements->res = res; - chain_init (&elements->chain); -} - -static void -new_record_union_field (struct o_element_list *list, - tree *el, - tree ident, - tree etype) -{ - tree res; - - res = build_decl (input_location, - FIELD_DECL, ident, etype); - DECL_CONTEXT (res) = list->res; - chain_append (&list->chain, res); - *el = res; -} - -void -new_record_field (struct o_element_list *list, - tree *el, - tree ident, - tree etype) -{ - return new_record_union_field (list, el, ident, etype); -} - -void -finish_record_type (struct o_element_list *elements, tree *res) -{ - TYPE_FIELDS (elements->res) = elements->chain.first; - layout_type (elements->res); - *res = elements->res; - - if (TYPE_NAME (elements->res) != NULL_TREE) - { - /* The type was completed. */ - rest_of_type_compilation (elements->res, 1); - } -} - -void -start_union_type (struct o_element_list *elements) -{ - elements->res = make_node (UNION_TYPE); - chain_init (&elements->chain); -} - -void -new_union_field (struct o_element_list *elements, - tree *el, - tree ident, - tree etype) -{ - return new_record_union_field (elements, el, ident, etype); -} - -void -finish_union_type (struct o_element_list *elements, tree *res) -{ - TYPE_FIELDS (elements->res) = elements->chain.first; - layout_type (elements->res); - *res = elements->res; -} - -tree -new_unsigned_type (int size) -{ - return make_unsigned_type (size); -} - -tree -new_signed_type (int size) -{ - return make_signed_type (size); -} - -tree -new_float_type (void) -{ - tree res; - - res = make_node (REAL_TYPE); - TYPE_PRECISION (res) = DOUBLE_TYPE_SIZE; - layout_type (res); - return res; -} - -tree -new_access_type (tree dtype) -{ - tree res; - - if (dtype == NULL_TREE) - { - res = make_node (POINTER_TYPE); - TREE_TYPE (res) = NULL_TREE; - /* Seems necessary. */ - SET_TYPE_MODE (res, Pmode); - layout_type (res); - return res; - } - else - return build_pointer_type (dtype); -} - -void -finish_access_type (tree atype, tree dtype) -{ - gcc_assert (TREE_CODE (atype) == POINTER_TYPE - && TREE_TYPE (atype) == NULL_TREE); - - TREE_TYPE (atype) = dtype; -} - -tree -new_array_type (tree el_type, tree index_type) -{ - return build_array_type (el_type, index_type); -} - - -tree -new_constrained_array_type (tree atype, tree length) -{ - tree range_type; - tree index_type; - tree len; - tree one; - tree res; - - index_type = TYPE_DOMAIN (atype); - if (integer_zerop (length)) - { - /* Handle null array, by creating a one-length array... */ - len = size_zero_node; - } - else - { - one = build_int_cstu (index_type, 1); - len = build2 (MINUS_EXPR, index_type, length, one); - len = fold (len); - } - - range_type = build_range_type (index_type, size_zero_node, len); - res = build_array_type (TREE_TYPE (atype), range_type); - - /* Constrained arrays are *always* a subtype of its array type. - Just copy alias set. */ - TYPE_ALIAS_SET (res) = get_alias_set (atype); - return res; -} - -void -new_boolean_type (tree *res, - tree false_id ATTRIBUTE_UNUSED, tree *false_e, - tree true_id ATTRIBUTE_UNUSED, tree *true_e) -{ - *res = make_node (BOOLEAN_TYPE); - TYPE_PRECISION (*res) = 1; - fixup_unsigned_type (*res); - *false_e = TYPE_MIN_VALUE (*res); - *true_e = TYPE_MAX_VALUE (*res); -} - -struct o_enum_list -{ - tree res; - struct chain_constr_type chain; - int num; - int size; -}; - -void -start_enum_type (struct o_enum_list *list, int size) -{ - list->res = make_node (ENUMERAL_TYPE); - // as of gcc4.8, TYPE_PRECISION of 0 is rigorously enforced! - TYPE_PRECISION(list->res) = size; - chain_init (&list->chain); - list->num = 0; - list->size = size; -} - -void -new_enum_literal (struct o_enum_list *list, tree ident, tree *res) -{ - *res = build_int_cstu (list->res, (HOST_WIDE_INT)(list->num)); - chain_append (&list->chain, tree_cons (ident, *res, NULL_TREE)); - list->num++; -} - -void -finish_enum_type (struct o_enum_list *list, tree *res) -{ - *res = list->res; - TYPE_VALUES (*res) = list->chain.first; - TYPE_UNSIGNED (*res) = 1; - TYPE_PRECISION (*res) = list->size; - set_min_and_max_values_for_integral_type (*res, list->size, 1); - layout_type (*res); -} - -struct GTY(()) o_record_aggr_list -{ - /* Type of the record. */ - tree atype; - /* Type of the next field to be added. */ - tree field; - /* Vector of elements. */ - // VEC(constructor_elt,gc) *elts; - vec<constructor_elt,va_gc> *elts; -}; - -void -start_record_aggr (struct o_record_aggr_list *list, tree atype) -{ - list->atype = atype; - list->field = TYPE_FIELDS (atype); - //list->elts = VEC_alloc (constructor_elt, gc, fields_length (atype)); - vec_alloc(list->elts, fields_length (atype)); -} - -void -new_record_aggr_el (struct o_record_aggr_list *list, tree value) -{ - CONSTRUCTOR_APPEND_ELT (list->elts, list->field, value); - list->field = TREE_CHAIN (list->field); -} - -void -finish_record_aggr (struct o_record_aggr_list *list, tree *res) -{ - *res = build_constructor (list->atype, list->elts); -} - -struct GTY(()) o_array_aggr_list -{ - tree atype; - /* Vector of elements. */ - vec<constructor_elt,va_gc> *elts; -}; - -void -start_array_aggr (struct o_array_aggr_list *list, tree atype) -{ - tree nelts; - unsigned HOST_WIDE_INT n; - - list->atype = atype; - list->elts = NULL; - - nelts = array_type_nelts (atype); - gcc_assert (nelts != NULL_TREE && tree_fits_uhwi_p (nelts)); - - n = tree_to_uhwi (nelts) + 1; - vec_alloc(list->elts, n); -} - -void -new_array_aggr_el (struct o_array_aggr_list *list, tree value) -{ - CONSTRUCTOR_APPEND_ELT (list->elts, NULL_TREE, value); -} - -void -finish_array_aggr (struct o_array_aggr_list *list, tree *res) -{ - *res = build_constructor (list->atype, list->elts); -} - - -tree -new_union_aggr (tree atype, tree field, tree value) -{ - tree res; - - res = build_constructor_single (atype, field, value); - TREE_CONSTANT (res) = 1; - return res; -} - -tree -new_indexed_element (tree arr, tree index) -{ - ortho_mark_addressable (arr); - return build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (arr)), - arr, index, NULL_TREE, NULL_TREE); -} - -tree -new_slice (tree arr, tree res_type, tree index) -{ -#if 0 - tree res; - tree el_ptr_type; - tree el_type; - tree res_ptr_type; -#endif - - /* *((RES_TYPE *)(&ARR[INDEX])) - convert ARR to a pointer, add index, and reconvert to array ? */ - gcc_assert (TREE_CODE (res_type) == ARRAY_TYPE); - - ortho_mark_addressable (arr); - return build4 (ARRAY_RANGE_REF, res_type, arr, index, NULL_TREE, NULL_TREE); -#if 0 - el_type = TREE_TYPE (TREE_TYPE (arr)); - el_ptr_type = build_pointer_type (el_type); - - res = build4 (ARRAY_REF, el_type, arr, index, NULL_TREE, NULL_TREE); - res = build1 (ADDR_EXPR, el_ptr_type, res); - res_ptr_type = build_pointer_type (res_type); - res = build1 (NOP_EXPR, res_ptr_type, res); - res = build1 (INDIRECT_REF, res_type, res); - return res; -#endif -} - -tree -new_selected_element (tree rec, tree el) -{ - tree res; - - gcc_assert (TREE_CODE (TREE_TYPE (rec)) == RECORD_TYPE); - - res = build3 (COMPONENT_REF, TREE_TYPE (el), rec, el, NULL_TREE); - return res; -} - -tree -new_access_element (tree acc) -{ - tree acc_type; - - acc_type = TREE_TYPE (acc); - gcc_assert (TREE_CODE (acc_type) == POINTER_TYPE); - - return build1 (INDIRECT_REF, TREE_TYPE (acc_type), acc); -} - -tree -new_offsetof (tree rec_type, tree field, tree rtype) -{ - tree off; - tree bit_off; - HOST_WIDE_INT pos; - tree res; - - gcc_assert (DECL_CONTEXT (field) == rec_type); - - off = DECL_FIELD_OFFSET (field); - - /* The offset must be a constant. */ - gcc_assert (tree_fits_uhwi_p (off)); - - bit_off = DECL_FIELD_BIT_OFFSET (field); - - /* The offset must be a constant. */ - gcc_assert (tree_fits_uhwi_p (bit_off)); - - pos = TREE_INT_CST_LOW (off) - + (TREE_INT_CST_LOW (bit_off) / BITS_PER_UNIT); - res = build_int_cstu (rtype, pos); - return res; -} - -tree -new_sizeof (tree atype, tree rtype) -{ - tree size; - - size = TYPE_SIZE_UNIT (atype); - - return fold (build1 (NOP_EXPR, rtype, size)); -} - -tree -new_alignof (tree atype, tree rtype) -{ - return build_int_cstu (rtype, TYPE_ALIGN_UNIT (atype)); -} - -static tree -ortho_build_addr (tree lvalue, tree atype) -{ - tree res; - - if (TREE_CODE (lvalue) == INDIRECT_REF) - { - /* ADDR_REF(INDIRECT_REF(x)) -> x. */ - res = TREE_OPERAND (lvalue, 0); - } - else - { - tree ptr_type; - - /* &base[off] -> base+off. */ - ortho_mark_addressable (lvalue); - - if (TREE_TYPE (lvalue) != TREE_TYPE (atype)) - ptr_type = build_pointer_type (TREE_TYPE (lvalue)); - else - ptr_type = atype; - res = fold_build1 (ADDR_EXPR, ptr_type, lvalue); - } - - if (TREE_TYPE (res) != atype) - res = fold_build1 (NOP_EXPR, atype, res); - - return res; -} - -tree -new_unchecked_address (tree lvalue, tree atype) -{ - return ortho_build_addr (lvalue, atype); -} - -tree -new_address (tree lvalue, tree atype) -{ - return ortho_build_addr (lvalue, atype); -} - -tree -new_global_address (tree lvalue, tree atype) -{ - return ortho_build_addr (lvalue, atype); -} - -tree -new_global_unchecked_address (tree lvalue, tree atype) -{ - return ortho_build_addr (lvalue, atype); -} - -/* Return a pointer to function FUNC. */ -static tree -build_function_ptr (tree func) -{ - return build1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (func)), func); -} - -tree -new_subprogram_address (tree subprg, tree atype) -{ - return fold (build1 (NOP_EXPR, atype, build_function_ptr (subprg))); -} - -tree -new_value (tree lvalue) -{ - return lvalue; -} - -void -new_debug_line_decl (int line) -{ - input_location = linemap_line_start (line_table, line, 252); -} - -void -new_type_decl (tree ident, tree atype) -{ - tree decl; - - TYPE_NAME (atype) = ident; - decl = build_decl (input_location, TYPE_DECL, ident, atype); - TYPE_STUB_DECL (atype) = decl; - push_decl (decl); - /* - if Get_TYPE_SIZE (Ttype) /= NULL_TREE then - -- Do not generate debug info for uncompleted types. - Rest_Of_Type_Compilation (Ttype, C_True); - end if; - */ -} - -enum o_storage { o_storage_external, - o_storage_public, - o_storage_private, - o_storage_local }; - -static void -set_storage (tree Node, enum o_storage storage) -{ - switch (storage) - { - case o_storage_external: - DECL_EXTERNAL (Node) = 1; - TREE_PUBLIC (Node) = 1; - TREE_STATIC (Node) = 0; - break; - case o_storage_public: - DECL_EXTERNAL (Node) = 0; - TREE_PUBLIC (Node) = 1; - TREE_STATIC (Node) = 1; - break; - case o_storage_private: - DECL_EXTERNAL (Node) = 0; - TREE_PUBLIC (Node) = 0; - TREE_STATIC (Node) = 1; - break; - case o_storage_local: - DECL_EXTERNAL (Node) = 0; - TREE_PUBLIC (Node) = 0; - TREE_STATIC (Node) = 0; - break; - } -} - -void -new_const_decl (tree *res, tree ident, enum o_storage storage, tree atype) -{ - tree cst; - - cst = build_decl (input_location, VAR_DECL, ident, atype); - set_storage (cst, storage); - TREE_READONLY (cst) = 1; - push_decl (cst); - switch (storage) - { - case o_storage_local: - gcc_unreachable (); - case o_storage_external: - /* We are at top level if Current_Function_Decl is null. */ - rest_of_decl_compilation - (cst, current_function_decl == NULL_TREE, 0); - break; - case o_storage_public: - case o_storage_private: - break; - } - *res = cst; -} - -void -start_const_value (tree *cst ATTRIBUTE_UNUSED) -{ -} - -void -finish_const_value (tree *cst, tree val) -{ - DECL_INITIAL (*cst) = val; - TREE_CONSTANT (val) = 1; - TREE_STATIC (*cst) = 1; - rest_of_decl_compilation - (*cst, current_function_decl == NULL_TREE, 0); -} - -void -new_var_decl (tree *res, tree ident, enum o_storage storage, tree atype) -{ - tree var; - - var = build_decl (input_location, VAR_DECL, ident, atype); - if (current_function_decl != NULL_TREE) - { - /* Local variable. */ - TREE_STATIC (var) = 0; - DECL_EXTERNAL (var) = 0; - TREE_PUBLIC (var) = 0; - } - else - set_storage (var, storage); - - push_decl (var); - - if (current_function_decl == NULL_TREE) - rest_of_decl_compilation (var, 1, 0); - - *res = var; -} - -struct GTY(()) o_inter_list -{ - tree ident; - enum o_storage storage; - - /* Return type. */ - tree rtype; - - /* List of parameter types. */ - struct list_constr_type param_list; - - /* Chain of parameters declarations. */ - struct chain_constr_type param_chain; -}; - -void -start_function_decl (struct o_inter_list *interfaces, - tree ident, - enum o_storage storage, - tree rtype) -{ - interfaces->ident = ident; - interfaces->storage = storage; - interfaces->rtype = rtype; - chain_init (&interfaces->param_chain); - list_init (&interfaces->param_list); -} - -void -start_procedure_decl (struct o_inter_list *interfaces, - tree ident, - enum o_storage storage) -{ - start_function_decl (interfaces, ident, storage, void_type_node); -} - -void -new_interface_decl (struct o_inter_list *interfaces, - tree *res, - tree ident, - tree atype) -{ - tree r; - - r = build_decl (input_location, PARM_DECL, ident, atype); - /* DECL_CONTEXT (Res, Xxx); */ - - /* Do type conversion: convert boolean and enums to int */ - switch (TREE_CODE (atype)) - { - case ENUMERAL_TYPE: - case BOOLEAN_TYPE: - DECL_ARG_TYPE (r) = integer_type_node; - default: - DECL_ARG_TYPE (r) = atype; - } - - layout_decl (r, 0); - - chain_append (&interfaces->param_chain, r); - ortho_list_append (&interfaces->param_list, atype); - *res = r; -} - -void -finish_subprogram_decl (struct o_inter_list *interfaces, tree *res) -{ - tree decl; - tree result; - tree parm; - int is_global; - - /* Append a void type in the parameter types chain, so that the function - is known not be have variables arguments. */ - ortho_list_append (&interfaces->param_list, void_type_node); - - decl = build_decl (input_location, FUNCTION_DECL, interfaces->ident, - build_function_type (interfaces->rtype, - interfaces->param_list.first)); - DECL_SOURCE_LOCATION (decl) = input_location; - - is_global = current_function_decl == NULL_TREE - || interfaces->storage == o_storage_external; - if (is_global) - set_storage (decl, interfaces->storage); - else - { - /* A nested subprogram. */ - DECL_EXTERNAL (decl) = 0; - TREE_PUBLIC (decl) = 0; - } - /* The function exist in static storage. */ - TREE_STATIC (decl) = 1; - DECL_INITIAL (decl) = error_mark_node; - TREE_ADDRESSABLE (decl) = 1; - - /* Declare the result. - FIXME: should be moved in start_function_body. */ - result = build_decl (input_location, - RESULT_DECL, NULL_TREE, interfaces->rtype); - DECL_RESULT (decl) = result; - DECL_CONTEXT (result) = decl; - - DECL_ARGUMENTS (decl) = interfaces->param_chain.first; - /* Set DECL_CONTEXT of parameters. */ - for (parm = interfaces->param_chain.first; - parm != NULL_TREE; - parm = TREE_CHAIN (parm)) - DECL_CONTEXT (parm) = decl; - - push_decl (decl); - - /* External functions are never nested. - Remove their context, which is set by push_decl. */ - if (interfaces->storage == o_storage_external) - DECL_CONTEXT (decl) = NULL_TREE; - - if (is_global) - rest_of_decl_compilation (decl, 1, 0); - - *res = decl; -} - -void -start_subprogram_body (tree func) -{ - gcc_assert (current_function_decl == DECL_CONTEXT (func)); - current_function_decl = func; - - /* The function is not anymore external. */ - DECL_EXTERNAL (func) = 0; - - push_stmts (alloc_stmt_list ()); - push_binding (); -} - -void -finish_subprogram_body (void) -{ - tree bind; - tree func; - tree parent; - - bind = pop_binding (); - pop_stmts (); - - func = current_function_decl; - DECL_INITIAL (func) = BIND_EXPR_BLOCK (bind); - DECL_SAVED_TREE (func) = bind; - - /* Initialize the RTL code for the function. */ - allocate_struct_function (func, false); - - /* Store the end of the function. */ - cfun->function_end_locus = input_location; - - parent = DECL_CONTEXT (func); - - if (parent != NULL) - cgraph_get_create_node (func); - else - cgraph_finalize_function (func, false); - - current_function_decl = parent; - set_cfun (NULL); -} - - -void -new_debug_line_stmt (int line) -{ - input_location = linemap_line_start (line_table, line, 252); -} - -void -start_declare_stmt (void) -{ - push_stmts (alloc_stmt_list ()); - push_binding (); -} - -void -finish_declare_stmt (void) -{ - tree bind; - - bind = pop_binding (); - pop_stmts (); - append_stmt (bind); -} - - -struct GTY(()) o_assoc_list -{ - tree subprg; - vec<tree, va_gc> *vecptr; -}; - -void -start_association (struct o_assoc_list *assocs, tree subprg) -{ - assocs->subprg = subprg; - assocs->vecptr = NULL; -} - -void -new_association (struct o_assoc_list *assocs, tree val) -{ - vec_safe_push(assocs->vecptr, val); -} - -tree -new_function_call (struct o_assoc_list *assocs) -{ - return build_call_vec (TREE_TYPE (TREE_TYPE (assocs->subprg)), - build_function_ptr (assocs->subprg), - assocs->vecptr); -} - -void -new_procedure_call (struct o_assoc_list *assocs) -{ - tree res; - - res = build_call_vec (TREE_TYPE (TREE_TYPE (assocs->subprg)), - build_function_ptr (assocs->subprg), - assocs->vecptr); - TREE_SIDE_EFFECTS (res) = 1; - append_stmt (res); -} - -void -new_assign_stmt (tree target, tree value) -{ - tree n; - - n = build2 (MODIFY_EXPR, TREE_TYPE (target), target, value); - TREE_SIDE_EFFECTS (n) = 1; - append_stmt (n); -} - -void -new_func_return_stmt (tree value) -{ - tree assign; - tree stmt; - tree res; - - res = DECL_RESULT (current_function_decl); - assign = build2 (MODIFY_EXPR, TREE_TYPE (value), res, value); - TREE_SIDE_EFFECTS (assign) = 1; - stmt = build1 (RETURN_EXPR, void_type_node, assign); - TREE_SIDE_EFFECTS (stmt) = 1; - append_stmt (stmt); -} - -void -new_proc_return_stmt (void) -{ - tree stmt; - - stmt = build1 (RETURN_EXPR, void_type_node, NULL_TREE); - TREE_SIDE_EFFECTS (stmt) = 1; - append_stmt (stmt); -} - - -struct GTY(()) o_if_block -{ - tree stmt; -}; - -void -start_if_stmt (struct o_if_block *block, tree cond) -{ - tree stmt; - tree stmts; - - stmts = alloc_stmt_list (); - stmt = build3 (COND_EXPR, void_type_node, cond, stmts, NULL_TREE); - block->stmt = stmt; - append_stmt (stmt); - push_stmts (stmts); -} - -void -new_else_stmt (struct o_if_block *block) -{ - tree stmts; - - pop_stmts (); - stmts = alloc_stmt_list (); - COND_EXPR_ELSE (block->stmt) = stmts; - push_stmts (stmts); -} - -void -finish_if_stmt (struct o_if_block *block ATTRIBUTE_UNUSED) -{ - pop_stmts (); -} - - -struct GTY(()) o_snode -{ - tree beg_label; - tree end_label; -}; - -/* Create an artificial label. */ -static tree -build_label (void) -{ - tree res; - - res = build_decl (input_location, LABEL_DECL, NULL_TREE, void_type_node); - DECL_CONTEXT (res) = current_function_decl; - DECL_ARTIFICIAL (res) = 1; - return res; -} - -void -start_loop_stmt (struct o_snode *label) -{ - tree stmt; - - label->beg_label = build_label (); - - stmt = build1 (LABEL_EXPR, void_type_node, label->beg_label); - append_stmt (stmt); - - label->end_label = build_label (); -} - -void -finish_loop_stmt (struct o_snode *label) -{ - tree stmt; - - stmt = build1 (GOTO_EXPR, void_type_node, label->beg_label); - TREE_USED (label->beg_label) = 1; - append_stmt (stmt); - /* Emit the end label only if there is a goto to it. - (Return may be used to exit from the loop). */ - if (TREE_USED (label->end_label)) - { - stmt = build1 (LABEL_EXPR, void_type_node, label->end_label); - append_stmt (stmt); - } -} - -void -new_exit_stmt (struct o_snode *l) -{ - tree stmt; - - stmt = build1 (GOTO_EXPR, void_type_node, l->end_label); - append_stmt (stmt); - TREE_USED (l->end_label) = 1; -} - -void -new_next_stmt (struct o_snode *l) -{ - tree stmt; - - stmt = build1 (GOTO_EXPR, void_type_node, l->beg_label); - TREE_USED (l->beg_label) = 1; - append_stmt (stmt); -} - -struct GTY(()) o_case_block -{ - tree case_type; - tree end_label; - int add_break; -}; - -void -start_case_stmt (struct o_case_block *block, tree value) -{ - tree stmt; - tree stmts; - - block->case_type = TREE_TYPE (value); - block->end_label = build_label (); - block->add_break = 0; - stmts = alloc_stmt_list (); - stmt = build3 (SWITCH_EXPR, block->case_type, value, stmts, NULL_TREE); - append_stmt (stmt); - push_stmts (stmts); -} - -void -start_choice (struct o_case_block *block) -{ - tree stmt; - if (block->add_break) - { - stmt = build1 (GOTO_EXPR, block->case_type, block->end_label); - append_stmt (stmt); - - block->add_break = 0; - } -} - -void -new_expr_choice (struct o_case_block *block ATTRIBUTE_UNUSED, tree expr) -{ - tree stmt; - - stmt = build_case_label - (expr, NULL_TREE, create_artificial_label (input_location)); - append_stmt (stmt); -} - -void -new_range_choice (struct o_case_block *block ATTRIBUTE_UNUSED, - tree low, tree high) -{ - tree stmt; - - stmt = build_case_label - (low, high, create_artificial_label (input_location)); - append_stmt (stmt); -} - -void -new_default_choice (struct o_case_block *block ATTRIBUTE_UNUSED) -{ - tree stmt; - - stmt = build_case_label - (NULL_TREE, NULL_TREE, create_artificial_label (input_location)); - append_stmt (stmt); -} - -void -finish_choice (struct o_case_block *block) -{ - block->add_break = 1; -} - -void -finish_case_stmt (struct o_case_block *block) -{ - tree stmt; - - pop_stmts (); - stmt = build1 (LABEL_EXPR, void_type_node, block->end_label); - append_stmt (stmt); -} - -bool -compare_identifier_string (tree id, const char *str, size_t len) -{ - if (IDENTIFIER_LENGTH (id) != len) - return false; - if (!memcmp (IDENTIFIER_POINTER (id), str, len)) - return true; - else - return false; -} - -void -get_identifier_string (tree id, const char **str, int *len) -{ - *len = IDENTIFIER_LENGTH (id); - *str = IDENTIFIER_POINTER (id); -} - -// C linkage wrappers for two (now C++) functions so that -// Ada code can call them without name mangling -tree get_identifier_with_length_c (const char *c, size_t s) -{ - return get_identifier_with_length(c, s); -} - -int toplev_main_c (int argc, char **argv) -{ - return toplev_main(argc, argv); -} - -void -debug_tree_c (tree expr) -{ - warning (OPT_Wall, "Debug tree"); - debug_tree (expr); -} - -} // end extern "C" - -#include "debug.h" -#include "gt-vhdl-ortho-lang.h" -#include "gtype-vhdl.h" diff --git a/ortho/gcc/ortho_gcc-main.adb b/ortho/gcc/ortho_gcc-main.adb deleted file mode 100644 index 70c8a7f79..000000000 --- a/ortho/gcc/ortho_gcc-main.adb +++ /dev/null @@ -1,42 +0,0 @@ --- 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 Ortho_Gcc_Front; -with Ada.Command_Line; use Ada.Command_Line; - -procedure Ortho_Gcc.Main -is - gnat_argc : Integer; - gnat_argv : System.Address; - - pragma Import (C, gnat_argc); - pragma Import (C, gnat_argv); - - function Toplev_Main (Argc : Integer; Argv : System.Address) - return Integer; - pragma Import (C, Toplev_Main, "toplev_main_c"); - - Status : Exit_Status; -begin - Ortho_Gcc_Front.Init; - - -- Note: GCC set signal handlers... - Status := Exit_Status (Toplev_Main (gnat_argc, gnat_argv)); - Set_Exit_Status (Status); -end Ortho_Gcc.Main; diff --git a/ortho/gcc/ortho_gcc-main.ads b/ortho/gcc/ortho_gcc-main.ads deleted file mode 100644 index 4bd73a1b6..000000000 --- a/ortho/gcc/ortho_gcc-main.ads +++ /dev/null @@ -1 +0,0 @@ -procedure Ortho_Gcc.Main; diff --git a/ortho/gcc/ortho_gcc.adb b/ortho/gcc/ortho_gcc.adb deleted file mode 100644 index ae7b4f53b..000000000 --- a/ortho/gcc/ortho_gcc.adb +++ /dev/null @@ -1,121 +0,0 @@ --- 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; - -package body Ortho_Gcc is - - function New_Lit (Lit : O_Cnode) return O_Enode is - begin - return O_Enode (Lit); - end New_Lit; - - function New_Obj (Obj : O_Dnode) return O_Lnode is - begin - return O_Lnode (Obj); - end New_Obj; - - function New_Obj_Value (Obj : O_Dnode) return O_Enode is - begin - return O_Enode (Obj); - end New_Obj_Value; - - procedure New_Debug_Filename_Decl (Filename : String) is - begin - null; - end New_Debug_Filename_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); - begin - null; - end New_Debug_Comment_Stmt; - - -- Representation of a C String: this is an access to a bounded string. - -- Therefore, with GNAT, such an access is a thin pointer. - subtype Fat_C_String is String (Positive); - type C_String is access all Fat_C_String; - pragma Convention (C, C_String); - - C_String_Null : constant C_String := null; - - -- Return the length of a C String (ie, the number of characters before - -- the Nul). - function C_String_Len (Str : C_String) return Natural; - pragma Import (C, C_String_Len, "strlen"); - - function Lang_Handle_Option (Opt : C_String; Arg : C_String) - return Integer; - pragma Export (C, Lang_Handle_Option); - - function Lang_Parse_File (Filename : C_String) return Integer; - pragma Export (C, Lang_Parse_File); - - function Lang_Handle_Option (Opt : C_String; Arg : C_String) - return Integer - is - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Name => String_Acc, Object => String); - - Res : Natural; - Ada_Opt : String_Acc; - Ada_Arg : String_Acc; - Len : Natural; - begin - Len := C_String_Len (Opt); - Ada_Opt := new String'(Opt (1 .. Len)); - if Arg /= C_String_Null then - Len := C_String_Len (Arg); - Ada_Arg := new String'(Arg (1 .. Len)); - else - Ada_Arg := null; - end if; - Res := Ortho_Gcc_Front.Decode_Option (Ada_Opt, Ada_Arg); - Unchecked_Deallocation (Ada_Opt); - Unchecked_Deallocation (Ada_Arg); - return Res; - end Lang_Handle_Option; - - function Lang_Parse_File (Filename : C_String) return Integer - is - Len : Natural; - File : String_Acc; - begin - if Filename = C_String_Null then - File := null; - else - Len := C_String_Len (Filename); - File := new String'(Filename.all (1 .. Len)); - end if; - - if Ortho_Gcc_Front.Parse (File) then - return 1; - else - return 0; - end if; - end Lang_Parse_File; - -end Ortho_Gcc; diff --git a/ortho/gcc/ortho_gcc.ads b/ortho/gcc/ortho_gcc.ads deleted file mode 100644 index 0afdc0887..000000000 --- a/ortho/gcc/ortho_gcc.ads +++ /dev/null @@ -1,701 +0,0 @@ --- 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; -use Ortho_Ident; - --- Interface to create nodes. -package Ortho_Gcc is - --- 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_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; - - -- True if the code generated supports nested subprograms. - Has_Nested_Subprograms : constant Boolean; - - ------------------------ - -- 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); - -- Finish the record type. - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an uncomplete record type: - -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type. - -- This type can be declared or used to define access types on it. - -- Then, complete (if necessary) the record type, by calling - -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE. - procedure New_Uncomplete_Record_Type (Res : out O_Tnode); - procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List); - - -- Build an union type. - procedure Start_Union_Type (Elements : out O_Element_List); - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode); - procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an access type. - -- DTYPE may be O_tnode_null in order to build an incomplete access type. - -- It is completed with finish_access_type. - function New_Access_Type (Dtype : O_Tnode) return O_Tnode; - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode); - - -- Build an array type. - -- The array is not constrained and unidimensional. - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode; - - -- Build a constrained array type. - function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) - return O_Tnode; - - -- Build a scalar type; size may be 8, 16, 32 or 64. - function New_Unsigned_Type (Size : Natural) return O_Tnode; - function New_Signed_Type (Size : Natural) return O_Tnode; - - -- Build a float type. - function New_Float_Type return O_Tnode; - - -- Build a boolean type. - procedure New_Boolean_Type (Res : out O_Tnode; - False_Id : O_Ident; - False_E : out O_Cnode; - True_Id : O_Ident; - True_E : out O_Cnode); - - -- Create an enumeration - type O_Enum_List is limited private; - - -- Elements are declared in order, the first is ordered from 0. - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural); - procedure New_Enum_Literal (List : in out O_Enum_List; - Ident : O_Ident; Res : out O_Cnode); - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode); - - ---------------- - -- Literals -- - ---------------- - - -- Create a literal from an integer. - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode; - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode; - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode; - - -- Create a null access literal. - function New_Null_Access (Ltype : O_Tnode) return O_Cnode; - - -- Build a record/array aggregate. - -- The aggregate is constant, and therefore can be only used to initialize - -- constant declaration. - -- ATYPE must be either a record type or an array subtype. - -- Elements must be added in the order, and must be literals or aggregates. - type O_Record_Aggr_List is limited private; - type O_Array_Aggr_List is limited private; - - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; - Atype : O_Tnode); - procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; - Value : O_Cnode); - procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; - Res : out O_Cnode); - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode); - procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; - Value : O_Cnode); - procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; - Res : out O_Cnode); - - -- Build an union aggregate. - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode; - - -- Returns the size in bytes of ATYPE. The result is a literal of - -- unsigned type RTYPE - -- ATYPE cannot be an unconstrained array type. - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the 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 -- - ------------------- - - 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; - - type O_Storage is (O_Storage_External, - O_Storage_Public, - O_Storage_Private, - O_Storage_Local); - -- Specifies the storage kind of a declaration. - -- O_STORAGE_EXTERNAL: - -- The declaration do not either reserve memory nor generate code, and - -- is imported either from an other file or from a later place in the - -- current file. - -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE: - -- The declaration reserves memory or generates code. - -- With O_STORAGE_PUBLIC, the declaration is exported outside of the - -- file while with O_STORAGE_PRIVATE, the declaration is local to the - -- file. - - Type_Error : exception; - Syntax_Error : exception; - - -- Create a value from a literal. - function New_Lit (Lit : O_Cnode) return O_Enode; - - -- Create a dyadic operation. - -- Left and right nodes must have the same type. - -- Binary operation is allowed only on boolean types. - -- The result is of the type of the operands. - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode; - - -- Create a monadic operation. - -- Result is of the type of operand. - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode; - - -- Create a comparaison operator. - -- NTYPE is the type of the result and must be a boolean type. - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) - return O_Enode; - - - type O_Inter_List is limited private; - type O_Assoc_List is limited private; - type O_If_Block is limited private; - type O_Case_Block is limited private; - - - -- Get an element of an array. - -- INDEX must be of the type of the array index. - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode; - - -- Get a slice of an array; this is equivalent to a conversion between - -- an array or an array subtype and an array subtype. - -- RES_TYPE must be an array_sub_type whose base type is the same as the - -- base type of ARR. - -- INDEX must be of the type of the array index. - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode; - - -- Get an element of a record. - -- Type of REC must be a record type. - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; - - -- Reference an access. - -- Type of ACC must be an access type. - function New_Access_Element (Acc : O_Enode) return O_Lnode; - - -- Do a conversion. - -- Allowed conversions are: - -- FIXME: to write. - function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode; - - -- Get the address of LVALUE. - -- ATYPE must be a type access whose designated type is the type of LVALUE. - -- FIXME: what about arrays. - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode; - - -- Same as New_Address but without any restriction. - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode; - - -- Get the value of an Lvalue. - function New_Value (Lvalue : O_Lnode) return O_Enode; - function New_Obj_Value (Obj : O_Dnode) return O_Enode; - - -- Get an lvalue from a declaration. - function New_Obj (Obj : O_Dnode) return O_Lnode; - - -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; - - -- Declare a type. - -- This simply gives a name to a type. - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode); - - --------------------- - -- Declarations. -- - --------------------- - - -- Filename of the next declaration. - procedure New_Debug_Filename_Decl (Filename : String); - - -- Line number of the next declaration. - procedure New_Debug_Line_Decl (Line : Natural); - - -- Add a comment in the declarative region. - procedure New_Debug_Comment_Decl (Comment : String); - - -- Declare a constant. - -- This simply gives a name to a constant value or aggregate. - -- A constant cannot be modified and its storage cannot be local. - -- ATYPE must be constrained. - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Set the value of a non-external constant. - procedure Start_Const_Value (Const : in out O_Dnode); - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode); - - -- Create a variable declaration. - -- A variable can be local only inside a function. - -- ATYPE must be constrained. - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Start a subprogram declaration. - -- Note: nested subprograms are allowed, ie o_storage_local subprograms can - -- be declared inside a subprograms. It is not allowed to declare - -- o_storage_external subprograms inside a subprograms. - -- Return type and interfaces cannot be a composite type. - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode); - -- For a subprogram without return value. - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage); - - -- Add an interface declaration to INTERFACES. - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode); - -- Finish the function declaration, get the node and a statement list. - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; Res : out O_Dnode); - -- Start a subprogram body. - -- Note: the declaration may have an external storage, in this case it - -- becomes public. - procedure Start_Subprogram_Body (Func : O_Dnode); - -- Finish a subprogram body. - procedure Finish_Subprogram_Body; - - - ------------------- - -- Statements. -- - ------------------- - - -- Add a line number as a statement. - procedure New_Debug_Line_Stmt (Line : Natural); - - -- Add a comment as a statement. - procedure New_Debug_Comment_Stmt (Comment : String); - - -- Start a declarative region. - procedure Start_Declare_Stmt; - procedure Finish_Declare_Stmt; - - -- Create a function call or a procedure call. - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode); - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode); - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode; - procedure New_Procedure_Call (Assocs : in out O_Assoc_List); - - -- Assign VALUE to TARGET, type must be the same or compatible. - -- FIXME: what about slice assignment? - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode); - - -- Exit from the subprogram and return VALUE. - procedure New_Return_Stmt (Value : O_Enode); - -- Exit from the subprogram, which doesn't return value. - procedure New_Return_Stmt; - - -- Build an IF statement. - procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode); - procedure New_Else_Stmt (Block : in out O_If_Block); - procedure Finish_If_Stmt (Block : in out O_If_Block); - - -- Create a infinite loop statement. - procedure Start_Loop_Stmt (Label : out O_Snode); - procedure Finish_Loop_Stmt (Label : in out O_Snode); - - -- Exit from a loop stmt or from a for stmt. - procedure New_Exit_Stmt (L : O_Snode); - -- Go to the start of a loop stmt or of a for stmt. - -- Loops/Fors between L and the current points are exited. - procedure New_Next_Stmt (L : O_Snode); - - -- Case statement. - -- VALUE is the selector and must be a discrete type. - procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode); - -- A choice branch is composed of expr, range or default choices. - -- A choice branch is enclosed between a Start_Choice and a Finish_Choice. - -- The statements are after the finish_choice. - procedure Start_Choice (Block : in out O_Case_Block); - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode); - procedure New_Range_Choice (Block : in out O_Case_Block; - Low, High : O_Cnode); - procedure New_Default_Choice (Block : in out O_Case_Block); - procedure Finish_Choice (Block : in out O_Case_Block); - procedure Finish_Case_Stmt (Block : in out O_Case_Block); - --- End of common part -private - -- GCC supports nested subprograms. - Has_Nested_Subprograms : constant Boolean := True; - - 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 - Case_Type : Tree; - 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/gcc/ortho_gcc.private.ads b/ortho/gcc/ortho_gcc.private.ads deleted file mode 100644 index cc2f556f0..000000000 --- a/ortho/gcc/ortho_gcc.private.ads +++ /dev/null @@ -1,269 +0,0 @@ --- 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 - -- GCC supports nested subprograms. - Has_Nested_Subprograms : constant Boolean := True; - - 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 - Case_Type : Tree; - 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/gcc/ortho_gcc_front.ads b/ortho/gcc/ortho_gcc_front.ads deleted file mode 100644 index 553057b20..000000000 --- a/ortho/gcc/ortho_gcc_front.ads +++ /dev/null @@ -1,2 +0,0 @@ -with Ortho_Front; -package Ortho_Gcc_Front renames Ortho_Front; diff --git a/ortho/gcc/ortho_ident.adb b/ortho/gcc/ortho_ident.adb deleted file mode 100644 index 770fece2b..000000000 --- a/ortho/gcc/ortho_ident.adb +++ /dev/null @@ -1,56 +0,0 @@ --- GCC back-end for ortho (identifiers) --- 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. - -package body Ortho_Ident is - function Get_Identifier_With_Length (Str : Address; Size : Integer) - return O_Ident; - pragma Import (C, Get_Identifier_With_Length, - "get_identifier_with_length_c"); - - function Compare_Identifier_String - (Id : O_Ident; Str : Address; Size : Integer) - return Boolean; - pragma Import (C, Compare_Identifier_String); - pragma Warnings (Off, Compare_Identifier_String); - - function Get_Identifier (Str : String) return O_Ident is - begin - return Get_Identifier_With_Length (Str'Address, Str'Length); - end Get_Identifier; - - function Is_Equal (Id : O_Ident; Str : String) return Boolean is - begin - return Compare_Identifier_String (Id, Str'Address, Str'Length); - end Is_Equal; - - function Get_String (Id : O_Ident) return String - is - procedure Get_Identifier_String - (Id : O_Ident; Str_Ptr : Address; Len_Ptr : Address); - pragma Import (C, Get_Identifier_String); - - Len : Natural; - type Str_Acc is access String (Positive); - Str : Str_Acc; - begin - Get_Identifier_String (Id, Str'Address, Len'Address); - return Str (1 .. Len); - end Get_String; - -end Ortho_Ident; - diff --git a/ortho/gcc/ortho_ident.ads b/ortho/gcc/ortho_ident.ads deleted file mode 100644 index 76c09ceb9..000000000 --- a/ortho/gcc/ortho_ident.ads +++ /dev/null @@ -1,30 +0,0 @@ --- GCC back-end for ortho (identifiers) --- 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; use System; - -package Ortho_Ident is - subtype O_Ident is Address; - function Get_Identifier (Str : String) return O_Ident; - function Get_String (Id : O_Ident) return String; - function Is_Equal (L, R : O_Ident) return Boolean renames System."="; - function Is_Equal (Id : O_Ident; Str : String) return Boolean; - O_Ident_Nul : constant O_Ident; -private - O_Ident_Nul : constant O_Ident := Null_Address; -end Ortho_Ident; diff --git a/ortho/gcc/ortho_nodes.ads b/ortho/gcc/ortho_nodes.ads deleted file mode 100644 index 7c6c4a076..000000000 --- a/ortho/gcc/ortho_nodes.ads +++ /dev/null @@ -1,3 +0,0 @@ -with Ortho_Gcc; - -package Ortho_Nodes renames Ortho_Gcc; |