diff options
Diffstat (limited to 'ortho/agcc')
29 files changed, 3651 insertions, 0 deletions
diff --git a/ortho/agcc/Makefile.inc b/ortho/agcc/Makefile.inc new file mode 100644 index 0000000..b5da6f0 --- /dev/null +++ b/ortho/agcc/Makefile.inc @@ -0,0 +1,112 @@ +# -*- Makefile -*- for agcc, the Ada binding for GCC internals. +# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +# +# GHDL is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any later +# version. +# +# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING. If not, write to the Free +# Software Foundation, 59 Temple Place - Suite 330, Boston, MA +# 02111-1307, USA. + +# Variable used: +# AGCC_GCCSRC_DIR: the gcc source base directory (ie gcc-X.Y.Z-objs/) +# AGCC_GCCOBJ_DIR: the gcc objects base directory +# agcc_srcdir: the agcc source directory +# agcc_objdir: the agcc object directory + +AGCC_INC_FLAGS=-I$(AGCC_GCCOBJ_DIR)/gcc -I$(AGCC_GCCSRC_DIR)/include \ + -I$(AGCC_GCCSRC_DIR)/gcc -I$(AGCC_GCCSRC_DIR)/gcc/config +AGCC_CFLAGS=-g -DIN_GCC $(AGCC_INC_FLAGS) + +AGCC_LOCAL_OBJS=agcc-bindings.o agcc-version.o + +AGCC_DEPS := $(agcc_srcdir)/agcc-trees.ads \ + $(agcc_srcdir)/agcc-hwint.ads \ + $(agcc_srcdir)/agcc-hconfig.ads \ + $(agcc_srcdir)/agcc-real.ads \ + $(agcc_srcdir)/agcc-machmode.ads \ + $(agcc_srcdir)/agcc-tm.ads \ + $(agcc_srcdir)/agcc-options.ads \ + $(AGCC_LOCAL_OBJS) +AGCC_OBJS := $(AGCC_LOCAL_OBJS) \ + $(AGCC_GCCOBJ_DIR)/gcc/toplev.o \ + $(AGCC_GCCOBJ_DIR)/gcc/c-convert.o \ + $(AGCC_GCCOBJ_DIR)/gcc/libbackend.a \ + $(AGCC_GCCOBJ_DIR)/libiberty/libiberty.a + +# Set rights to prevent editing. +GENERATE_VIA_GEN_TREE=\ + $(RM) -f $@ && \ + $(agcc_objdir)/gen_tree -C $(AGCC_GCCOBJ_DIR)/gcc - < $< > $@ && \ + chmod a-w $@ + +$(agcc_srcdir)/agcc-trees.ads: $(agcc_srcdir)/agcc-trees.ads.in \ + $(agcc_objdir)/gen_tree + $(GENERATE_VIA_GEN_TREE) + +$(agcc_srcdir)/agcc-hwint.ads: $(agcc_srcdir)/agcc-hwint.ads.in \ + $(agcc_objdir)/gen_tree + $(GENERATE_VIA_GEN_TREE) + +$(agcc_srcdir)/agcc-hconfig.ads: $(agcc_srcdir)/agcc-hconfig.ads.in \ + $(agcc_objdir)/gen_tree + $(GENERATE_VIA_GEN_TREE) + +$(agcc_srcdir)/agcc-real.ads: $(agcc_srcdir)/agcc-real.ads.in \ + $(agcc_objdir)/gen_tree + $(GENERATE_VIA_GEN_TREE) + +$(agcc_srcdir)/agcc-machmode.ads: $(agcc_srcdir)/agcc-machmode.ads.in \ + $(agcc_objdir)/gen_tree \ + $(AGCC_GCCOBJ_DIR)/gcc/insn-modes.h + $(GENERATE_VIA_GEN_TREE) + +$(agcc_srcdir)/agcc-tm.ads: $(agcc_srcdir)/agcc-tm.ads.in \ + $(agcc_objdir)/gen_tree + $(GENERATE_VIA_GEN_TREE) + +$(agcc_srcdir)/agcc-options.ads: $(agcc_srcdir)/agcc-options.ads.in \ + $(agcc_objdir)/gen_tree \ + $(AGCC_GCCOBJ_DIR)/gcc/options.h + $(GENERATE_VIA_GEN_TREE) + +$(agcc_objdir)/gen_tree: $(agcc_objdir)/gen_tree.o + $(CC) -o $@ $< + +$(agcc_objdir)/gen_tree.o: $(agcc_srcdir)/gen_tree.c \ + $(AGCC_GCCSRC_DIR)/gcc/tree.def $(AGCC_GCCSRC_DIR)/gcc/tree.h \ + $(AGCC_GCCOBJ_DIR)/gcc/tree-check.h + $(CC) -c -o $@ $< $(AGCC_CFLAGS) + +agcc-bindings.o: $(agcc_srcdir)/agcc-bindings.c \ + $(AGCC_GCCOBJ_DIR)/gcc/gtype-vhdl.h \ + $(AGCC_GCCOBJ_DIR)/gcc/gt-vhdl-agcc-bindings.h + $(CC) -c -o $@ $< $(AGCC_CFLAGS) + +agcc-version.c: $(AGCC_GCCSRC_DIR)/gcc/version.c + -$(RM) -f $@ + echo '#include "version.h"' > $@ + sed -n -e '/version_string/ s/";/ (ghdl)";/p' < $< >> $@ + echo 'const char bug_report_url[] = "<URL:mailto:ghdl@free.fr>";' >> $@ + +agcc-version.o: agcc-version.c + $(CC) -c -o $@ $< $(AGCC_CFLAGS) + +agcc-clean: force + $(RM) -f $(agcc_objdir)/gen_tree $(agcc_objdir)/gen_tree.o + $(RM) -f $(agcc_objdir)/*.o + $(RM) -f $(agcc_srcdir)/*~ + +agcc-maintainer-clean: force + $(RM) -f $(AGCC_DEPS) + + +.PHONY: agcc-clean agcc-maintainer-clean diff --git a/ortho/agcc/agcc-autils.adb b/ortho/agcc/agcc-autils.adb new file mode 100644 index 0000000..30eb1e6 --- /dev/null +++ b/ortho/agcc/agcc-autils.adb @@ -0,0 +1,93 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Unchecked_Conversion; +with Agcc.Hconfig; use Agcc.Hconfig; +with Agcc.Machmode; use Agcc.Machmode; + +package body Agcc.Autils is + Arr_Len : constant Natural := Unsigned_64'Size / HOST_WIDE_INT'Size; + type Arr_Conv is array (Natural range 0 .. Arr_Len - 1) of HOST_WIDE_INT; + + subtype Assert_Type is Boolean range True .. True; + Assert_Arr_Len_Is_1_Or_2 : constant Assert_Type := + Arr_Len = 1 or Arr_Len = 2; + pragma Unreferenced (Assert_Arr_Len_Is_1_Or_2); + + procedure To_Host_Wide_Int (V : Unsigned_64; L, H : out HOST_WIDE_INT) is + function Unchecked_Conversion is new Ada.Unchecked_Conversion + (Source => Unsigned_64, Target => Arr_Conv); + Res : Arr_Conv; + begin + Res := Unchecked_Conversion (V); + if Arr_Len = 1 then + H := 0; + L := Res (0); + else + if HOST_WORDS_BIG_ENDIAN then + L := Res (1); + H := Res (0); + else + L := Res (0); + H := Res (1); + end if; + end if; + end To_Host_Wide_Int; + + procedure To_Host_Wide_Int (V : Integer_64; L, H : out HOST_WIDE_INT) is + function Unchecked_Conversion is new Ada.Unchecked_Conversion + (Source => Integer_64, Target => Arr_Conv); + Res : Arr_Conv; + begin + Res := Unchecked_Conversion (V); + if Arr_Len = 1 then + if V < 0 then + H := -1; + else + H := 0; + end if; + L := Res (0); + else + if HOST_WORDS_BIG_ENDIAN then + L := Res (1); + H := Res (0); + else + L := Res (0); + H := Res (1); + end if; + end if; + end To_Host_Wide_Int; + + function To_Real_Value_Type (V : IEEE_Float_64) return REAL_VALUE_TYPE + is + Mant_Size : constant Natural := 60; + Rfract : IEEE_Float_64; + Fract : Integer_64; + Exp : Integer; + L, H : HOST_WIDE_INT; + Mantisse : REAL_VALUE_TYPE; + begin + -- Note: this works only when REAL_ARITHMETIC is defined!!! + Exp := IEEE_Float_64'Exponent (V); + Rfract := IEEE_Float_64'Fraction (V); + Rfract := IEEE_Float_64'Scaling (Rfract, Mant_Size); + Fract := Integer_64 (Rfract); + To_Host_Wide_Int (Fract, L, H); + REAL_VALUE_FROM_INT (Mantisse'Address, L, H, DFmode); + return REAL_VALUE_LDEXP (Mantisse, Exp - Mant_Size); + end To_Real_Value_Type; +end Agcc.Autils; diff --git a/ortho/agcc/agcc-autils.ads b/ortho/agcc/agcc-autils.ads new file mode 100644 index 0000000..8ca7da4 --- /dev/null +++ b/ortho/agcc/agcc-autils.ads @@ -0,0 +1,28 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Agcc.Hwint; use Agcc.Hwint; +with Agcc.Real; use Agcc.Real; +with Interfaces; use Interfaces; + +-- Additional utils. +package Agcc.Autils is + procedure To_Host_Wide_Int (V : Unsigned_64; L, H : out HOST_WIDE_INT); + procedure To_Host_Wide_Int (V : Integer_64; L, H : out HOST_WIDE_INT); + function To_Real_Value_Type (V : IEEE_Float_64) return REAL_VALUE_TYPE; +end Agcc.Autils; + diff --git a/ortho/agcc/agcc-bindings.c b/ortho/agcc/agcc-bindings.c new file mode 100644 index 0000000..2dbe33b --- /dev/null +++ b/ortho/agcc/agcc-bindings.c @@ -0,0 +1,738 @@ +/* Ada bindings for GCC internals - Bindings for Ada. + Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ +#include <stddef.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 "real.h" +#include "toplev.h" + +enum tree_code +get_tree_code (tree t) +{ + return TREE_CODE (t); +} + +void +set_tree_constant (tree t, int flag) +{ + TREE_CONSTANT (t) = flag; +} + +int +get_tree_constant (tree t) +{ + return TREE_CONSTANT (t); +} + +void +set_tree_public (tree t, int flag) +{ + TREE_PUBLIC (t) = flag; +} + +void +set_tree_static (tree t, int flag) +{ + TREE_STATIC (t) = flag; +} + +void +set_tree_type (tree t, tree val) +{ + TREE_TYPE (t) = val; +} + +tree +get_tree_type (tree t) +{ + return TREE_TYPE (t); +} + +void +set_tree_chain (tree t, tree chain) +{ + TREE_CHAIN (t) = chain; +} + +tree +get_tree_chain (tree t) +{ + return TREE_CHAIN (t); +} + +void +set_tree_unsigned (tree t, int flag) +{ + TREE_UNSIGNED (t) = flag; +} + +int +get_tree_unsigned (tree t) +{ + return TREE_UNSIGNED (t); +} + +void +set_tree_addressable (tree t, int flag) +{ + TREE_ADDRESSABLE (t) = flag; +} + +int +get_tree_addressable (tree t) +{ + return TREE_ADDRESSABLE (t); +} + +void +set_tree_side_effects (tree t, int flag) +{ + TREE_SIDE_EFFECTS (t) = flag; +} + +void +set_tree_readonly (tree t, int flag) +{ + TREE_READONLY (t) = flag; +} + +void +set_tree_operand (tree t, unsigned int n, tree val) +{ + TREE_OPERAND (t, n) = val; +} + +tree +get_tree_operand (tree t, unsigned int n) +{ + return TREE_OPERAND (t, n); +} + +int +get_tree_this_volatile (tree t) +{ + return TREE_THIS_VOLATILE (t); +} + +int +set_tree_this_volatile (tree t, int val) +{ + TREE_THIS_VOLATILE (t) = val; +} + +tree +get_tree_purpose (tree l) +{ + return TREE_PURPOSE (l); +} + +tree +get_tree_value (tree l) +{ + return TREE_VALUE (l); +} + +int +get_tree_used (tree n) +{ + return TREE_USED (n); +} + +void +set_tree_used (tree n, int flag) +{ + TREE_USED (n) = flag; +} + +HOST_WIDE_INT +get_tree_int_cst_low (tree node) +{ + return TREE_INT_CST_LOW (node); +} + +HOST_WIDE_INT +get_tree_int_cst_high (tree node) +{ + return TREE_INT_CST_HIGH (node); +} + +tree +get_constructor_elts (tree c) +{ + return CONSTRUCTOR_ELTS (c); +} + +tree +(build_int_2) (HOST_WIDE_INT lo, HOST_WIDE_INT hi) +{ + return build_int_2 (lo, hi); +} + +void +set_decl_arg_type (tree decl, tree val) +{ + DECL_ARG_TYPE (decl) = val; +} + +void +set_decl_external (tree decl, int val) +{ + DECL_EXTERNAL (decl) = val; +} + +int +get_decl_external (tree decl) +{ + return DECL_EXTERNAL (decl); +} + +void +set_decl_arguments (tree decl, tree args) +{ + DECL_ARGUMENTS (decl) = args; +} + +tree +get_decl_arguments (tree decl) +{ + return DECL_ARGUMENTS (decl); +} + +void +set_decl_result (tree decl, tree res) +{ + DECL_RESULT (decl) = res; +} + +tree +get_decl_result (tree decl) +{ + return DECL_RESULT (decl); +} + +void +set_decl_context (tree decl, tree context) +{ + DECL_CONTEXT (decl) = context; +} + +tree +get_decl_context (tree decl) +{ + return DECL_CONTEXT (decl); +} + +void +set_decl_initial (tree decl, tree res) +{ + DECL_INITIAL (decl) = res; +} + +tree +get_decl_initial (tree decl) +{ + return DECL_INITIAL (decl); +} + +tree +get_decl_name (tree decl) +{ + return DECL_NAME (decl); +} + +tree +get_decl_assembler_name (tree decl) +{ + return DECL_ASSEMBLER_NAME (decl); +} + +void +set_DECL_ASSEMBLER_NAME (tree decl, tree name) +{ + SET_DECL_ASSEMBLER_NAME (decl, name); +} + +void +set_decl_built_in_class (tree decl, enum built_in_class class) +{ + DECL_BUILT_IN_CLASS (decl) = class; +} + +void +set_decl_function_code (tree decl, int code) +{ + DECL_FUNCTION_CODE (decl) = code; +} + +tree +get_decl_field_offset (tree decl) +{ + return DECL_FIELD_OFFSET (decl); +} + +tree +get_decl_field_bit_offset (tree decl) +{ + return DECL_FIELD_BIT_OFFSET (decl); +} + +int +integral_type_p (tree type) +{ + return INTEGRAL_TYPE_P (type); +} + +void +set_type_values (tree type, tree values) +{ + TYPE_VALUES (type) = values; +} + +void +set_type_name (tree type, tree name) +{ + TYPE_NAME (type) = name; +} + +tree +get_type_name (tree type) +{ + return TYPE_NAME (type); +} + +void +set_type_min_value (tree type, tree val) +{ + TYPE_MIN_VALUE (type) = val; +} + +tree +get_type_min_value (tree type) +{ + return TYPE_MIN_VALUE (type); +} + +void +set_type_max_value (tree type, tree val) +{ + TYPE_MAX_VALUE (type) = val; +} + +tree +get_type_max_value (tree type) +{ + return TYPE_MAX_VALUE (type); +} + +void +set_type_size (tree type, tree size) +{ + TYPE_SIZE (type) = size; +} + +tree +get_type_size (tree type) +{ + return TYPE_SIZE (type); +} + +void +set_type_precision (tree type, int precision) +{ + TYPE_PRECISION (type) = precision; +} + +int +get_type_precision (tree type) +{ + return TYPE_PRECISION (type); +} + +void +set_type_fields (tree type, tree fields) +{ + TYPE_FIELDS (type) = fields; +} + +tree +get_type_fields (tree type) +{ + return TYPE_FIELDS (type); +} + +void +set_type_stub_decl (tree type, tree decl) +{ + TYPE_STUB_DECL (type) = decl; +} + +tree +get_type_domain (tree type) +{ + return TYPE_DOMAIN (type); +} + +void +set_type_domain (tree type, tree domain) +{ + TYPE_DOMAIN (type) = domain; +} + +void * +get_type_lang_specific (tree node) +{ + return TYPE_LANG_SPECIFIC (node); +} + +void +set_type_lang_specific (tree node, void *val) +{ + TYPE_LANG_SPECIFIC (node) = val; +} + +int +get_type_is_sizetype (tree node) +{ + return TYPE_IS_SIZETYPE (node); +} + +void +set_type_pointer_to (tree node, tree dnode) +{ + TYPE_POINTER_TO (node) = dnode; +} + +tree +get_type_pointer_to (tree node) +{ + return TYPE_POINTER_TO (node); +} + +enum machine_mode +get_type_mode (tree node) +{ + return TYPE_MODE (node); +} + +void +set_type_mode (tree node, enum machine_mode mode) +{ + TYPE_MODE (node) = mode; +} + +void +set_current_function_decl (tree decl) +{ + current_function_decl = decl; +} + +tree +get_current_function_decl (void) +{ + return current_function_decl; +} + +int +double_type_size (void) +{ + return DOUBLE_TYPE_SIZE; +} + +int +bits_per_unit (void) +{ + return BITS_PER_UNIT; +} + +tree +(size_int) (HOST_WIDE_INT number) +{ + return size_int (number); +} + +tree +get_type_size_unit (tree node) +{ + return TYPE_SIZE_UNIT (node); +} + +/* For agcc.real: */ +REAL_VALUE_TYPE +get_REAL_VALUE_ATOF (const char *s, enum machine_mode mode) +{ + return REAL_VALUE_ATOF (s, mode); +} + +REAL_VALUE_TYPE +get_REAL_VALUE_LDEXP (REAL_VALUE_TYPE x, int n) +{ + REAL_VALUE_TYPE res; + real_ldexp (&res, &x, n); + return res; +} + +void +get_REAL_VALUE_FROM_INT (REAL_VALUE_TYPE *d, HOST_WIDE_INT l, HOST_WIDE_INT h, + enum machine_mode mode) +{ + REAL_VALUE_FROM_INT (*d, l, h, mode); +} + +int +get_identifier_length (tree node) +{ + return IDENTIFIER_LENGTH (node); +} + +const char * +get_identifier_pointer (tree node) +{ + return IDENTIFIER_POINTER (node); +} + +tree +get_block_supercontext (tree node) +{ + return BLOCK_SUPERCONTEXT (node); +} + +void +set_block_supercontext (tree block, tree sc) +{ + BLOCK_SUPERCONTEXT (block) = sc; +} + +void +set_block_vars (tree block, tree vars) +{ + BLOCK_VARS (block) = vars; +} + +const int tree_identifier_size = sizeof (struct tree_identifier); + +#if 0 +static void +ggc_mark_tree_ptr (void *elt) +{ + ggc_mark_tree (*(tree *) elt); +} +#endif + +#undef ggc_mark_tree +void +ggc_mark_tree (tree expr) +{ + gt_ggc_m_9tree_node (expr); +} + +#if 0 +void +ggc_add_tree_root (void *base, int nelt) +{ + ggc_add_root (base, nelt, sizeof (tree), ggc_mark_tree_ptr); +} +#endif + +int +get_mode_bitsize (enum machine_mode mode) +{ + return GET_MODE_BITSIZE (mode); +} + +int +get_errorcount (void) +{ + return errorcount; +} + +void +set_errorcount (int c) +{ + errorcount = c; +} + + +/* Defined in agcc.fe */ +extern const char language_name[]; +extern bool lang_init (void); +extern void lang_finish (void); +extern unsigned int lang_init_options (unsigned int argc, const char **argv); +extern int lang_handle_option (size_t code, const char *argc, int value); +extern bool lang_post_options (const char **); +extern HOST_WIDE_INT lang_get_alias_set (tree t); +extern bool mark_addressable (tree t); + +extern int global_bindings_p (void); +extern int kept_level_p (void); +extern tree getdecls (void); +extern void pushlevel (int); +extern tree poplevel (int, int, int); +extern void insert_block (tree); +extern void set_block (tree); +extern tree pushdecl (tree); + +extern tree type_for_mode (enum machine_mode, int); +extern tree type_for_size (unsigned int, int); +extern tree unsigned_type (tree); +extern tree signed_type (tree); +extern tree signed_or_unsigned_type (int, tree); +extern tree truthvalue_conversion (tree); +extern void lang_parse_file (int); + +#undef LANG_HOOKS_NAME +#define LANG_HOOKS_NAME language_name +#undef LANG_HOOKS_IDENTIFIER_SIZE +#define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier) +#undef LANG_HOOKS_INIT +#define LANG_HOOKS_INIT lang_init +#undef LANG_HOOKS_FINISH +#define LANG_HOOKS_FINISH lang_finish +#undef LANG_HOOKS_INIT_OPTIONS +#define LANG_HOOKS_INIT_OPTIONS lang_init_options +#undef LANG_HOOKS_HANDLE_OPTION +#define LANG_HOOKS_HANDLE_OPTION lang_handle_option +#undef LANG_HOOKS_POST_OPTIONS +#define LANG_HOOKS_POST_OPTIONS lang_post_options +#undef LANG_HOOKS_GET_ALIAS_SET +#define LANG_HOOKS_GET_ALIAS_SET lang_get_alias_set +#undef LANG_HOOKS_HONOR_READONLY +#define LANG_HOOKS_HONOR_READONLY true +#undef LANG_HOOKS_TRUTHVALUE_CONVERSION +#define LANG_HOOKS_TRUTHVALUE_CONVERSION truthvalue_conversion +#undef LANG_HOOKS_MARK_ADDRESSABLE +#define LANG_HOOKS_MARK_ADDRESSABLE mark_addressable + +#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 lang_parse_file + +const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; + +/* Tree code classes. */ + +#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE, + +const char tree_code_type[] = { +#include "tree.def" + 'x' +}; +#undef DEFTREECODE + +/* Table indexed by tree code giving number of expression + operands beyond the fixed part of the node structure. + Not used for types or decls. */ + +#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH, + +const unsigned char tree_code_length[] = { +#include "tree.def" + 0 +}; +#undef DEFTREECODE + +#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) NAME, +const char * const tree_code_name[] = { +#include "tree.def" + "@@dummy" +}; +#undef DEFTREECODE + +union lang_tree_node + GTY((desc ("0"), + chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)"))) +{ + union tree_node GTY ((tag ("0"), + desc ("tree_node_structure (&%h)"))) + generic; +}; + +struct lang_decl GTY(()) +{ +}; + +struct lang_type GTY (()) +{ +}; + +struct language_function GTY (()) +{ +}; + +tree +c_common_truthvalue_conversion (tree expr) +{ + if (TREE_CODE (TREE_TYPE (expr)) == BOOLEAN_TYPE) + return expr; + if (TREE_CODE (expr) == INTEGER_CST) + return integer_zerop (expr) ? integer_zero_node : integer_one_node; + + abort (); +} + +int +get_PROMOTE_PROTOTYPES (void) +{ + return PROMOTE_PROTOTYPES; +} + +struct binding_level GTY(()) +{ + tree names; + tree blocks; + tree block_created_by_back_end; + struct binding_level *level_chain; +}; + +extern GTY(()) struct binding_level *current_binding_level; +extern GTY((deletable (""))) struct binding_level *old_binding_level; + +struct binding_level * +alloc_binding_level (void) +{ + return (struct binding_level *)ggc_alloc (sizeof (struct binding_level)); +} + +#ifndef MAX_BITS_PER_WORD +#define MAX_BITS_PER_WORD BITS_PER_WORD +#endif + +extern GTY(()) tree signed_and_unsigned_types[MAX_BITS_PER_WORD + 1][2]; + +#include "debug.h" +#include "gt-vhdl-agcc-bindings.h" +#include "gtype-vhdl.h" + diff --git a/ortho/agcc/agcc-convert.ads b/ortho/agcc/agcc-convert.ads new file mode 100644 index 0000000..964dd81 --- /dev/null +++ b/ortho/agcc/agcc-convert.ads @@ -0,0 +1,26 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Agcc.Trees; use Agcc.Trees; + +package Agcc.Convert is + function Convert_To_Integer (Atype : Tree; Expr : Tree) return Tree; + function Convert_To_Pointer (Atype : Tree; Expr : Tree) return Tree; +private + pragma Import (C, Convert_To_Integer); + pragma Import (C, Convert_To_Pointer); +end Agcc.Convert; diff --git a/ortho/agcc/agcc-diagnostic.ads b/ortho/agcc/agcc-diagnostic.ads new file mode 100644 index 0000000..4558896 --- /dev/null +++ b/ortho/agcc/agcc-diagnostic.ads @@ -0,0 +1,24 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Agcc.Diagnostic is + function Get_Errorcount return Integer; + procedure Set_Errorcount (Cnt : Integer); +private + pragma Import (C, Get_Errorcount); + pragma Import (C, Set_Errorcount); +end Agcc.Diagnostic; diff --git a/ortho/agcc/agcc-fe.ads b/ortho/agcc/agcc-fe.ads new file mode 100644 index 0000000..7c2b110 --- /dev/null +++ b/ortho/agcc/agcc-fe.ads @@ -0,0 +1,238 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Agcc.Trees; use Agcc.Trees; +with Agcc.Machmode; use Agcc.Machmode; +with Agcc.Hwint; use Agcc.Hwint; +with Agcc.Options; use Agcc.Options; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with C; use C; + +package Agcc.Fe is + -- Subprograms that must be defined by the front-end. + + -- Defined in langhooks.h + function Lang_Init_Options (Argc : Integer; Argv : C_String_Array) + return Integer; + + -- Front-end function expected by GCC. + function Lang_Handle_Option (Code : Opt_Code; + Arg : C_String; + Value : Integer) + return Integer; + + type C_String_Acc is access C_String; + pragma Convention (C, C_String_Acc); + + function Lang_Post_Options (Filename : C_String_Acc) return C_Bool; + + function Lang_Init return C_Bool; + + procedure Lang_Finish; + + --procedure Lang_Clear_Binding_Stack; + + -- Return the typed-based alias set for T, which may be an expression + -- or a type. Return -1 if we don't do anything special. + -- O means can alias everything. + function Lang_Get_Alias_Set (T : Tree) return HOST_WIDE_INT; + + --function Lang_Expand_Constant (N : Tree) return Tree; + + --function Lang_Safe_From_P (Target : Rtx; Exp : Tree) return C_Bool; + + procedure Lang_Parse_File (Debug : C_Bool); + + -- 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. + function Mark_Addressable (Exp : Tree) return C_Bool; + + -- Possibly apply default attributes to function FUNC represented by + -- a FUNCTION_DECL. + procedure Insert_Default_Attributes (Func : Tree); + + -- Lexical scopes. + -- Roughly speaking, it is used to mark declarations regions. + + -- Enter in a new lexical scope. INSIDE should be FALSE (TRUE iff called + -- from the inside of the front end, ie from gcc internal code). + procedure Pushlevel (Inside : C_Bool); + + -- Add a declaration to the current scope. + -- Note: GCC backend expect PUSHDECL to return its argument; however, + -- it is only seldom used. Both forms exist and are aliased with a third + -- one which is exported under the C name. + -- (Unfortunatly, it is not possible to export the function and to import + -- the procedure). + procedure Pushdecl (Decl : Tree); + function Pushdecl (Decl : Tree) return Tree; + + -- This function has to be defined. + function Exported_Pushdecl (Decl : Tree) return Tree; + + -- Get the declarations of the current scope. + function Getdecls return Tree; + + procedure Set_Block (Block : Tree); + + -- Return non-zero if we are currently in the global binding level. + function Global_Bindings_P return Integer; + + -- Insert BLOCK at the end of the list of subblocks of the + -- current binding level. This is used when a BIND_EXPR is expanded, + -- to handle the BLOCK node inside the BIND_EXPR. + procedure Insert_Block (Block : Tree); + + -- Exit the current scope. + -- FUNCTIONBODY is TRUE iff the scope corresponds to a subprogram scope. + -- Used forms (both imported). + procedure Poplevel (Keep : C_Bool; Revers : C_Bool; Functionbody : C_Bool); + function Poplevel (Keep : C_Bool; Revers : C_Bool; Functionbody : C_Bool) + return Tree; + + -- Exported form. + function Exported_Poplevel + (Keep : C_Bool; Revers : C_Bool; Functionbody : C_Bool) + return Tree; + + -- Perform all the initialization steps that are language-specific. + --procedure Lang_Init; + + -- Perform all the finalization steps that are language-specific. + --procedure Lang_Finish; + + -- Return an integer type with the number of bits of precision given by + -- PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise + -- it is a signed type. + function Type_For_Size (Precision : Natural; Unsignedp : C_Bool) + return Tree; + + -- Return a data type that has machine mode MODE. UNSIGNEDP selects + -- an unsigned type; otherwise a signed type is returned. + function Type_For_Mode (Mode : Machine_Mode; Unsignedp : C_Bool) + return Tree; + + -- Return the unsigned version of a TYPE_NODE, a scalar type. + function Unsigned_Type (Type_Node : Tree) return Tree; + + -- Return the signed version of a TYPE_NODE, a scalar type. + function Signed_Type (Type_Node : Tree) return Tree; + + -- Return a type the same as TYPE except unsigned or signed according to + -- UNSIGNEDP. + function Signed_Or_Unsigned_Type (Unsignedp : C_Bool; Atype : Tree) + return Tree; + + -- Return a definition for a builtin function named NAME and whose data + -- type is TYPE. TYPE should be a function type with argument types. + -- FUNCTION_CODE tells later passes how to compile calls to this function. + -- See tree.h for its possible values. + -- + -- If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, + -- the name to be called if we can't opencode the function. + function Builtin_Function + (Name: System.Address; + Ftype : Tree; + Function_Code : Built_In_Function; + Class : Built_In_Class; + Library_Name : System.Address) + return Tree; + + -- Set debug flag of the parser. + procedure Set_Yydebug (Flag : C_Bool); + + + -- Hooks for print-tree.c: + procedure Print_Lang_Decl (File : FILEs; Node : Tree; Indent : natural); + procedure Print_Lang_Type (File : FILEs; Node : Tree; Indent : Natural); + procedure Print_Lang_Identifier + (File : FILEs; Node : Tree; Indent : Natural); + procedure Lang_Print_Xnode (File : FILEs; Node : Tree; Indent : Natural); + + -- Print any language-specific compilation statistics. + procedure Print_Lang_Statistics; + + + -- Finish to copy a ..._DECL node (the LANG_DECL_SPECIFIC field). + procedure Copy_Lang_Decl (Node : Tree); + + -- Normalize boolean value EXPR. + function Truthvalue_Conversion (Expr : Tree) return Tree; + + -- Procedure called in case of sizeof applied to an incomplete type. + procedure Incomplete_Type_Error (Value : Tree; Atype : Tree); + + -- This function must be defined in the language-specific files. + -- expand_expr calls it to build the cleanup-expression for a TARGET_EXPR. + function Maybe_Build_Cleanup (Decl : Tree) return Tree; + + --Language_String : constant Chars; + Flag_Traditional : Integer := 0; +private + pragma Export (C, Lang_Init_Options); + pragma Export (C, Lang_Handle_Option); + pragma Export (C, Lang_Post_Options); + pragma Export (C, Lang_Init); + pragma Export (C, Lang_Finish); + pragma Export (C, Lang_Get_Alias_Set); + + pragma Export (C, Lang_Parse_File); + + pragma Export (C, Mark_Addressable); + pragma Export (C, Insert_Default_Attributes); + + pragma Import (C, Pushdecl); + pragma Export (C, Exported_Pushdecl, "pushdecl"); + pragma Export (C, Pushlevel); + pragma Export (C, Set_Block); + pragma Export (C, Insert_Block); + pragma Export (C, Global_Bindings_P); + pragma Import (C, Poplevel); + pragma Export (C, Exported_Poplevel, "poplevel"); + pragma Export (C, Getdecls); + + pragma Export (C, Type_For_Size); + pragma Export (C, Type_For_Mode); + pragma Export (C, Unsigned_Type); + pragma Export (C, Signed_Type); + pragma Export (C, Signed_Or_Unsigned_Type); + + pragma Export (C, Builtin_Function); + + + pragma Export (C, Set_Yydebug); + + pragma Export (C, Print_Lang_Decl); + pragma Export (C, Print_Lang_Type); + pragma Export (C, Print_Lang_Identifier); + pragma Export (C, Lang_Print_Xnode); + + pragma Export (C, Print_Lang_Statistics); + pragma Export (C, Copy_Lang_Decl); + + pragma Export (C, Truthvalue_Conversion); + pragma Export (C, Incomplete_Type_Error); + pragma Export (C, Maybe_Build_Cleanup); + + pragma Export (C, Flag_Traditional); +end Agcc.Fe; + diff --git a/ortho/agcc/agcc-ggc.ads b/ortho/agcc/agcc-ggc.ads new file mode 100644 index 0000000..4892d59 --- /dev/null +++ b/ortho/agcc/agcc-ggc.ads @@ -0,0 +1,33 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Agcc.Trees; use Agcc.Trees; + +package Agcc.Ggc is + procedure Ggc_Add_Root (Base : System.Address; + Nelt : Natural; + Size : Natural; + Func : System.Address); + + procedure Ggc_Add_Tree_Root (Base : System.Address; Nelt : Natural); + + procedure Ggc_Mark_Tree (Expr : Tree); +private + pragma Import (C, Ggc_Add_Root); + pragma Import (C, Ggc_Mark_Tree); + pragma Import (C, Ggc_Add_Tree_Root); +end Agcc.Ggc; diff --git a/ortho/agcc/agcc-ghdl.c b/ortho/agcc/agcc-ghdl.c new file mode 100644 index 0000000..211d5e0 --- /dev/null +++ b/ortho/agcc/agcc-ghdl.c @@ -0,0 +1,658 @@ +/* Ada bindings for GCC internals. + Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ +#include "config.h" +#include "system.h" +#include "tree.h" +#include "flags.h" +#include <stdio.h> + +#if 0 +const char *const language_string = "ghdl"; +int flag_traditional; +#endif + +/* Convertion from a C string to the corresponding cannonical + Ada (GNAT) String. */ +struct str_template +{ + int first; + int last; +}; + +struct str_fatptr +{ + const char *array; + struct str_template *tpl; +}; + +#if 0 +/* Called by toplev.c, to initialize the parser. */ +const char * +init_parse (const char *filename) +{ + struct str_template temp1 = {1, strlen (filename)}; + struct str_fatptr fp = {filename, &temp1}; + + ghdl1__init_parse (fp); + return filename; +} +#endif + +void +lang_init_options (void) +{ + extern int gnat_argc; + extern const char **gnat_argv; + extern const char *progname; + + /* Initialize ada.command_line. */ + gnat_argc = 1; + gnat_argv = &progname; + + adainit (); +} + +#if 0 +/* Decode all the language specific options that cannot be decoded by GCC. The + option decoding phase of GCC calls this routine on the flags that it cannot + decode. Return 1 if successful, otherwise return 0. */ + +int +lang_decode_option (argc, argv) + int argc; + char **argv; +{ + return 0; +} + +void +lang_print_xnode(file, t, i) + FILE *file; + tree t; + int i; +{ + return; +} + +/* Routines Expected by gcc: */ + +/* These are used to build types for various sizes. The code below + is a simplified version of that of GNAT. */ + +#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 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. */ + +tree +type_for_size (precision, unsignedp) + unsigned precision; + int unsignedp; +{ + tree t; + + if (precision <= MAX_BITS_PER_WORD + && signed_and_unsigned_types[precision][unsignedp] != 0) + return signed_and_unsigned_types[precision][unsignedp]; + + if (unsignedp) + t = signed_and_unsigned_types[precision][1] + = make_unsigned_type (precision); + else + t = signed_and_unsigned_types[precision][0] + = make_signed_type (precision); + + return t; +} + + +/* Return a data type that has machine mode MODE. UNSIGNEDP selects + an unsigned type; otherwise a signed type is returned. */ + +tree +type_for_mode (mode, unsignedp) + enum machine_mode mode; + int unsignedp; +{ + return type_for_size (GET_MODE_BITSIZE (mode), unsignedp); +} + +/* Return the unsigned version of a TYPE_NODE, a scalar type. */ + +tree +unsigned_type (type_node) + tree type_node; +{ + return type_for_size (TYPE_PRECISION (type_node), 1); +} + +/* Return the signed version of a TYPE_NODE, a scalar type. */ + +tree +signed_type (type_node) + tree type_node; +{ + return type_for_size (TYPE_PRECISION (type_node), 0); +} + +/* Return a type the same as TYPE except unsigned or signed according to + UNSIGNEDP. */ + +tree +signed_or_unsigned_type (unsignedp, type) + int unsignedp; + tree type; +{ + if (! INTEGRAL_TYPE_P (type) || TREE_UNSIGNED (type) == unsignedp) + return type; + else + return type_for_size (TYPE_PRECISION (type), unsignedp); +} + +void +init_type_for_size (void) +{ + ggc_add_tree_root (signed_and_unsigned_types, + sizeof (signed_and_unsigned_types) / sizeof (tree)); +} +#endif + + +#if 0 +/* These functions and variables deal with binding contours. We only + need these functions for the list of PARM_DECLs, but we leave the + functions more general; these are a simplified version of the + functions from GNAT. */ + +/* For each binding contour we allocate a binding_level structure which records + the entities defined or declared in that contour. Contours include: + + the global one + one for each subprogram definition + one for each compound statement (declare block) + + Binding contours are used to create GCC tree BLOCK nodes. */ + +struct binding_level +{ + /* A chain of ..._DECL nodes for all variables, constants, functions, + parameters and type declarations. These ..._DECL nodes are chained + through the TREE_CHAIN field. Note that these ..._DECL nodes are stored + in the reverse of the order supplied to be compatible with the + back-end. */ + tree names; + /* For each level (except the global one), a chain of BLOCK nodes for all + the levels that were entered and exited one level down from this one. */ + tree blocks; + /* The back end may need, for its own internal processing, to create a BLOCK + node. This field is set aside for this purpose. If this field is non-null + when the level is popped, i.e. when poplevel is invoked, we will use such + block instead of creating a new one from the 'names' field, that is the + ..._DECL nodes accumulated so far. Typically the routine 'pushlevel' + will be called before setting this field, so that if the front-end had + inserted ..._DECL nodes in the current block they will not be lost. */ + tree block_created_by_back_end; + /* The binding level containing this one (the enclosing binding level). */ + struct binding_level *level_chain; +}; + +/* The binding level currently in effect. */ +static struct binding_level *current_binding_level = NULL; + +/* The outermost binding level. This binding level is created when the + compiler is started and it will exist through the entire compilation. */ +static struct binding_level *global_binding_level; + +/* Binding level structures are initialized by copying this one. */ +static struct binding_level clear_binding_level = {NULL, NULL, NULL, NULL}; + +/* Return non-zero if we are currently in the global binding level. */ + +int +global_bindings_p () +{ + return current_binding_level == global_binding_level ? -1 : 0; +} + +/* Return the list of declarations in the current level. Note that this list + is in reverse order (it has to be so for back-end compatibility). */ + +tree +getdecls () +{ + return current_binding_level->names; +} + +/* Nonzero if the current level needs to have a BLOCK made. */ + +int +kept_level_p () +{ + return (current_binding_level->names != 0); +} + +/* Enter a new binding level. The input parameter is ignored, but has to be + specified for back-end compatibility. */ + +void +pushlevel (ignore) + int ignore; +{ + struct binding_level *newlevel + = (struct binding_level *) xmalloc (sizeof (struct binding_level)); + + *newlevel = clear_binding_level; + + /* Add this level to the front of the chain (stack) of levels that are + active. */ + newlevel->level_chain = current_binding_level; + current_binding_level = newlevel; +} + +/* Exit a binding level. + Pop the level off, and restore the state of the identifier-decl mappings + that were in effect when this level was entered. + + If KEEP is nonzero, this level had explicit declarations, so + and create a "block" (a BLOCK node) for the level + to record its declarations and subblocks for symbol table output. + + If FUNCTIONBODY is nonzero, this level is the body of a function, + so create a block as if KEEP were set and also clear out all + label names. + + If REVERSE is nonzero, reverse the order of decls before putting + them into the BLOCK. */ + +tree +poplevel (keep, reverse, functionbody) + int keep; + int reverse; + int functionbody; +{ + /* Points to a BLOCK tree node. This is the BLOCK node construted for the + binding level that we are about to exit and which is returned by this + routine. */ + tree block_node = NULL_TREE; + tree decl_chain; + tree decl_node; + tree subblock_chain = current_binding_level->blocks; + tree subblock_node; + tree block_created_by_back_end; + + /* Reverse the list of XXXX_DECL nodes if desired. Note that the ..._DECL + nodes chained through the `names' field of current_binding_level are in + reverse order except for PARM_DECL node, which are explicitely stored in + the right order. */ + decl_chain = (reverse) ? nreverse (current_binding_level->names) + : current_binding_level->names; + + block_created_by_back_end = current_binding_level->block_created_by_back_end; + if (block_created_by_back_end != 0) + { + block_node = block_created_by_back_end; + + /* Check if we are about to discard some information that was gathered + by the front-end. Nameley check if the back-end created a new block + without calling pushlevel first. To understand why things are lost + just look at the next case (i.e. no block created by back-end. */ + if ((keep || functionbody) && (decl_chain || subblock_chain)) + abort (); + } + + /* If there were any declarations in the current binding level, or if this + binding level is a function body, or if there are any nested blocks then + create a BLOCK node to record them for the life of this function. */ + else if (keep || functionbody) + block_node = build_block (keep ? decl_chain : 0, 0, subblock_chain, 0, 0); + + /* Record the BLOCK node just built as the subblock its enclosing scope. */ + for (subblock_node = subblock_chain; subblock_node; + subblock_node = TREE_CHAIN (subblock_node)) + BLOCK_SUPERCONTEXT (subblock_node) = block_node; + + /* Clear out the meanings of the local variables of this level. */ + + for (subblock_node = decl_chain; subblock_node; + subblock_node = TREE_CHAIN (subblock_node)) + if (DECL_NAME (subblock_node) != 0) + /* If the identifier was used or addressed via a local extern decl, + don't forget that fact. */ + if (DECL_EXTERNAL (subblock_node)) + { + if (TREE_USED (subblock_node)) + TREE_USED (DECL_NAME (subblock_node)) = 1; + if (TREE_ADDRESSABLE (subblock_node)) + TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1; + } + + /* Pop the current level. */ + current_binding_level = current_binding_level->level_chain; + + if (functionbody) + { + /* This is the top level block of a function. The ..._DECL chain stored + in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't + leave them in the BLOCK because they are found in the FUNCTION_DECL + instead. */ + DECL_INITIAL (current_function_decl) = block_node; + BLOCK_VARS (block_node) = 0; + } + else if (block_node) + { + if (block_created_by_back_end == NULL) + current_binding_level->blocks + = chainon (current_binding_level->blocks, block_node); + } + + /* If we did not make a block for the level just exited, any blocks made for + inner levels (since they cannot be recorded as subblocks in that level) + must be carried forward so they will later become subblocks of something + else. */ + else if (subblock_chain) + current_binding_level->blocks + = chainon (current_binding_level->blocks, subblock_chain); + if (block_node) + TREE_USED (block_node) = 1; + + return block_node; +} + +/* Insert BLOCK at the end of the list of subblocks of the + current binding level. This is used when a BIND_EXPR is expanded, + to handle the BLOCK node inside the BIND_EXPR. */ + +void +insert_block (block) + tree block; +{ + TREE_USED (block) = 1; + current_binding_level->blocks + = chainon (current_binding_level->blocks, block); +} + +/* Set the BLOCK node for the innermost scope + (the one we are currently in). */ + +void +set_block (block) + tree block; +{ + current_binding_level->block_created_by_back_end = block; +} + +/* Records a ..._DECL node DECL as belonging to the current lexical scope. + Returns the ..._DECL node. */ + +tree +pushdecl (decl) + tree decl; +{ + /* External objects aren't nested, other objects may be. */ + if (DECL_EXTERNAL (decl)) + DECL_CONTEXT (decl) = 0; + else + DECL_CONTEXT (decl) = current_function_decl; + + /* Put the declaration on the list. The list of declarations is in reverse + order. The list will be reversed later if necessary. This needs to be + this way for compatibility with the back-end. */ + + TREE_CHAIN (decl) = current_binding_level->names; + current_binding_level->names = decl; + + /* For the declaration of a type, set its name if it is not already set. */ + + if (TREE_CODE (decl) == TYPE_DECL + && TYPE_NAME (TREE_TYPE (decl)) == 0) + TYPE_NAME (TREE_TYPE (decl)) = decl; /* DECL_NAME (decl); */ + + return decl; +} +#endif + +#ifndef CHAR_TYPE_SIZE +#define CHAR_TYPE_SIZE BITS_PER_UNIT +#endif + +#ifndef INT_TYPE_SIZE +#define INT_TYPE_SIZE BITS_PER_WORD +#endif + +#undef SIZE_TYPE +#define SIZE_TYPE "long unsigned int" + +#if 0 +/* Create the predefined scalar types such as `integer_type_node' needed + in the gcc back-end and initialize the global binding level. */ + +void +init_decl_processing () +{ + tree endlink; + + error_mark_node = make_node (ERROR_MARK); + TREE_TYPE (error_mark_node) = error_mark_node; + + initialize_sizetypes (); + + /* The structure `tree_identifier' is the GCC tree data structure that holds + IDENTIFIER_NODE nodes. We need to call `set_identifier_size' to tell GCC + that we have not added any language specific fields to IDENTIFIER_NODE + nodes. */ + set_identifier_size (sizeof (struct tree_identifier)); + lineno = 0; + + /* Make the binding_level structure for global names. */ + pushlevel (0); + global_binding_level = current_binding_level; + + build_common_tree_nodes (0); + pushdecl (build_decl (TYPE_DECL, get_identifier ("int"), + integer_type_node)); + pushdecl (build_decl (TYPE_DECL, get_identifier ("char"), + char_type_node)); + set_sizetype (unsigned_type_node); + build_common_tree_nodes_2 (0); + +} +#endif + + +#if 0 +/* Perform all the initialization steps that are language-specific. */ + +void +lang_init () +{} + +/* Perform all the finalization steps that are language-specific. */ + +void +lang_finish () +{} + +/* Return a short string identifying this language to the debugger. */ + +const char * +lang_identify () +{ + return "vhdl"; +} + +/* If DECL has a cleanup, build and return that cleanup here. + This is a callback called by expand_expr. */ + +tree +maybe_build_cleanup (decl) + tree decl; +{ return NULL_TREE; } + +/* Print an error message for invalid use of an incomplete type. */ + +void +incomplete_type_error (dont_care_1, dont_care_2) + tree dont_care_1, dont_care_2; +{ abort (); } + +tree +truthvalue_conversion (expr) + tree expr; +{ return expr;} + +int +mark_addressable (expr) + tree expr; +{return 0;} +#endif + +#if 0 +/* Print any language-specific compilation statistics. */ + +void +print_lang_statistics () +{} + +/* Since we don't use the DECL_LANG_SPECIFIC field, this is a no-op. */ + +void +copy_lang_decl (node) + tree node; +{} + +/* Hooks for print-tree.c: */ + +void +print_lang_decl (file, node, indent) + FILE *file; + tree node; + int indent; +{} + +void +print_lang_type (file, node, indent) + FILE *file; + tree node; + int indent; +{} + +void +print_lang_identifier (file, node, indent) + FILE *file; + tree node; + int indent; +{} +#endif + +#if 0 +/* Performs whatever initialization steps are needed by the language-dependent + lexical analyzer. */ + +void +init_lex () +{} + + +/* Sets some debug flags for the parser. It does nothing here. */ + +void +set_yydebug (value) + int value; +{} +#endif + +#if 0 +/* Routine to print parse error message. */ +void +yyerror (str) + char *str; +{ + fprintf (stderr, "%s\n", str); +} +#endif + +#if 0 +/* Return the typed-based alias set for T, which may be an expression + or a type. Return -1 if we don't do anything special. */ + +HOST_WIDE_INT +lang_get_alias_set (t) + tree t ATTRIBUTE_UNUSED; +{ + return -1; +} +#endif + +#if 0 +/* 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. */ + +tree +builtin_function (name, type, function_code, class, library_name) + const char *name; + tree type; + int function_code; + enum built_in_class class; + const char *library_name; +{ + tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type); + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + if (library_name) + DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name); + make_decl_rtl (decl, NULL_PTR, 1); + pushdecl (decl); + DECL_BUILT_IN_CLASS (decl) = class; + DECL_FUNCTION_CODE (decl) = function_code; + return decl; +} +#endif + +#if 0 +/* Mark language-specific parts of T for garbage-collection. */ + +void +lang_mark_tree (t) + tree t ATTRIBUTE_UNUSED; +{ +} +#endif + +void +print_chain (tree t) +{ + while (t != NULL) + { + print_node_brief (stdout, "", t, 0); + fprintf (stdout, "\n"); + t = TREE_CHAIN (t); + } +} diff --git a/ortho/agcc/agcc-hconfig.ads.in b/ortho/agcc/agcc-hconfig.ads.in new file mode 100644 index 0000000..3662c95 --- /dev/null +++ b/ortho/agcc/agcc-hconfig.ads.in @@ -0,0 +1,21 @@ +-- Ada bindings for GCC internals. -*- Ada -*- +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package Agcc.Hconfig is +@host_big_endian +end Agcc.Hconfig; diff --git a/ortho/agcc/agcc-hwint.ads.in b/ortho/agcc/agcc-hwint.ads.in new file mode 100644 index 0000000..245f211 --- /dev/null +++ b/ortho/agcc/agcc-hwint.ads.in @@ -0,0 +1,23 @@ +-- Ada bindings for GCC internals. -*- Ada -*- +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Interfaces; + +package Agcc.Hwint is + pragma Preelaborate (Agcc.Hwint); +@host_wide_int +end Agcc.Hwint; diff --git a/ortho/agcc/agcc-input.ads b/ortho/agcc/agcc-input.ads new file mode 100644 index 0000000..d7ff5ec --- /dev/null +++ b/ortho/agcc/agcc-input.ads @@ -0,0 +1,29 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Agcc.Input is + type Location_T is record + File : Chars; + Line : Integer; + end record; + pragma Convention (C_Pass_By_Copy, Location_T); + + Input_Location : Location_T; + pragma Import (C, Input_Location); +end Agcc.Input; + + diff --git a/ortho/agcc/agcc-libiberty.ads b/ortho/agcc/agcc-libiberty.ads new file mode 100644 index 0000000..89784b7 --- /dev/null +++ b/ortho/agcc/agcc-libiberty.ads @@ -0,0 +1,21 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Agcc.Libiberty is + function Xmalloc (Size : Size_T) return Chars; + pragma Import (C, Xmalloc); +end Agcc.Libiberty; diff --git a/ortho/agcc/agcc-machmode.ads.in b/ortho/agcc/agcc-machmode.ads.in new file mode 100644 index 0000000..ccc6980 --- /dev/null +++ b/ortho/agcc/agcc-machmode.ads.in @@ -0,0 +1,35 @@ +-- Ada bindings for GCC internals. -*- Ada -*- +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package Agcc.Machmode is + pragma Preelaborate (Agcc.Machmode); + + type Machine_Mode is + ( +@machmode + ); + pragma Convention (C, Machine_Mode); + + function GET_MODE_BITSIZE (Mode : Machine_Mode) return Natural; + Ptr_Mode : Machine_Mode; + +private + pragma Import (C, GET_MODE_BITSIZE); + pragma Import (C, Ptr_Mode); +end Agcc.Machmode; + diff --git a/ortho/agcc/agcc-options.ads.in b/ortho/agcc/agcc-options.ads.in new file mode 100644 index 0000000..8931edd --- /dev/null +++ b/ortho/agcc/agcc-options.ads.in @@ -0,0 +1,31 @@ +-- Ada bindings for GCC internals. -*- Ada -*- +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +-- This file is preprocessed by gen_tree to create agcc-options.ads + +package Agcc.Options is + +@options_CL + + type Opt_Code is + ( +@options_OPTs + ); + + pragma Convention (C, Opt_Code); +end Agcc.Options; diff --git a/ortho/agcc/agcc-output.ads b/ortho/agcc/agcc-output.ads new file mode 100644 index 0000000..6ecab6e --- /dev/null +++ b/ortho/agcc/agcc-output.ads @@ -0,0 +1,24 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Agcc.Trees; use Agcc.Trees; + +package Agcc.Output is + procedure Make_Function_Rtl (Func : Tree); +private + pragma Import (C, Make_Function_Rtl); +end Agcc.Output; diff --git a/ortho/agcc/agcc-real.ads.in b/ortho/agcc/agcc-real.ads.in new file mode 100644 index 0000000..ec6b080 --- /dev/null +++ b/ortho/agcc/agcc-real.ads.in @@ -0,0 +1,42 @@ +-- Ada bindings for GCC internals. -*- Ada -*- +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Agcc.Hwint; use Agcc.Hwint; +with Agcc.Machmode; use Agcc.Machmode; + +package Agcc.Real is + pragma Preelaborate (Agcc.Real); + + type REAL_VALUE_TYPE is private; + + function REAL_VALUE_ATOF (S : System.Address; M : Machine_Mode) + return REAL_VALUE_TYPE; + + function REAL_VALUE_LDEXP (X : REAL_VALUE_TYPE; N : Integer) + return REAL_VALUE_TYPE; + + procedure REAL_VALUE_FROM_INT (D : System.Address; + Lo, Hi : HOST_WIDE_INT; + Mode : Machine_Mode); +private +@real + -- FIXME: check about the convention on other machines. + pragma Convention (C_Pass_By_Copy, REAL_VALUE_TYPE); + pragma Import (C, REAL_VALUE_ATOF, "get_REAL_VALUE_ATOF"); + pragma Import (C, REAL_VALUE_LDEXP, "get_REAL_VALUE_LDEXP"); + pragma Import (C, REAL_VALUE_FROM_INT, "get_REAL_VALUE_FROM_INT"); +end Agcc.Real; diff --git a/ortho/agcc/agcc-rtl.ads b/ortho/agcc/agcc-rtl.ads new file mode 100644 index 0000000..e45143a --- /dev/null +++ b/ortho/agcc/agcc-rtl.ads @@ -0,0 +1,31 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Agcc.Input; use Agcc.Input; +with System; + +package Agcc.Rtl is + -- Defines RTX as an opaque type. + type Rtx is new System.Address; + + procedure Emit_Line_Note (Loc : Location_T); + function Emit_Line_Note (Loc : Location_T) return Rtx; + procedure Emit_Nop; +private + pragma Import (C, Emit_Line_Note); + pragma Import (C, Emit_Nop); +end Agcc.Rtl; diff --git a/ortho/agcc/agcc-stor_layout.ads b/ortho/agcc/agcc-stor_layout.ads new file mode 100644 index 0000000..aeaa4d7 --- /dev/null +++ b/ortho/agcc/agcc-stor_layout.ads @@ -0,0 +1,24 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Agcc.Trees; use Agcc.Trees; + +package Agcc.Stor_Layout is + procedure Fixup_Unsigned_Type (Atype : Tree); +private + pragma Import (C, Fixup_Unsigned_Type); +end Agcc.Stor_Layout; diff --git a/ortho/agcc/agcc-tm.ads.in b/ortho/agcc/agcc-tm.ads.in new file mode 100644 index 0000000..7fea03c --- /dev/null +++ b/ortho/agcc/agcc-tm.ads.in @@ -0,0 +1,37 @@ +-- Ada bindings for GCC internals. -*- Ada -*- +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +-- Definitions about target machine. + +package Agcc.Tm is + pragma Preelaborate (Agcc.Tm); + + function DOUBLE_TYPE_SIZE return Natural; + function LONG_DOUBLE_TYPE_SIZE return Natural; + function BITS_PER_UNIT return Natural; + function BITS_PER_WORD return Natural; + function PROMOTE_PROTOTYPES return C_Bool; +@tm +private + pragma Import (C, DOUBLE_TYPE_SIZE); + pragma Import (C, LONG_DOUBLE_TYPE_SIZE); + pragma Import (C, BITS_PER_UNIT); + pragma Import (C, BITS_PER_WORD); + pragma Import (C, PROMOTE_PROTOTYPES, "get_PROMOTE_PROTOTYPES"); +end Agcc.Tm; + diff --git a/ortho/agcc/agcc-toplev.ads b/ortho/agcc/agcc-toplev.ads new file mode 100644 index 0000000..a816f54 --- /dev/null +++ b/ortho/agcc/agcc-toplev.ads @@ -0,0 +1,51 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Agcc.Trees; use Agcc.Trees; +with System; +with Agcc.Hwint; use Agcc.Hwint; + +package Agcc.Toplev is + procedure Rest_Of_Decl_Compilation (Decl : Tree; + Asmspec : System.Address; + Top_Level : C_Bool; + At_End : C_Bool); + procedure Rest_Of_Type_Compilation (Decl : Tree; Toplevel : C_Bool); + procedure Rest_Of_Compilation (Decl : Tree); + + function Exact_Log2_Wide (X : HOST_WIDE_INT) return Integer; + function Floor_Log2_Wide (X : HOST_WIDE_INT) return Integer; + + procedure Error (Msg : System.Address); + + procedure Announce_Function (Func : Tree); + + function Toplev_Main (Argc : Integer; Argv : System.Address) + return Integer; +private + pragma Import (C, Rest_Of_Decl_Compilation); + pragma Import (C, Rest_Of_Type_Compilation); + pragma Import (C, Rest_Of_Compilation); + + pragma Import (C, Exact_Log2_Wide); + pragma Import (C, Floor_Log2_Wide); + + pragma Import (C, Error); + + pragma Import (C, Announce_Function); + pragma Import (C, Toplev_Main); +end Agcc.Toplev; diff --git a/ortho/agcc/agcc-trees.adb b/ortho/agcc/agcc-trees.adb new file mode 100644 index 0000000..a13aba3 --- /dev/null +++ b/ortho/agcc/agcc-trees.adb @@ -0,0 +1,33 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package body Agcc.Trees is + function Build_Int (Low : HOST_WIDE_INT) return Tree is + begin + if Low < 0 then + return Build_Int_2_Wide (Low, -1); + else + return Build_Int_2_Wide (Low, 0); + end if; + end Build_Int; + + procedure Expand_Start_Bindings (Flags : Integer) is + begin + Expand_Start_Bindings_And_Block (Flags, NULL_TREE); + end Expand_Start_Bindings; + +end Agcc.Trees; diff --git a/ortho/agcc/agcc-trees.ads.in b/ortho/agcc/agcc-trees.ads.in new file mode 100644 index 0000000..5eb2d58 --- /dev/null +++ b/ortho/agcc/agcc-trees.ads.in @@ -0,0 +1,514 @@ +-- Ada bindings for GCC internals. -*- Ada -*- +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +-- This file is preprocessed by gen_tree to create agcc-trees.ads +-- gen_tree adds enumerations from GCC C files. + +with System; use System; +with Agcc.Hwint; use Agcc.Hwint; +with Agcc.Real; use Agcc.Real; +with Agcc.Machmode; use Agcc.Machmode; + +package Agcc.Trees is + --pragma No_Elaboration_Code (Agcc.Trees); + + type Tree is new System.Address; + + NULL_TREE : constant Tree; + + type Tree_Code is + ( +@tree_code + ); + pragma Convention (C, Tree_Code); + + type Built_In_Class is + (NOT_BUILT_IN, BUILT_IN_FRONTEND, BUILT_IN_MD, BUILT_IN_NORMAL); + pragma Convention (C, Built_In_Class); + + type Built_In_Function is + ( +@built_in_function + ); + pragma Convention (C, Built_In_Function); + + type Tree_Index is + ( +@tree_index + ); + + type Type_Qual_Type is new Integer; +@type_qual + + type Global_Trees_Array is array (Tree_Index) of Tree; + pragma Convention (C, Global_Trees_Array); + Global_Trees : Global_Trees_Array; + pragma Import (C, Global_Trees); + + Error_Mark_Node : Tree renames Global_Trees (TI_ERROR_MARK); + Void_Type_Node : Tree renames Global_Trees (TI_VOID_TYPE); + Ptr_Type_Node : Tree renames Global_Trees (TI_PTR_TYPE); + Const_Ptr_Type_Node : Tree renames Global_Trees (TI_CONST_PTR_TYPE); + Integer_Zero_Node : Tree renames Global_Trees (TI_INTEGER_ZERO); + Integer_One_Node : Tree renames Global_Trees (TI_INTEGER_ONE); + Size_Zero_Node : Tree renames Global_Trees (TI_SIZE_ZERO); + + type Size_Type_Kind is + ( +@size_type_kind + ); + + type Sizetype_Tab_Array is array (Size_Type_Kind) of Tree; + pragma Convention (C, Sizetype_Tab_Array); + Sizetype_Tab : Sizetype_Tab_Array; + pragma Import (C, Sizetype_Tab); + + Bitsizetype : Tree renames Sizetype_Tab (TK_BITSIZETYPE); + Sizetype : Tree renames Sizetype_Tab (TK_SIZETYPE); + + type Integer_Types_Kind is + ( +@integer_types + ); + + type Integer_Types_Array is array (Integer_Types_Kind) of Tree; + pragma Convention (C, Integer_Types_Array); + Integer_Types : Integer_Types_Array; + pragma Import (C, Integer_Types); + + Integer_Type_Node : Tree renames Integer_Types (itk_int); + Unsigned_Type_Node : Tree renames Integer_Types (itk_unsigned_int); + Char_Type_Node : Tree renames Integer_Types (itk_char); + + function Build (Code: Tree_Code; T: Tree; O0, O1: Tree) return Tree; + function Build (Code: Tree_Code; T: Tree; O0, O1, O2: Tree) return Tree; + function Build1 (Code: Tree_Code; T: Tree; O: Tree) return Tree; + function Build_Constructor (T : Tree; V : Tree) return Tree; + function Build_Block (Vars : Tree; + Tags : Tree; + Subblocks : Tree; + Supercontext : Tree; + Chain : Tree) + return Tree; + function Build_Decl (Code : Tree_Code; T1 : Tree; T2: Tree) return Tree; + function Build_Int_2 (Low, Hi: HOST_WIDE_INT) return Tree; + function Build_Int_2_Wide (Low, Hi: HOST_WIDE_INT) return Tree; + function Build_Real (Rtype : Tree; D : REAL_VALUE_TYPE) return Tree; + function Build_Function_Type (Value_Type : Tree; Arg_Type : Tree) + return Tree; + function Build_Pointer_Type (Atype : Tree) return Tree; + function Get_Identifier (Str : System.Address) return Tree; + function Build_String (Len : Integer; Str : System.Address) return Tree; + function Build_Index_Type (Max : Tree) return Tree; + function Build_Range_Type (Basetype : Tree; Low : Tree; High : Tree) + return Tree; + function Build_Array_Type (El_Type : Tree; Domain : Tree) return Tree; + function Make_Node (Code : Tree_Code) return Tree; + function Build_Qualified_Type (Atype : Tree; Qual : Type_Qual_Type) + return Tree; + + function Build_Save_Expr (Expr : Tree) return Tree; + + function Make_Signed_Type (Precision : Natural) return Tree; + function Make_Unsigned_Type (Precision : Natural) return Tree; + procedure Initialize_Sizetypes; + procedure Set_Sizetype (Atype : Tree); + + function Host_Integerp (T : Tree; Pos : Integer) return Integer; + + function Chainon (Op1, Op2 : Tree) return Tree; + function Listify (Node : Tree) return Tree; + function Tree_Cons (Purpose : Tree; Value : Tree; Chain : Tree) + return Tree; + function Nreverse (Chain : Tree) return Tree; + function Build_Tree_List (Purpose : Tree; Value : Tree) return Tree; + + function Size_In_Bytes (Decl : Tree) return Tree; + procedure Set_Identifier_Size (Size : Natural); + + function Get_Inner_Reference + (Exp : Tree; + Pbitsize : Address; -- HOST_WIDE_INT pointer + Pbitpos : Address; -- HOST_WIDE_INT pointer + Poffset : Address; -- Tree pointer + Pmode : Address; -- MACHINE_MODE pointer + Punsignedp : Address; -- int pointer + Pvolatilep : Address) -- int pointer + return Tree; + + Current_Function_Decl : Tree; + + function Integer_Zerop (Expr : Tree) return C_Bool; + function Integer_Onep (Expr : Tree) return C_Bool; + function Real_Zerop (Expr : Tree) return C_Bool; + + procedure Layout_Type (Atype : Tree); + procedure Layout_Decl (Decl : Tree; Align : Natural); + + procedure Expand_Start_Bindings_And_Block (Flags : Integer; Block : Tree); + procedure Expand_Start_Bindings (Flags : Integer); + procedure Expand_End_Bindings + (Vars : Tree; Mark_Ends: C_Bool; Dont_Jump_In : C_Bool); + + procedure Init_Function_Start + (Subr : Tree; Filename : Chars; Line : Integer); + procedure Expand_Function_Start + (Subr : Tree; Parms_Have_Cleanups : C_Bool); + procedure Expand_Function_End + (Filename : Chars; Line : Integer; End_Bindings : C_Bool); + procedure Push_Function_Context; + procedure Pop_Function_Context; + procedure Put_Var_Into_Stack (Expr : Tree; Rescan : C_Bool); + procedure Expand_Null_Return; + procedure Expand_Return (Expr : Tree); + procedure Expand_Expr_Stmt (Expr : Tree); + procedure Expand_Decl (Decl : Tree); + procedure Expand_Decl_Init (Decl : Tree); + + function Expand_Exit_Something return Integer; + + -- Conditions (IF). + procedure Expand_Start_Cond (Cond : Tree; Has_Exit : C_Bool); + procedure Expand_Start_Elseif (Cond : Tree); + procedure Expand_Start_Else; + procedure Expand_End_Cond; + + -- Loops (FOR, WHILE, DO-WHILE, CONTINUE, EXIT ...) + type Nesting is private; + Nesting_Null : constant Nesting; + function Expand_Start_Loop (Exit_Flag : C_Bool) return Nesting; + procedure Expand_Continue_Loop (Which_Loop: Nesting); + procedure Expand_End_Loop; + function Expand_Start_Loop_Continue_Elsewhere (Exit_Flag : C_Bool) + return Nesting; + procedure Expand_Loop_Continue_Here; + procedure Expand_Exit_Loop (Which_Loop : Nesting); + function Expand_Exit_Loop_If_False (Which_Loop : Nesting; Cond : Tree) + return Integer; + + -- multibranch (SWITCH). + procedure Expand_Start_Case + (Exit_Flag : C_Bool; Expr : Tree; Etype : Tree; Printname : Chars); + function Pushcase + (Value : Tree; Converter : Address; Label : Tree; Duplicate : Address) + return Integer; + function Pushcase_Range + (Low, High : Tree; Converter : Address; Label : Tree; Duplicate : Address) + return Integer; + function Add_Case_Node (Low, High : Tree; Label : Tree; Duplicate : Address) + return Integer; + procedure Expand_End_Case_Type (Orig_Index : Tree; Orig_Type : Tree); + + procedure Debug_Tree (T: Tree); + + function Fold (Atree : Tree) return Tree; + function Size_Binop (Code : Tree_Code; arg0, Arg1 : Tree) return Tree; + function Size_Int (Number : HOST_WIDE_INT) return Tree; + + function Convert (Atype : Tree; Expr : Tree) return Tree; + + -- Create an INTEGER_CST whose value is LOW signed extended to + -- 2 HOST_WIDE_INT. + function Build_Int (Low : HOST_WIDE_INT) return Tree; + + function Get_TREE_CODE (T : Tree) return Tree_Code; + procedure Set_TREE_CONSTANT (T : Tree; Val : C_Bool); + function Get_TREE_CONSTANT (T : Tree) return C_Bool; + procedure Set_TREE_PUBLIC (Decl: Tree; Val : C_Bool); + procedure Set_TREE_STATIC (Decl : Tree; Val : C_Bool); + procedure Set_TREE_TYPE (Decl : Tree; T : Tree); + function Get_TREE_TYPE (Decl : Tree) return Tree; + procedure Set_TREE_CHAIN (Decl : Tree; Chain : Tree); + function Get_TREE_CHAIN (Decl : Tree) return Tree; + procedure Set_TREE_UNSIGNED (Decl : Tree; Val: C_Bool); + function Get_TREE_UNSIGNED (Decl : Tree) return C_Bool; + procedure Set_TREE_ADDRESSABLE (Decl : Tree; Val: C_Bool); + function Get_TREE_ADDRESSABLE (Decl : Tree) return C_Bool; + procedure Set_TREE_SIDE_EFFECTS (Decl : Tree; Val: C_Bool); + procedure Set_TREE_READONLY (Decl : Tree; Val: C_Bool); + procedure Set_TREE_OPERAND (T : Tree; N : Natural; Val : Tree); + function Get_TREE_OPERAND (T : Tree; N : Natural) return Tree; + procedure Set_TREE_THIS_VOLATILE (T : Tree; Val : C_Bool); + function Get_TREE_THIS_VOLATILE (T : Tree) return C_Bool; + function Get_TREE_VALUE (Decl : Tree) return Tree; + function Get_TREE_PURPOSE (Decl : Tree) return Tree; + function Get_TREE_USED (Decl : Tree) return C_Bool; + procedure Set_TREE_USED (Decl : Tree; Flag : C_Bool); + + function Get_TREE_INT_CST_LOW (Node : Tree) return HOST_WIDE_INT; + function Get_TREE_INT_CST_HIGH (Node : Tree) return HOST_WIDE_INT; + + function Get_CONSTRUCTOR_ELTS (Cons : Tree) return Tree; + + procedure Set_DECL_ARG_TYPE (Decl : Tree; Val : Tree); + procedure Set_DECL_EXTERNAL (Decl : Tree; Val : C_Bool); + function Get_DECL_EXTERNAL (Decl : Tree) return C_Bool; + procedure Set_DECL_ARGUMENTS (Decl : Tree; Args : Tree); + function Get_DECL_ARGUMENTS (Decl : Tree) return Tree; + procedure Set_DECL_RESULT (Decl : Tree; Res : Tree); + function Get_DECL_RESULT (Decl : Tree) return Tree; + procedure Set_DECL_CONTEXT (Decl : Tree; Context : Tree); + function Get_DECL_CONTEXT (Decl : Tree) return Tree; + function Get_DECL_INITIAL (Decl : Tree) return Tree; + procedure Set_DECL_INITIAL (Decl : Tree; Init : Tree); + function Get_DECL_NAME (Decl : Tree) return Tree; + function Get_DECL_ASSEMBLER_NAME (Decl : Tree) return Tree; + procedure Set_DECL_ASSEMBLER_NAME (Decl : Tree; Name : Tree); + procedure Set_DECL_BUILT_IN_CLASS (Decl : Tree; Class : Built_In_Class); + procedure Set_DECL_FUNCTION_CODE (Decl : Tree; Code : Built_In_Function); + function Get_DECL_FIELD_OFFSET (Decl : Tree) return Tree; + function Get_DECL_FIELD_BIT_OFFSET (Decl : Tree) return Tree; + + procedure Set_TYPE_VALUES (Atype : Tree; Values: Tree); + procedure Set_TYPE_NAME (Atype : Tree; Name: Tree); + function Get_TYPE_NAME (Atype : Tree) return Tree; + procedure Set_TYPE_MIN_VALUE (Atype : Tree; Val: Tree); + function Get_TYPE_MIN_VALUE (Atype : Tree) return Tree; + procedure Set_TYPE_MAX_VALUE (Atype : Tree; Val: Tree); + function Get_TYPE_MAX_VALUE (Atype : Tree) return Tree; + procedure Set_TYPE_SIZE (Atype : Tree; Size: Tree); + function Get_TYPE_SIZE (Atype : Tree) return Tree; + procedure Set_TYPE_PRECISION (Atype : Tree; Precision : Integer); + function Get_TYPE_PRECISION (Atype : Tree) return Integer; + procedure Set_TYPE_FIELDS (Atype : Tree; Fields : Tree); + function Get_TYPE_FIELDS (Atype : Tree) return Tree; + procedure Set_TYPE_STUB_DECL (Atype : Tree; Decl : Tree); + procedure Set_TYPE_LANG_SPECIFIC (Atype : Tree; Val : System.Address); + function Get_TYPE_LANG_SPECIFIC (Atype : Tree) return System.Address; + function Get_TYPE_IS_SIZETYPE (Atype : Tree) return C_Bool; + function Get_TYPE_DOMAIN (Atype : Tree) return Tree; + procedure Set_TYPE_DOMAIN (Atype : Tree; Domain : Tree); + function Get_TYPE_SIZE_UNIT (Atype : Tree) return Tree; + function Get_TYPE_POINTER_TO (Atype : Tree) return Tree; + procedure Set_TYPE_POINTER_TO (Atype : Tree; Dtype : Tree); + function INTEGRAL_TYPE_P (Atype : Tree) return C_Bool; + procedure Set_TYPE_MODE (Atype : Tree; Mode : Machine_Mode); + function Get_TYPE_MODE (Atype : Tree) return Machine_Mode; + + function Get_BLOCK_SUPERCONTEXT (Ablock : Tree) return Tree; + procedure Set_BLOCK_SUPERCONTEXT (Ablock : Tree; Sc : Tree); + procedure Set_BLOCK_VARS (Ablock : Tree; Vars : Tree); + + function Get_IDENTIFIER_LENGTH (N : Tree) return Integer; + function Get_IDENTIFIER_POINTER (N : Tree) return Chars; + + procedure Build_Common_Tree_Nodes (Signed_Char : C_Bool); + procedure Build_Common_Tree_Nodes_2 (Short_Double : C_Bool); + + -- Points to the name of the input file from which the current input + -- being parsed originally came (before it went into cpp). + Input_Filename : Chars; + + Main_Input_Filename : Chars; + + -- Current line number in input file. + Lineno : Integer; + + -- sizeof (struct tree_identifier). + Tree_Identifier_Size : Natural; + + -- Create DECL_RTL for a declaration for a static or external variable or + -- static or external function. + procedure Make_Decl_Rtl (Decl : Tree; Asmspec : Chars; Top_Level : C_Bool); + +private + NULL_TREE : constant Tree := Tree (System.Null_Address); + + type Nesting is new System.Address; + Nesting_Null : constant Nesting := Nesting (Null_Address); + + pragma Import (C, Current_Function_Decl); + pragma Import (C, Set_Identifier_Size); + + pragma Import (C, Build); + pragma Import (C, Build1); + pragma Import (C, Build_Constructor); + pragma Import (C, Build_Block); + pragma Import (C, Build_Decl); + pragma Import (C, Build_Int_2); + pragma Import (C, Build_Int_2_Wide); + pragma Import (C, Build_Real); + pragma Import (C, Build_Function_Type); + pragma Import (C, Build_Pointer_Type); + pragma Import (C, Get_Identifier); + pragma Import (C, Build_String); + pragma Import (C, Make_Node); + pragma Import (C, Build_Index_Type); + pragma Import (C, Build_Range_Type); + pragma Import (C, Build_Array_Type); + pragma Import (C, Build_Qualified_Type); + pragma Import (C, Build_Save_Expr, "save_expr"); + + pragma Import (C, Make_Signed_Type); + pragma Import (C, Make_Unsigned_Type); + pragma Import (C, Initialize_Sizetypes); + pragma Import (C, Set_Sizetype); + pragma Import (C, Host_Integerp); + + pragma Import (C, Chainon); + pragma Import (C, Listify); + pragma Import (C, Tree_Cons); + pragma Import (C, Nreverse); + pragma Import (C, Build_Tree_List); + + pragma Import (C, Size_In_Bytes); + pragma Import (C, Get_Inner_Reference); + + pragma Import (C, Integer_Zerop); + pragma Import (C, Integer_Onep); + pragma Import (C, Real_Zerop); + + pragma Import (C, Layout_Type); + pragma Import (C, Layout_Decl); + + pragma Import (C, Expand_Start_Bindings_And_Block); + pragma Import (C, Expand_End_Bindings); + + pragma Import (C, Init_Function_Start); + pragma Import (C, Expand_Function_Start); + pragma Import (C, Expand_Function_End); + pragma Import (C, Push_Function_Context); + pragma Import (C, Pop_Function_Context); + pragma Import (C, Put_Var_Into_Stack); + + pragma Import (C, Expand_Null_Return); + pragma Import (C, Expand_Return); + pragma Import (C, Expand_Expr_Stmt); + pragma Import (C, Expand_Decl); + pragma Import (C, Expand_Decl_Init); + + pragma Import (C, Expand_Exit_Something); + + pragma Import (C, Expand_Start_Cond); + pragma Import (C, Expand_Start_Elseif); + pragma Import (C, Expand_Start_Else); + pragma Import (C, Expand_End_Cond); + + pragma Import (C, Expand_Start_Loop); + pragma Import (C, Expand_Continue_Loop); + pragma Import (C, Expand_End_Loop); + pragma Import (C, Expand_Start_Loop_Continue_Elsewhere); + pragma Import (C, Expand_Loop_Continue_Here); + pragma Import (C, Expand_Exit_Loop); + pragma Import (C, Expand_Exit_Loop_If_False); + + pragma Import (C, Expand_Start_Case); + pragma Import (C, Pushcase); + pragma Import (C, Pushcase_Range); + pragma Import (C, Add_Case_Node); + pragma Import (C, Expand_End_Case_Type); + + pragma Import (C, Debug_Tree); + + pragma Import (C, Fold); + pragma Import (C, Size_Binop); + pragma Import (C, Size_Int); + pragma Import (C, Convert); + + -- Import pragma clauses for C MACROs. + pragma Import (C, Get_TREE_CODE); + pragma Import (C, Set_TREE_CONSTANT); + pragma Import (C, Get_TREE_CONSTANT); + pragma Import (C, Set_TREE_PUBLIC); + pragma Import (C, Set_TREE_STATIC); + pragma Import (C, Set_TREE_TYPE); + pragma Import (C, Get_TREE_TYPE); + pragma Import (C, Set_TREE_CHAIN); + pragma Import (C, Get_TREE_CHAIN); + pragma Import (C, Set_TREE_UNSIGNED); + pragma Import (C, Get_TREE_UNSIGNED); + pragma Import (C, Set_TREE_ADDRESSABLE); + pragma Import (C, Get_TREE_ADDRESSABLE); + pragma Import (C, Set_TREE_SIDE_EFFECTS); + pragma Import (C, Set_TREE_READONLY); + pragma Import (C, Get_TREE_OPERAND); + pragma Import (C, Set_TREE_OPERAND); + pragma Import (C, Get_TREE_THIS_VOLATILE); + pragma Import (C, Set_TREE_THIS_VOLATILE); + pragma Import (C, Get_TREE_PURPOSE); + pragma Import (C, Get_TREE_VALUE); + pragma Import (C, Get_TREE_USED); + pragma Import (C, Set_TREE_USED); + + pragma Import (C, Get_TREE_INT_CST_LOW); + pragma Import (C, Get_TREE_INT_CST_HIGH); + + pragma Import (C, Get_CONSTRUCTOR_ELTS); + pragma Import (C, Set_TYPE_VALUES); + pragma Import (C, Set_TYPE_NAME); + pragma Import (C, Get_TYPE_NAME); + pragma Import (C, Set_TYPE_MIN_VALUE); + pragma Import (C, Get_TYPE_MIN_VALUE); + pragma Import (C, Set_TYPE_MAX_VALUE); + pragma Import (C, Get_TYPE_MAX_VALUE); + pragma Import (C, Set_TYPE_SIZE); + pragma Import (C, Get_TYPE_SIZE); + pragma Import (C, Set_TYPE_PRECISION); + pragma Import (C, Get_TYPE_PRECISION); + pragma Import (C, Set_TYPE_FIELDS); + pragma Import (C, Get_TYPE_FIELDS); + pragma Import (C, Set_TYPE_STUB_DECL); + pragma Import (C, Set_TYPE_LANG_SPECIFIC); + pragma Import (C, Get_TYPE_LANG_SPECIFIC); + pragma Import (C, Get_TYPE_IS_SIZETYPE); + pragma Import (C, Get_TYPE_DOMAIN); + pragma Import (C, Set_TYPE_DOMAIN); + pragma Import (C, Get_TYPE_POINTER_TO); + pragma Import (C, Set_TYPE_POINTER_TO); + pragma Import (C, Get_TYPE_SIZE_UNIT); + pragma Import (C, INTEGRAL_TYPE_P); + pragma Import (C, Set_TYPE_MODE); + pragma Import (C, Get_TYPE_MODE); + + pragma Import (C, Set_DECL_ARG_TYPE); + pragma Import (C, Set_DECL_EXTERNAL); + pragma Import (C, Get_DECL_EXTERNAL); + pragma Import (C, Set_DECL_ARGUMENTS); + pragma Import (C, Get_DECL_ARGUMENTS); + pragma Import (C, Set_DECL_RESULT); + pragma Import (C, Get_DECL_RESULT); + pragma Import (C, Set_DECL_CONTEXT); + pragma Import (C, Get_DECL_CONTEXT); + pragma Import (C, Get_DECL_INITIAL); + pragma Import (C, Set_DECL_INITIAL); + pragma Import (C, Get_DECL_NAME); + pragma Import (C, Set_DECL_ASSEMBLER_NAME, "set_DECL_ASSEMBLER_NAME"); + pragma Import (C, Get_DECL_ASSEMBLER_NAME); + pragma Import (C, Set_DECL_BUILT_IN_CLASS); + pragma Import (C, Set_DECL_FUNCTION_CODE); + pragma Import (C, Get_DECL_FIELD_OFFSET); + pragma Import (C, Get_DECL_FIELD_BIT_OFFSET); + + pragma Import (C, Get_BLOCK_SUPERCONTEXT); + pragma Import (C, Set_BLOCK_SUPERCONTEXT); + pragma Import (C, Set_BLOCK_VARS); + + pragma Import (C, Get_IDENTIFIER_LENGTH); + pragma Import (C, Get_IDENTIFIER_POINTER); + + pragma Import (C, Build_Common_Tree_Nodes); + pragma Import (C, Build_Common_Tree_Nodes_2); + + pragma Import (C, Input_Filename); + pragma Import (C, Main_Input_Filename); + pragma Import (C, Lineno); + + pragma Import (C, Tree_Identifier_Size); + + pragma Import (C, Make_Decl_Rtl); +end Agcc.Trees; diff --git a/ortho/agcc/agcc.adb b/ortho/agcc/agcc.adb new file mode 100644 index 0000000..da2fe43 --- /dev/null +++ b/ortho/agcc/agcc.adb @@ -0,0 +1,23 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package body Agcc is + function "+" (B : C_Bool) return Boolean is + begin + return B /= C_False; + end "+"; +end Agcc; diff --git a/ortho/agcc/agcc.ads b/ortho/agcc/agcc.ads new file mode 100644 index 0000000..c21745c --- /dev/null +++ b/ortho/agcc/agcc.ads @@ -0,0 +1,45 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with System; +with Interfaces.C; + +package Agcc is + pragma Pure (Agcc); + + subtype Chars is System.Address; + NULL_Chars : Chars renames System.Null_Address; + + Nul : constant Character := Character'Val (0); + + -- Names size_t. + type Size_T is new Interfaces.C.size_t; + + -- Ada representation of boolean type in C. + -- Never compare with C_TRUE, since in C any value different from 0 is + -- considered as true. + type C_Bool is new Integer; + pragma Convention (C, C_Bool); + + subtype C_Boolean is C_Bool range 0 .. 1; + + C_False : constant C_Bool := 0; + C_True : constant C_Bool := 1; + + function "+" (B : C_Bool) return Boolean; + pragma Inline ("+"); +end Agcc; diff --git a/ortho/agcc/agcc.sed b/ortho/agcc/agcc.sed new file mode 100644 index 0000000..9252e4a --- /dev/null +++ b/ortho/agcc/agcc.sed @@ -0,0 +1,23 @@ +# SED script used to extract lines enclosed in /* BEGIN ... END */ of a +# gnatbind C generated files. +# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold + +# If the current line starts with /* BEGIN, read next line and go to keep. +\@/* BEGIN@ { + n + b keep +} +# The current line is discarded, and a the cycle is restarted. +d + +# keep the lines. +: keep +# If the current line starts with END, then it is removed and a new cycle is +# started. +\@ END@ d +# Print the current line +p +# Read the next line +n +# Go to keep. +b keep diff --git a/ortho/agcc/c.adb b/ortho/agcc/c.adb new file mode 100644 index 0000000..1b88636 --- /dev/null +++ b/ortho/agcc/c.adb @@ -0,0 +1,55 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Unchecked_Conversion; +with System; + +package body C is + function C_String_Len (Str : C_String) return Natural is + begin + if Str = null then + return 0; + end if; + for I in Str'Range loop + if Str (I) = Character'Val (0) then + return I - 1; + end if; + end loop; + raise Program_Error; + end C_String_Len; + + function Image (Str : C_Str_Len) return String is + begin + if Str.Str = null then + return ''' & Character'Val (Str.Len) & '''; + else + return Str.Str (1 .. Str.Len); + end if; + end Image; + + function To_C_String (Acc : access String) return C_String + is + function Unchecked_Conversion is new Ada.Unchecked_Conversion + (Source => System.Address, Target => C_String); + begin + -- Check ACC is nul-terminated. + if Acc (Acc.all'Last) /= Character'Val (0) then + raise Program_Error; + end if; + return Unchecked_Conversion (Acc (Acc.all'First)'Address); + end To_C_String; +end C; diff --git a/ortho/agcc/c.ads b/ortho/agcc/c.ads new file mode 100644 index 0000000..01ff030 --- /dev/null +++ b/ortho/agcc/c.ads @@ -0,0 +1,64 @@ +-- Ada bindings for GCC internals. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Unchecked_Conversion; +with System; + +package C is + pragma Preelaborate (C); + + -- 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); + + -- Convert an address to a C_STRING. + function To_C_String is new Ada.Unchecked_Conversion + (Source => System.Address, Target => C_String); + + -- NULL for a string. + C_String_Null : constant C_String; + + -- Convert an Ada access string to a C_String. + -- This simply takes the address of the first character of ACC. This + -- is unchecked, so be careful with the life of ACC. + -- The last element of the string designated by ACC must be the NUL-char. + -- This is a little bit more restrictive than being only NUL-terminated. + function To_C_String (Acc : access String) return C_String; + + -- Return the length of a C String (ie, the number of characters before + -- the Nul). + function C_String_Len (Str : C_String) return Natural; + + -- An (very large) array of C String. This is the type of ARGV. + type C_String_Array is array (Natural) of C_String; + pragma Convention (C, C_String_Array); + + -- A structure for a string (len and address). + type C_Str_Len is record + Len : Natural; + Str : C_String; + end record; + pragma Convention (C_Pass_By_Copy, C_Str_Len); + + type C_Str_Len_Acc is access C_Str_Len; + + function Image (Str : C_Str_Len) return String; +private + C_String_Null : constant C_String := null; +end C; diff --git a/ortho/agcc/gen_tree.c b/ortho/agcc/gen_tree.c new file mode 100644 index 0000000..ff826b4 --- /dev/null +++ b/ortho/agcc/gen_tree.c @@ -0,0 +1,575 @@ +/* Ada bindings for GCC internals - generate Ada files. + Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "flags.h" +#include "tree.h" +#include "real.h" +#include "options.h" +#undef abort + +static const char *progname; + +/* Taken from tree.h. */ + + +#define XSTR(X) #X +#define STR(X) XSTR(X) +static const char *treecode_sym[] = +{ +#define DEFTREECODE(SYM, STRING, TYPE, NARGS) #SYM, +#include "tree.def" +#undef DEFTREECODE + NULL +}; + +static const char *treecode_string[] = +{ +#define DEFTREECODE(SYM, STRING, TYPE, NARGS) STRING, +#include "tree.def" +#undef DEFTREECODE + NULL +}; + +void +gen_tree_code (void) +{ + int i, j; + size_t len; + const size_t indent = 24; + + for (i = 0; treecode_sym[i] != NULL; i++) + { + len = strlen (treecode_sym[i]); + printf (" %s, ", treecode_sym[i]); + for (j = len; j < indent; j++) + putchar (' '); + printf ("-- %s\n", treecode_string[i]); + } + printf (" LAST_AND_UNUSED_TREE_CODE\n"); +} + +static const char *built_in_function_sym[] = +{ +#if 0 +#define DEF_BUILTIN(x) #x, +#else +#define DEF_BUILTIN(ENUM, N, C, T, LT, B, F, NA, ATTR, IMP) #ENUM, +#endif +#include "builtins.def" +#undef DEF_BUILTIN + NULL +}; + +static void +print_underscore (const char *sym) +{ + for (; *sym != 0; sym++) + { + if (sym[0] == '_' && (sym[1] == '_' || sym[1] == 0)) + fputs ("_u", stdout); + else + fputc (sym[0], stdout); + } +} + +void +gen_built_in_function (void) +{ + int i; + + for (i = 0; built_in_function_sym[i] != NULL; i++) + { + fputs (" ", stdout); + print_underscore (built_in_function_sym[i]); + fputs (",\n", stdout); + } + + printf (" END_BUILTINS\n"); +} + +#if 0 +static const char *machmode_sym[] = +{ +#if 0 +#define DEF_MACHMODE(SYM, NAME, TYPE, BITSIZE, SIZE, UNIT, WIDER) #SYM, +#else +#define DEF_MACHMODE(SYM, NAME, TYPE, BITSIZE, SIZE, UNIT, WIDER, INNER) \ + #SYM, +#endif +#include "machmode.def" +#undef DEF_MACHMODE + NULL +}; +#endif + +static void +gen_machmode (void) +{ + int i; + char line[128]; + FILE *f; + int do_emit; + char *p; + + f = fopen ("insn-modes.h", "r"); + if (f == NULL) + { + fprintf (stderr, "cannot open insn-modes\n"); + exit (1); + } + + do_emit = 0; + while (1) + { + if (fgets (line, sizeof (line), f) == NULL) + break; + if (!do_emit) + { + if (strncmp (line, "enum machine_mode", 17) == 0) + do_emit = 1; + } + else if (memcmp (line, " MAX_MACHINE_MODE,", 19) == 0) + { + fclose (f); + break; + } + else + { + /* Search for " [A-Z0-9_]*mode,". */ + p = line; + if (p[0] != ' ' || p[1] != ' ') + continue; + p += 2; + while ((*p >= 'A' && *p <= 'Z') + || (*p >= '0' && *p <= '9') + || (*p == '_')) + p++; + if (memcmp (p, "mode,", 5) == 0) + { + p[4] = 0; + printf (" %s,\n", line + 2); + } + } + + } + printf (" MAX_MACHINE_MODE\n"); +} + +static void +gen_options_CL (void) +{ + printf (" CL_C : constant Integer := %d;\n", CL_C); + printf (" CL_vhdl : constant Integer := %d;\n", CL_vhdl); +} + +static void +gen_options_OPTs (void) +{ + char line[128]; + FILE *f; + int do_emit; + char *p; + + f = fopen ("options.h", "r"); + if (f == NULL) + { + fprintf (stderr, "cannot open options.h\n"); + exit (1); + } + + do_emit = 0; + while (1) + { + if (fgets (line, sizeof (line), f) == NULL) + break; + if (!do_emit) + { + if (strncmp (line, "enum opt_code", 13) == 0) + do_emit = 1; + } + else if (memcmp (line, " N_OPTS", 9) == 0) + { + fclose (f); + break; + } + else + { + /* Search for " [A-Z0-9]*mode,". */ + p = line; + if (memcmp (p, " OPT_", 6) != 0) + continue; + printf (" OPT"); + for (p = line + 5; *p != ','; p++) + { + if (p[0] == '_' && (p[1] == ',' || p[1] == '_')) + fputs ("_U", stdout); + else + { + if (p[0] >= 'A' && p[0] <= 'Z') + putchar ('U'); + putchar (p[0]); + } + } + printf (",\n"); + } + + } + printf (" N_OPTS\n"); +} + +struct xtab_t +{ + int val; + const char *name; +}; + +void +gen_enumeration (const struct xtab_t *xtab, int max, const char *max_name) +{ + int i; + + for (i = 0; i < max; i++) + { + const struct xtab_t *t; + + for (t = xtab; t->name; t++) + if (t->val == i) + break; + + if (t->name == NULL) + { + fprintf (stderr, "gen_enumeration: kind %d unknown (max is %s)\n", + i, max_name); + exit (1); + } + + printf (" %s,\n", t->name); + } + printf (" %s\n", max_name); +} + +const struct xtab_t size_type_names[] = +{ + { SIZETYPE, "TK_SIZETYPE" }, + { SSIZETYPE, "TK_SSIZETYPE" }, + { USIZETYPE, "TK_USIZETYPE" }, + { BITSIZETYPE, "TK_BITSIZETYPE" }, + { SBITSIZETYPE, "TK_SBITSIZETYPE" }, + { UBITSIZETYPE, "TK_UBITSIZETYPE" }, + { 0, NULL} +}; + +static void +gen_size_type (void) +{ + gen_enumeration (size_type_names, TYPE_KIND_LAST, "TYPE_KIND_LAST"); +} + + +const struct xtab_t type_qual_tab[] = +{ + { TYPE_UNQUALIFIED, "TYPE_UNQUALIFIED" }, + { TYPE_QUAL_CONST, "TYPE_QUAL_CONST" }, + { TYPE_QUAL_VOLATILE, "TYPE_QUAL_VOLATILE" }, + { TYPE_QUAL_RESTRICT, "TYPE_QUAL_RESTRICT" }, + { 0, NULL} +}; + +void +gen_type_qual (void) +{ + const struct xtab_t *t; + for (t = type_qual_tab; t->name; t++) + printf (" %s : constant Type_Qual_Type := %d;\n", t->name, t->val); +} + +const struct xtab_t tree_index_tab[] = +{ + /* Defined in tree.h */ + { TI_ERROR_MARK, "TI_ERROR_MARK" }, + { TI_INTQI_TYPE, "TI_INTQI_TYPE" }, + { TI_INTHI_TYPE, "TI_INTHI_TYPE" }, + { TI_INTSI_TYPE, "TI_INTSI_TYPE" }, + { TI_INTDI_TYPE, "TI_INTDI_TYPE" }, + { TI_INTTI_TYPE, "TI_INTTI_TYPE" }, + + { TI_UINTQI_TYPE, "TI_UINTQI_TYPE" }, + { TI_UINTHI_TYPE, "TI_UINTHI_TYPE" }, + { TI_UINTSI_TYPE, "TI_UINTSI_TYPE" }, + { TI_UINTDI_TYPE, "TI_UINTDI_TYPE" }, + { TI_UINTTI_TYPE, "TI_UINTTI_TYPE" }, + + { TI_INTEGER_ZERO, "TI_INTEGER_ZERO" }, + { TI_INTEGER_ONE, "TI_INTEGER_ONE" }, + { TI_INTEGER_MINUS_ONE, "TI_INTEGER_MINUS_ONE" }, + { TI_NULL_POINTER, "TI_NULL_POINTER" }, + + { TI_SIZE_ZERO, "TI_SIZE_ZERO" }, + { TI_SIZE_ONE, "TI_SIZE_ONE" }, + + { TI_BITSIZE_ZERO, "TI_BITSIZE_ZERO" }, + { TI_BITSIZE_ONE, "TI_BITSIZE_ONE" }, + { TI_BITSIZE_UNIT, "TI_BITSIZE_UNIT" }, + + { TI_PUBLIC, "TI_PUBLIC" }, + { TI_PROTECTED, "TI_PROTECTED" }, + { TI_PRIVATE, "TI_PRIVATE" }, + + { TI_BOOLEAN_FALSE, "TI_BOOLEAN_FALSE" }, + { TI_BOOLEAN_TRUE, "TI_BOOLEAN_TRUE" }, + + { TI_COMPLEX_INTEGER_TYPE, "TI_COMPLEX_INTEGER_TYPE" }, + { TI_COMPLEX_FLOAT_TYPE, "TI_COMPLEX_FLOAT_TYPE" }, + { TI_COMPLEX_DOUBLE_TYPE, "TI_COMPLEX_DOUBLE_TYPE" }, + { TI_COMPLEX_LONG_DOUBLE_TYPE, "TI_COMPLEX_LONG_DOUBLE_TYPE" }, + + { TI_FLOAT_TYPE, "TI_FLOAT_TYPE" }, + { TI_DOUBLE_TYPE, "TI_DOUBLE_TYPE" }, + { TI_LONG_DOUBLE_TYPE, "TI_LONG_DOUBLE_TYPE" }, + + { TI_FLOAT_PTR_TYPE, "TI_FLOAT_PTR_TYPE" }, + { TI_DOUBLE_PTR_TYPE, "TI_DOUBLE_PTR_TYPE" }, + { TI_LONG_DOUBLE_PTR_TYPE, "TI_LONG_DOUBLE_PTR_TYPE" }, + { TI_INTEGER_PTR_TYPE, "TI_INTEGER_PTR_TYPE" }, + + { TI_VOID_TYPE, "TI_VOID_TYPE" }, + { TI_PTR_TYPE, "TI_PTR_TYPE" }, + { TI_CONST_PTR_TYPE, "TI_CONST_PTR_TYPE" }, + { TI_SIZE_TYPE, "TI_SIZE_TYPE" }, + { TI_PTRDIFF_TYPE, "TI_PTRDIFF_TYPE" }, + { TI_VA_LIST_TYPE, "TI_VA_LIST_TYPE" }, + { TI_BOOLEAN_TYPE, "TI_BOOLEAN_TYPE" }, + + { TI_VOID_LIST_NODE, "TI_VOID_LIST_NODE" }, + + { TI_UV4SF_TYPE, "TI_UV4SF_TYPE" }, + { TI_UV4SI_TYPE, "TI_UV4SI_TYPE" }, + { TI_UV8HI_TYPE, "TI_UV8HI_TYPE" }, + { TI_UV8QI_TYPE, "TI_UV8QI_TYPE" }, + { TI_UV4HI_TYPE, "TI_UV4HI_TYPE" }, + { TI_UV2HI_TYPE, "TI_UV2HI_TYPE" }, + { TI_UV2SI_TYPE, "TI_UV2SI_TYPE" }, + { TI_UV2SF_TYPE, "TI_UV2SF_TYPE" }, + { TI_UV2DI_TYPE, "TI_UV2DI_TYPE" }, + { TI_UV1DI_TYPE, "TI_UV1DI_TYPE" }, + { TI_UV16QI_TYPE, "TI_UV16QI_TYPE" }, + + { TI_V4SF_TYPE, "TI_V4SF_TYPE" }, + { TI_V16SF_TYPE, "TI_V16SF_TYPE" }, + { TI_V4SI_TYPE, "TI_V4SI_TYPE" }, + { TI_V8HI_TYPE, "TI_V8HI_TYPE" }, + { TI_V8QI_TYPE, "TI_V8QI_TYPE" }, + { TI_V4HI_TYPE, "TI_V4HI_TYPE" }, + { TI_V2HI_TYPE, "TI_V2HI_TYPE" }, + { TI_V2SI_TYPE, "TI_V2SI_TYPE" }, + { TI_V2SF_TYPE, "TI_V2SF_TYPE" }, + { TI_V2DF_TYPE, "TI_V2DF_TYPE" }, + { TI_V2DI_TYPE, "TI_V2DI_TYPE" }, + { TI_V1DI_TYPE, "TI_V1DI_TYPE" }, + { TI_V16QI_TYPE, "TI_V16QI_TYPE" }, + { TI_V4DF_TYPE, "TI_V4DF_TYPE" }, + + { TI_MAIN_IDENTIFIER, "TI_MAIN_IDENTIFIER" }, + + { 0, NULL } +}; + +const struct xtab_t integer_types_tab[] = +{ + { itk_char, "itk_char" }, + { itk_signed_char, "itk_signed_char" }, + { itk_unsigned_char, "itk_unsigned_char" }, + { itk_short, "itk_short" }, + { itk_unsigned_short, "itk_unsigned_short" }, + { itk_int, "itk_int" }, + { itk_unsigned_int, "itk_unsigned_int" }, + { itk_long, "itk_long" }, + { itk_unsigned_long, "itk_unsigned_long" }, + { itk_long_long, "itk_long_long" }, + { itk_unsigned_long_long, "itk_unsigned_long_long" }, + { 0, NULL } +}; + + +void +gen_tree_index (void) +{ + gen_enumeration (tree_index_tab, TI_MAX, "TI_MAX"); +} + +void +gen_integer_types (void) +{ + gen_enumeration (integer_types_tab, itk_none, "itk_none"); +} + +static void +gen_host_wide_int_decl (void) +{ + int l; + switch (sizeof (HOST_WIDE_INT)) + { + case 4: + l = 32; + break; + case 8: + l = 64; + break; + default: + fprintf (stderr, "%s: cannot handle sizeof (HOST_WIDE_INT) %d\n", + progname, sizeof (HOST_WIDE_INT)); + exit (1); + } + printf (" type HOST_WIDE_INT is new Interfaces.Integer_%d;\n", l); + printf (" type UNSIGNED_HOST_WIDE_INT is new Interfaces.Unsigned_%d;\n", + l); +} + +static void +gen_host_big_endian (void) +{ +#ifdef HOST_WORDS_BIG_ENDIAN + printf (" HOST_WORDS_BIG_ENDIAN : constant Boolean := True;\n"); +#else + printf (" HOST_WORDS_BIG_ENDIAN : constant Boolean := False;\n"); +#endif +} + +static void +gen_real (void) +{ + printf (" type Real_Value_Type_Arr is array (0 .. %d) of HOST_WIDE_INT;\n", + (sizeof (REAL_VALUE_TYPE) / sizeof (HOST_WIDE_INT)) - 1); + printf (" type REAL_VALUE_TYPE is record\n" + " r : Real_Value_Type_Arr;\n" + " end record;\n"); +} + +static void +gen_tm (void) +{ +#ifndef MAX_BITS_PER_WORD +#define MAX_BITS_PER_WORD BITS_PER_WORD +#endif + /* This is a constant. */ + printf (" MAX_BITS_PER_WORD : constant Natural := %d;\n", + MAX_BITS_PER_WORD); +} + +int +main (int argc, char *argv[]) +{ + FILE *infile; + char line[2048]; + const char *filename; + int c; + + progname = argv[0]; + + while ((c = getopt (argc, argv, "C:")) != -1) + switch (c) + { + case 'C': + chdir (optarg); + break; + case '?': + fprintf (stderr, "%s: unknown option '%s'\n", progname, optopt); + exit (1); + default: + abort (); + } + + if (argc - optind != 1) + { + fprintf (stderr, "usage: %s FILENAME\n", progname); + exit (1); + } + filename = argv[optind]; + if (strcmp (filename, "-") == 0) + infile = stdin; + else + infile = fopen (filename, "r"); + if (infile == NULL) + { + fprintf (stderr, "%s: cannot open %s (%s)\n", progname, filename, + strerror (errno)); + exit (1); + } +#if 0 +#ifdef REAL_IS_NOT_DOUBLE + printf ("-- REAL_IS_NOT_DOUBLE is not yet implemented\n"); + printf ("You loose\n"); + return 1; +#endif +#endif + printf ("-- Automatically generated by %s\n", progname); + printf ("-- from %s\n", filename); + printf ("-- DO NOT EDIT THIS FILE\n"); + + while (fgets (line, sizeof (line), infile) != NULL) + { + if (line[0] != '@') + fputs (line, stdout); + else + { + char *p; + + for (p = line + 1; isalpha (*p) || *p == '_'; p++) + ; + *p = 0; + + if (!strcmp (line, "@tree_code")) + gen_tree_code (); + else if (!strcmp (line, "@built_in_function")) + gen_built_in_function (); + else if (!strcmp (line, "@size_type_kind")) + gen_size_type (); + else if (!strcmp (line, "@type_qual")) + gen_type_qual (); + else if (!strcmp (line, "@host_wide_int")) + gen_host_wide_int_decl (); + else if (!strcmp (line, "@tree_index")) + gen_tree_index (); + else if (!strcmp (line, "@integer_types")) + gen_integer_types (); + else if (!strcmp (line, "@host_big_endian")) + gen_host_big_endian (); + else if (!strcmp (line, "@real")) + gen_real (); + else if (!strcmp (line, "@machmode")) + gen_machmode (); + else if (!strcmp (line, "@tm")) + gen_tm (); + else if (!strcmp (line, "@options_CL")) + gen_options_CL (); + else if (!strcmp (line, "@options_OPTs")) + gen_options_OPTs (); + else + { + fprintf (stderr, "unknown code `%s'\n", line); + exit (1); + } + } + } + return 0; +} |