diff options
author | Tristan Gingold | 2014-03-12 03:44:18 +0100 |
---|---|---|
committer | Tristan Gingold | 2014-03-12 03:44:18 +0100 |
commit | 8fc7559a26a3c634b7c87ada03744f5f31637b32 (patch) | |
tree | 125b7264888d5f87f72865f20bda953a120846e8 /ortho | |
parent | 0594d17c40ce054f61d2a5679e377467ebc7c796 (diff) | |
download | ghdl-8fc7559a26a3c634b7c87ada03744f5f31637b32.tar.gz ghdl-8fc7559a26a3c634b7c87ada03744f5f31637b32.tar.bz2 ghdl-8fc7559a26a3c634b7c87ada03744f5f31637b32.zip |
Remove old and unused agcc and gcc34 subdirs.
Diffstat (limited to 'ortho')
41 files changed, 0 insertions, 6789 deletions
diff --git a/ortho/agcc/Makefile.inc b/ortho/agcc/Makefile.inc deleted file mode 100644 index b5da6f0..0000000 --- a/ortho/agcc/Makefile.inc +++ /dev/null @@ -1,112 +0,0 @@ -# -*- 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 deleted file mode 100644 index 30eb1e6..0000000 --- a/ortho/agcc/agcc-autils.adb +++ /dev/null @@ -1,93 +0,0 @@ --- 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 deleted file mode 100644 index 8ca7da4..0000000 --- a/ortho/agcc/agcc-autils.ads +++ /dev/null @@ -1,28 +0,0 @@ --- 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 deleted file mode 100644 index 2dbe33b..0000000 --- a/ortho/agcc/agcc-bindings.c +++ /dev/null @@ -1,738 +0,0 @@ -/* 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 deleted file mode 100644 index 964dd81..0000000 --- a/ortho/agcc/agcc-convert.ads +++ /dev/null @@ -1,26 +0,0 @@ --- 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 deleted file mode 100644 index 4558896..0000000 --- a/ortho/agcc/agcc-diagnostic.ads +++ /dev/null @@ -1,24 +0,0 @@ --- 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 deleted file mode 100644 index 7c2b110..0000000 --- a/ortho/agcc/agcc-fe.ads +++ /dev/null @@ -1,238 +0,0 @@ --- 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 deleted file mode 100644 index 4892d59..0000000 --- a/ortho/agcc/agcc-ggc.ads +++ /dev/null @@ -1,33 +0,0 @@ --- 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 deleted file mode 100644 index 211d5e0..0000000 --- a/ortho/agcc/agcc-ghdl.c +++ /dev/null @@ -1,658 +0,0 @@ -/* 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 deleted file mode 100644 index 3662c95..0000000 --- a/ortho/agcc/agcc-hconfig.ads.in +++ /dev/null @@ -1,21 +0,0 @@ --- 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 deleted file mode 100644 index 245f211..0000000 --- a/ortho/agcc/agcc-hwint.ads.in +++ /dev/null @@ -1,23 +0,0 @@ --- 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 deleted file mode 100644 index d7ff5ec..0000000 --- a/ortho/agcc/agcc-input.ads +++ /dev/null @@ -1,29 +0,0 @@ --- 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 deleted file mode 100644 index 89784b7..0000000 --- a/ortho/agcc/agcc-libiberty.ads +++ /dev/null @@ -1,21 +0,0 @@ --- 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 deleted file mode 100644 index ccc6980..0000000 --- a/ortho/agcc/agcc-machmode.ads.in +++ /dev/null @@ -1,35 +0,0 @@ --- 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 deleted file mode 100644 index 8931edd..0000000 --- a/ortho/agcc/agcc-options.ads.in +++ /dev/null @@ -1,31 +0,0 @@ --- 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 deleted file mode 100644 index 6ecab6e..0000000 --- a/ortho/agcc/agcc-output.ads +++ /dev/null @@ -1,24 +0,0 @@ --- 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 deleted file mode 100644 index ec6b080..0000000 --- a/ortho/agcc/agcc-real.ads.in +++ /dev/null @@ -1,42 +0,0 @@ --- 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 deleted file mode 100644 index e45143a..0000000 --- a/ortho/agcc/agcc-rtl.ads +++ /dev/null @@ -1,31 +0,0 @@ --- 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 deleted file mode 100644 index aeaa4d7..0000000 --- a/ortho/agcc/agcc-stor_layout.ads +++ /dev/null @@ -1,24 +0,0 @@ --- 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 deleted file mode 100644 index 7fea03c..0000000 --- a/ortho/agcc/agcc-tm.ads.in +++ /dev/null @@ -1,37 +0,0 @@ --- 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 deleted file mode 100644 index a816f54..0000000 --- a/ortho/agcc/agcc-toplev.ads +++ /dev/null @@ -1,51 +0,0 @@ --- 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 deleted file mode 100644 index a13aba3..0000000 --- a/ortho/agcc/agcc-trees.adb +++ /dev/null @@ -1,33 +0,0 @@ --- 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 deleted file mode 100644 index 5eb2d58..0000000 --- a/ortho/agcc/agcc-trees.ads.in +++ /dev/null @@ -1,514 +0,0 @@ --- 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 deleted file mode 100644 index da2fe43..0000000 --- a/ortho/agcc/agcc.adb +++ /dev/null @@ -1,23 +0,0 @@ --- 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 deleted file mode 100644 index c21745c..0000000 --- a/ortho/agcc/agcc.ads +++ /dev/null @@ -1,45 +0,0 @@ --- 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 deleted file mode 100644 index 9252e4a..0000000 --- a/ortho/agcc/agcc.sed +++ /dev/null @@ -1,23 +0,0 @@ -# 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 deleted file mode 100644 index 1b88636..0000000 --- a/ortho/agcc/c.adb +++ /dev/null @@ -1,55 +0,0 @@ --- 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 deleted file mode 100644 index 01ff030..0000000 --- a/ortho/agcc/c.ads +++ /dev/null @@ -1,64 +0,0 @@ --- 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 deleted file mode 100644 index ff826b4..0000000 --- a/ortho/agcc/gen_tree.c +++ /dev/null @@ -1,575 +0,0 @@ -/* 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; -} diff --git a/ortho/gcc34/Makefile b/ortho/gcc34/Makefile deleted file mode 100644 index 9f8b327..0000000 --- a/ortho/gcc34/Makefile +++ /dev/null @@ -1,50 +0,0 @@ -# Makefile of ortho implementation for GCC. -# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold -# -# GHDL is free software; you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free -# Software Foundation; either version 2, or (at your option) any later -# version. -# -# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or -# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -# for more details. -# -# You should have received a copy of the GNU General Public License -# along with GCC; see the file COPYING. If not, write to the Free -# Software Foundation, 59 Temple Place - Suite 330, Boston, MA -# 02111-1307, USA. -ortho_srcdir=.. -orthobe_srcdir=$(ortho_srcdir)/gcc -agcc_srcdir=$(ortho_srcdir)/agcc -agcc_objdir=. -AGCC_GCCSRC_DIR:=$(HOME)/dist/gcc-3.4.3 -AGCC_GCCOBJ_DIR:=$(AGCC_GCCSRC_DIR)-objs -SED=sed - -all: $(ortho_exec) - -include $(agcc_srcdir)/Makefile.inc - -ORTHO_BASENAME=$(orthobe_srcdir)/ortho_gcc -ORTHO_PACKAGE=Ortho_Gcc - -include $(ortho_srcdir)/Makefile.inc - -$(ortho_exec): $(AGCC_DEPS) $(ORTHO_BASENAME).ads force - gnatmake -m -o $@ -g -aI$(agcc_srcdir) -aI$(ortho_srcdir) \ - -aI$(ortho_srcdir)/gcc $(GNAT_FLAGS) ortho_gcc-main \ - -bargs -E -largs $(AGCC_OBJS) #-static - -clean: agcc-clean - $(RM) -f *.o *.ali ortho_nodes-main - $(RM) b~*.ad? *~ - -distclean: clean agcc-clean - - -force: - -.PHONY: force all clean - diff --git a/ortho/gcc34/agcc-fe.adb b/ortho/gcc34/agcc-fe.adb deleted file mode 100644 index 75ba795..0000000 --- a/ortho/gcc34/agcc-fe.adb +++ /dev/null @@ -1,776 +0,0 @@ --- Ortho implementation for GCC. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Unchecked_Deallocation; ---with Agcc.Ggc; use Agcc.Ggc; -with Agcc.Tm; use Agcc.Tm; -with Agcc.Machmode; use Agcc.Machmode; -with Agcc.Diagnostic; -with Agcc.Input; use Agcc.Input; -with Agcc.Options; use Agcc.Options; -with Ortho_Gcc; -with Ortho_Gcc_Front; use Ortho_Gcc_Front; - -package body Agcc.Fe is - File_Name : String_Acc; - - Stdin_Filename : String_Acc := new String'("*stdin*" & Nul); - - function Lang_Init_Options (Argc : Integer; Argv : C_String_Array) - return Integer - is - pragma Unreferenced (Argc); - pragma Unreferenced (Argv); - begin - return CL_vhdl; - end Lang_Init_Options; - - function Lang_Handle_Option (Code : Opt_Code; - Arg : C_String; - Value : Integer) - return Integer - is - pragma Unreferenced (Value); - --type String_Acc_Array_Acc is access String_Acc_Array; - - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Name => String_Acc, Object => String); - --procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - -- (Name => String_Acc_Array_Acc, Object => String_Acc_Array); - - --C_Opt : C_String := Argv (0); - --C_Arg : C_String; - --Opt : String := C_Opt (1 .. C_String_Len (C_Opt)); - Res : Natural; - Opt : String_Acc; - Opt_Arg : String_Acc; - Len : Natural; - begin - if Arg /= C_String_Null then - Len := C_String_Len (Arg); - else - Len := 0; - end if; - Opt_Arg := null; - case Code is - when OPT_U_std_U => - Opt := new String'("--std=" & Arg (1 .. Len)); - when OPT_U_compile_standard => - Opt := new String'("--compile-standard"); - when OPT_U_bootstrap => - Opt := new String'("--bootstrap"); - when OPT_U_work_U => - Opt := new String'("--work=" & Arg (1 .. Len)); - when OPT_U_workdir_U => - Opt := new String'("--workdir=" & Arg (1 .. Len)); - when OPT_UP => - Opt := new String'("-P" & Arg (1 .. Len)); - when OPT_U_elab => - Opt := new String'("--elab"); - Opt_Arg := new String'(Arg (1 .. Len)); - when OPT_U_anaelab => - Opt := new String'("--anaelab"); - Opt_Arg := new String'(Arg (1 .. Len)); - when OPT_l => - Opt := new String'("-l"); - Opt_Arg := new String'(Arg (1 .. Len)); - when OPT_c => - Opt := new String'("-c"); - Opt_Arg := new String'(Arg (1 .. Len)); - when OPT_U_ghdl => - Opt := new String'(Arg (1 .. Len)); - when OPT_U_warn_U => - Opt := new String'("--warn-" & Arg (1 .. Len)); - when OPT_U_expect_failure => - Opt := new String'("--expect-failure"); - when OPT_U_no_vital_checks => - Opt := new String'("--no-vital-checks"); - when OPT_U_vital_checks => - Opt := new String'("--vital-checks"); - when OPT_fexplicit => - Opt := new String'("-fexplicit"); - when OPT_v => - Opt := new String'("-v"); - when others => - return 0; - end case; - Res := Ortho_Gcc_Front.Decode_Option (Opt, Opt_Arg); - Unchecked_Deallocation (Opt); - Unchecked_Deallocation (Opt_Arg); - return Res; - end Lang_Handle_Option; - - function Lang_Post_Options (Filename : C_String_Acc) return C_Bool - is - Filename_Len : Natural; - begin - if Filename.all = C_String_Null then - File_Name := null; - Filename.all := To_C_String (Stdin_Filename); - else - Filename_Len := C_String_Len (Filename.all); - File_Name := new String'(Filename.all (1 .. Filename_Len)); - end if; - - -- Run the back-end. - return C_False; - end Lang_Post_Options; - - - procedure Lang_Parse_File (Debug : C_Bool) - is - pragma Unreferenced (Debug); - begin - if not Ortho_Gcc_Front.Parse (File_Name) then - Agcc.Diagnostic.Set_Errorcount (1); - end if; - end Lang_Parse_File; - - function Lang_Get_Alias_Set (T : Tree) return HOST_WIDE_INT - is - pragma Unreferenced (T); - begin - return -1; - end Lang_Get_Alias_Set; - - --function Lang_Safe_From_P (Target : Rtx; Exp : Tree) return Boolean; - - function Mark_Addressable (Exp : Tree) return C_Bool - is - N : Tree; - Code : Tree_Code; - begin - N := Exp; - loop - Code := Get_TREE_CODE (N); - case Code is - when VAR_DECL - | CONST_DECL - | PARM_DECL - | RESULT_DECL => - Put_Var_Into_Stack (N, C_True); - Set_TREE_ADDRESSABLE (N, C_True); - return C_True; - - when COMPONENT_REF - | ARRAY_REF => - N := Get_TREE_OPERAND (N, 0); - - when FUNCTION_DECL - | CONSTRUCTOR => - Set_TREE_ADDRESSABLE (N, C_True); - return C_True; - - when INDIRECT_REF => - return C_True; - - when others => - raise Program_Error; - end case; - end loop; - end Mark_Addressable; - - procedure Insert_Default_Attributes (Func : Tree) - is - pragma Unreferenced (Func); - begin - null; - end Insert_Default_Attributes; - - -- These functions and variables deal with binding contours. - - -- For each binding contour we allocate a binding_level structure which - -- records the entities defined or declared in that contour. - -- Contours include: - -- - -- the global one - -- one for each subprogram definition - -- one for each compound statement (declare block) - -- - -- Binding contours are used to create GCC tree BLOCK nodes. - - -- BE CAREFUL: this structure is also declared in agcc-bindings.c - type Binding_Level; - type Binding_Level_Acc is access Binding_Level; - type Binding_Level is record - -- A chain of ..._DECL nodes for all variables, constants, functions, - -- parameters and type declarations. These ..._DECL nodes are chained - -- through the TREE_CHAIN field. Note that these ..._DECL nodes are - -- stored in the reverse of the order supplied to be compatible with - -- the back-end. - Names : Tree; - - -- For each level (except the global one), a chain of BLOCK nodes for - -- all the levels that were entered and exited one level down from this - -- one. - Blocks : Tree; - - -- The back end may need, for its own internal processing, to create a - -- BLOCK node. This field is set aside for this purpose. If this field - -- is non-null when the level is popped, i.e. when poplevel is invoked, - -- we will use such block instead of creating a new one from the - -- 'names' field, that is the ..._DECL nodes accumulated so far. - -- Typically the routine 'pushlevel' will be called before setting this - -- field, so that if the front-end had inserted ..._DECL nodes in the - -- current block they will not be lost. - Block_Created_By_Back_End : Tree; - - -- The binding level containing this one (the enclosing binding level). - Level_Chain : Binding_Level_Acc; - end record; - pragma Convention (C, Binding_Level_Acc); - pragma Convention (C, Binding_Level); - - -- The binding level currently in effect. - Current_Binding_Level : Binding_Level_Acc := null; - pragma Export (C, Current_Binding_Level); - - -- The outermost binding level. This binding level is created when the - -- compiler is started and it will exist through the entire compilation. - Global_Binding_Level : Binding_Level_Acc; - - -- Chain of unused binding levels, since they are never deallocated. - Old_Binding_Level : Binding_Level_Acc := null; - pragma Export (C, Old_Binding_Level); - - function Alloc_Binding_Level return Binding_Level_Acc; - pragma Import (C, Alloc_Binding_Level); - - -- Binding level structures are initialized by copying this one. - Clear_Binding_Level : constant Binding_Level := - (Names => NULL_TREE, - Blocks => NULL_TREE, - Block_Created_By_Back_End => NULL_TREE, - Level_Chain => null); - - -- Return non-zero if we are currently in the global binding level. - function Global_Bindings_P return Integer is - begin - if Current_Binding_Level = Global_Binding_Level then - return 1; - else - return 0; - end if; - end Global_Bindings_P; - - -- Return the list of declarations in the current level. Note that this - -- list is in reverse order (it has to be so for back-end compatibility). - function Getdecls return Tree is - begin - return Current_Binding_Level.Names; - end Getdecls; - - -- Nonzero if the current level needs to have a BLOCK made. --- function Kept_Level_P return Boolean is --- begin --- return Current_Binding_Level.Names /= NULL_TREE; --- end Kept_Level_P; - - -- Enter a new binding level. The input parameter is ignored, but has to - -- be specified for back-end compatibility. - procedure Pushlevel (Inside : C_Bool) - is - pragma Unreferenced (Inside); - Newlevel : Binding_Level_Acc; - - begin - if Old_Binding_Level /= null then - Newlevel := Old_Binding_Level; - Old_Binding_Level := Old_Binding_Level.Level_Chain; - else - Newlevel := Alloc_Binding_Level; - end if; - Newlevel.all := Clear_Binding_Level; - - -- Add this level to the front of the chain (stack) of levels that are - -- active. - Newlevel.Level_Chain := Current_Binding_Level; - Current_Binding_Level := Newlevel; - end Pushlevel; - - -- Exit a binding level. - -- Pop the level off, and restore the state of the identifier-decl mappings - -- that were in effect when this level was entered. - -- - -- If KEEP is nonzero, this level had explicit declarations, so - -- and create a "block" (a BLOCK node) for the level - -- to record its declarations and subblocks for symbol table output. - -- - -- If FUNCTIONBODY is nonzero, this level is the body of a function, - -- so create a block as if KEEP were set and also clear out all - -- label names. - -- - -- If REVERSE is nonzero, reverse the order of decls before putting - -- them into the BLOCK. - function Exported_Poplevel - (Keep : C_Bool; Revers : C_Bool; Functionbody : C_Bool) - return Tree - is - -- Points to a BLOCK tree node. This is the BLOCK node construted for - -- the binding level that we are about to exit and which is returned - -- by this routine. - Block_Node : Tree := NULL_TREE; - - Decl_Chain : Tree; - Subblock_Chain : Tree; - Subblock_Node : Tree; - Block_Created_By_Back_End : Tree; - - N : Tree; - Tmp : Binding_Level_Acc; - begin - Decl_Chain := Current_Binding_Level.Names; - Block_Created_By_Back_End := - Current_Binding_Level.Block_Created_By_Back_End; - Subblock_Chain := Current_Binding_Level.Blocks; - - -- Pop the current level, and save it on the chain of old binding - -- levels. - Tmp := Current_Binding_Level; - Current_Binding_Level := Tmp.Level_Chain; - Tmp.Level_Chain := Old_Binding_Level; - Old_Binding_Level := Tmp; - - -- Reverse the list of XXXX_DECL nodes if desired. Note that - -- the ..._DECL nodes chained through the `names' field of - -- current_binding_level are in reverse order except for PARM_DECL node, - -- which are explicitely stored in the right order. - if Revers /= C_False then - Decl_Chain := Nreverse (Decl_Chain); - end if; - - if Block_Created_By_Back_End /= NULL_TREE then - Block_Node := Block_Created_By_Back_End; - - -- Check if we are about to discard some information that was - -- gathered by the front-end. Nameley check if the back-end created - -- a new block without calling pushlevel first. To understand why - -- things are lost just look at the next case (i.e. no block - -- created by back-end. */ - if (Keep /= C_False or Functionbody /= C_False) - and then (Decl_Chain /= NULL_TREE or Subblock_Chain /= NULL_TREE) - then - raise Program_Error; - end if; - elsif Keep /= C_False or Functionbody /= C_False then - -- If there were any declarations in the current binding level, or if - -- this binding level is a function body, or if there are any nested - -- blocks then create a BLOCK node to record them for the life of - -- this function. - if Keep /= C_False then - N := Decl_Chain; - else - N := NULL_TREE; - end if; - Block_Node := Build_Block - (N, NULL_TREE, Subblock_Chain, NULL_TREE, NULL_TREE); - end if; - - -- Record the BLOCK node just built as the subblock its enclosing scope. - Subblock_Node := Subblock_Chain; - while Subblock_Node /= NULL_TREE loop - Set_BLOCK_SUPERCONTEXT (Subblock_Node, Block_Node); - Subblock_Node := Get_TREE_CHAIN (Subblock_Node); - end loop; - - -- Clear out the meanings of the local variables of this level. - Subblock_Node := Decl_Chain; - while Subblock_Node /= NULL_TREE loop - - if Get_DECL_NAME (Subblock_Node) /= NULL_TREE then - -- If the identifier was used or addressed via a local - -- extern decl, don't forget that fact. - if Get_DECL_EXTERNAL (Subblock_Node) /= C_False then - if Get_TREE_USED (Subblock_Node) /= C_False then - Set_TREE_USED (Get_DECL_NAME (Subblock_Node), C_True); - end if; - if Get_TREE_ADDRESSABLE (Subblock_Node) /= C_False then - Set_TREE_ADDRESSABLE - (Get_DECL_ASSEMBLER_NAME (Subblock_Node), C_True); - end if; - end if; - end if; - Subblock_Node := Get_TREE_CHAIN (Subblock_Node); - end loop; - - if Functionbody /= C_False then - -- This is the top level block of a function. The ..._DECL chain - -- stored in BLOCK_VARS are the function's parameters (PARM_DECL - -- nodes). Don't leave them in the BLOCK because they are found - -- in the FUNCTION_DECL instead. - Set_DECL_INITIAL (Current_Function_Decl, Block_Node); - Set_BLOCK_VARS (Block_Node, NULL_TREE); - elsif Block_Node /= NULL_TREE then - if Block_Created_By_Back_End = NULL_TREE then - Current_Binding_Level.Blocks - := Chainon (Current_Binding_Level.Blocks, Block_Node); - end if; - elsif Subblock_Chain /= NULL_TREE then - -- If we did not make a block for the level just exited, any blocks - -- made for inner levels (since they cannot be recorded as subblocks - -- in that level) must be carried forward so they will later become - -- subblocks of something else. - Current_Binding_Level.Blocks - := Chainon (Current_Binding_Level.Blocks, Subblock_Chain); - end if; - - if Block_Node /= NULL_TREE then - Set_TREE_USED (Block_Node, C_True); - end if; - - return Block_Node; - end Exported_Poplevel; - - -- Insert BLOCK at the end of the list of subblocks of the - -- current binding level. This is used when a BIND_EXPR is expanded, - -- to handle the BLOCK node inside the BIND_EXPR. - procedure Insert_Block (Block : Tree) is - begin - Set_TREE_USED (Block, C_True); - Current_Binding_Level.Blocks - := Chainon (Current_Binding_Level.Blocks, Block); - end Insert_Block; - - -- Set the BLOCK node for the innermost scope (the one we are - -- currently in). - procedure Set_Block (Block : Tree) is - begin - Current_Binding_Level.Block_Created_By_Back_End := Block; - end Set_Block; - - -- Records a ..._DECL node DECL as belonging to the current lexical scope. - -- Returns the ..._DECL node. - function Exported_Pushdecl (Decl : Tree) return Tree - is - begin - -- External objects aren't nested, other objects may be. - if Get_DECL_EXTERNAL (Decl) /= C_False then - Set_DECL_CONTEXT (Decl, NULL_TREE); - else - Set_DECL_CONTEXT (Decl, Current_Function_Decl); - end if; - - -- Put the declaration on the list. The list of declarations is in - -- reverse order. The list will be reversed later if necessary. This - -- needs to be this way for compatibility with the back-end. - Set_TREE_CHAIN (Decl, Current_Binding_Level.Names); - Current_Binding_Level.Names := Decl; - - -- For the declaration of a type, set its name if it is not already set. - if Get_TREE_CODE (Decl) = TYPE_DECL - and then Get_TYPE_NAME (Get_TREE_TYPE (Decl)) = NULL_TREE - then - Set_TYPE_NAME (Get_TREE_TYPE (Decl), Decl); -- DECL_NAME (decl); - end if; - - return Decl; - end Exported_Pushdecl; - - -- This variable keeps a table for types for each precision so that we only - -- allocate each of them once. Signed and unsigned types are kept separate. - type Signed_And_Unsigned_Types_Array_Type is - array (Natural range 0 .. MAX_BITS_PER_WORD, C_Boolean) of Tree; - Signed_And_Unsigned_Types : Signed_And_Unsigned_Types_Array_Type := - (others => (others => NULL_TREE)); - pragma Export (C, Signed_And_Unsigned_Types); - - -- Return an integer type with the number of bits of precision given by - -- PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise - -- it is a signed type. - function Type_For_Size (Precision : Natural; Unsignedp : C_Bool) - return Tree - is - T : Tree; - begin - if Precision <= MAX_BITS_PER_WORD - and then Signed_And_Unsigned_Types (Precision, Unsignedp) /= NULL_TREE - then - return Signed_And_Unsigned_Types (Precision, Unsignedp); - end if; - - if Unsignedp /= C_False then - T := Make_Unsigned_Type (Precision); - else - T := Make_Signed_Type (Precision); - end if; - if Precision <= MAX_BITS_PER_WORD then - Signed_And_Unsigned_Types (Precision, Unsignedp) := T; - end if; - return T; - end Type_For_Size; - - -- Return a data type that has machine mode MODE. UNSIGNEDP selects - -- an unsigned type; otherwise a signed type is returned. - function Type_For_Mode (Mode : Machine_Mode; Unsignedp : C_Bool) - return Tree - is - begin - return Type_For_Size (GET_MODE_BITSIZE (Mode), Unsignedp); - end Type_For_Mode; - - -- Return the unsigned version of a TYPE_NODE, a scalar type. - function Unsigned_Type (Type_Node : Tree) return Tree - is - begin - return Type_For_Size (Get_TYPE_PRECISION (Type_Node), C_True); - end Unsigned_Type; - - -- Return the signed version of a TYPE_NODE, a scalar type. - function Signed_Type (Type_Node : Tree) return Tree - is - begin - return Type_For_Size (Get_TYPE_PRECISION (Type_Node), C_False); - end Signed_Type; - - -- Return a type the same as TYPE except unsigned or signed according to - -- UNSIGNEDP. - function Signed_Or_Unsigned_Type (Unsignedp : C_Bool; Atype : Tree) - return Tree - is - begin - if INTEGRAL_TYPE_P (Atype) = C_False - or else Get_TREE_UNSIGNED (Atype) = Unsignedp - then - return Atype; - else - return Type_For_Size (Get_TYPE_PRECISION (Atype), Unsignedp); - end if; - end Signed_Or_Unsigned_Type; - - - --procedure Init_Type_For_Size; - --pragma Import (C, Init_Type_For_Size); - - Int_Str : constant String := "int" & Nul; - Char_Str : constant String := "char" & Nul; - - Builtin_Alloca_Str : constant String := "__builtin_alloca" & Nul; - - function Lang_Init return C_Bool - is - --File : String renames Filename (1 .. Filename_Len); - Ptr_Ftype_Sizetype : Tree; - Alloca_Function : Tree; - begin - --Error_Mark_Node := Make_Node (ERROR_MARK); - --Set_TREE_TYPE (Error_Mark_Node, Error_Mark_Node); - - --Initialize_Sizetypes; - - -- The structure `tree_identifier' is the GCC tree data structure that - -- holds IDENTIFIER_NODE nodes. We need to call `set_identifier_size' - -- to tell GCC that we have not added any language specific fields to - -- IDENTIFIER_NODE nodes. - --Set_Identifier_Size (Tree_Identifier_Size); - Input_Location.Line := 0; - - -- Make the binding_level structure for global names. - Pushlevel (C_False); - Global_Binding_Level := Current_Binding_Level; - - Build_Common_Tree_Nodes (C_False); - Pushdecl (Build_Decl (TYPE_DECL, Get_Identifier (Int_Str'Address), - Integer_Type_Node)); - Pushdecl (Build_Decl (TYPE_DECL, Get_Identifier (Char_Str'Address), - Char_Type_Node)); - Set_Sizetype (Unsigned_Type_Node); - Build_Common_Tree_Nodes_2 (C_False); - - --Init_Type_For_Size; - - -- Create alloc builtin. - Ptr_Ftype_Sizetype := Build_Function_Type - (Ptr_Type_Node, - Tree_Cons (NULL_TREE, Get_TYPE_DOMAIN (Sizetype), NULL_TREE)); - Alloca_Function := Builtin_Function - (Builtin_Alloca_Str'Address, Ptr_Ftype_Sizetype, - BUILT_IN_ALLOCA, BUILT_IN_NORMAL, System.Null_Address); - Ortho_Gcc.Alloca_Function_Ptr := Build1 - (ADDR_EXPR, Build_Pointer_Type (Ptr_Ftype_Sizetype), Alloca_Function); --- Ggc_Add_Tree_Root (Ortho_Gcc.Alloca_Function_Ptr'Address, 1); - - Ortho_Gcc.Init; - - -- Continue. - return C_True; - end Lang_Init; - - procedure Lang_Finish is - begin - null; - end Lang_Finish; - - -- Return a definition for a builtin function named NAME and whose data - -- type is TYPE. TYPE should be a function type with argument types. - -- FUNCTION_CODE tells later passes how to compile calls to this function. - -- See tree.h for its possible values. - -- - -- If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, - -- the name to be called if we can't opencode the function. - function Builtin_Function - (Name: System.Address; - Ftype : Tree; - Function_Code : Built_In_Function; - Class : Built_In_Class; - Library_Name : System.Address) - return Tree - is - use System; - Decl : Tree; - begin - Decl := Build_Decl (FUNCTION_DECL, Get_Identifier (Name), Ftype); - Set_DECL_EXTERNAL (Decl, C_True); - Set_TREE_PUBLIC (Decl, C_True); - if Library_Name /= Null_Address then - Set_DECL_ASSEMBLER_NAME (Decl, Get_Identifier (Library_Name)); - end if; - Make_Decl_Rtl (Decl, NULL_Chars, C_True); - Pushdecl (Decl); - Set_DECL_BUILT_IN_CLASS (Decl, Class); - Set_DECL_FUNCTION_CODE (Decl, Function_Code); - return Decl; - end Builtin_Function; - - procedure Set_Yydebug (Flag : C_Bool) - is - pragma Unreferenced (Flag); - begin - null; - end Set_Yydebug; - - procedure Print_Lang_Decl (File : FILEs; Node : Tree; Indent : natural) - is - pragma Unreferenced (File); - pragma Unreferenced (Node); - pragma Unreferenced (Indent); - begin - null; - end Print_Lang_Decl; - - procedure Print_Lang_Type (File : FILEs; Node : Tree; Indent : Natural) - is - pragma Unreferenced (File); - pragma Unreferenced (Node); - pragma Unreferenced (Indent); - begin - null; - end Print_Lang_Type; - - procedure Print_Lang_Identifier - (File : FILEs; Node : Tree; Indent : Natural) - is - pragma Unreferenced (File); - pragma Unreferenced (Node); - pragma Unreferenced (Indent); - begin - null; - end Print_Lang_Identifier; - - procedure Lang_Print_Xnode (File : FILEs; Node : Tree; Indent : Natural) - is - pragma Unreferenced (File); - pragma Unreferenced (Node); - pragma Unreferenced (Indent); - begin - -- There is no X nodes. - raise Program_Error; - end Lang_Print_Xnode; - - procedure Print_Lang_Statistics is - begin - null; - end Print_Lang_Statistics; - - procedure Copy_Lang_Decl (Node : Tree) - is - pragma Unreferenced (Node); - begin - null; - end Copy_Lang_Decl; - - function Truthvalue_Conversion (Expr : Tree) return Tree - is - Expr_Type : Tree; - type Conv_Array is array (Boolean) of Tree; - Conv : Conv_Array; - begin - Expr_Type := Get_TREE_TYPE (Expr); - if Get_TREE_CODE (Expr_Type) /= BOOLEAN_TYPE then - Conv := (True => Integer_One_Node, - False => Integer_Zero_Node); - else - Conv := (False => Get_TYPE_MIN_VALUE (Expr_Type), - True => Get_TYPE_MAX_VALUE (Expr_Type)); - end if; - - -- From java/decl.c - -- It is simpler and generates better code to have only TRUTH_*_EXPR - -- or comparison expressions as truth values at this level. - - case Get_TREE_CODE (Expr) is - when EQ_EXPR - | NE_EXPR - | LE_EXPR - | GE_EXPR - | LT_EXPR - | GT_EXPR - | TRUTH_ANDIF_EXPR - | TRUTH_ORIF_EXPR - | TRUTH_AND_EXPR - | TRUTH_OR_EXPR - | ERROR_MARK => - return Expr; - - when INTEGER_CST => - if Integer_Zerop (Expr) = C_False then - -- EXPR is not 0, so EXPR is interpreted as TRUE. - return Conv (True); - else - return Conv (False); - end if; - - when REAL_CST => - if Real_Zerop (Expr) = C_False then - return Conv (True); - else - return Conv (False); - end if; - - when others => - raise Program_Error; - end case; - end Truthvalue_Conversion; - - procedure Incomplete_Type_Error (Value : Tree; Atype : Tree) - is - pragma Unreferenced (Value); - pragma Unreferenced (Atype); - begin - -- Can never happen. - raise Program_Error; - end Incomplete_Type_Error; - - function Maybe_Build_Cleanup (Decl : Tree) return Tree - is - pragma Unreferenced (Decl); - begin - return NULL_TREE; - end Maybe_Build_Cleanup; - - Language_Name : constant String := "GNU vhdl" & Nul; - pragma Export (C, Language_Name); -end Agcc.Fe; diff --git a/ortho/gcc34/lang.opt b/ortho/gcc34/lang.opt deleted file mode 100644 index b2f650a..0000000 --- a/ortho/gcc34/lang.opt +++ /dev/null @@ -1,88 +0,0 @@ -; Options for the VHDL front-end. -; Copyright (C) 2003, 2004, 2005 Tristan Gingold -; -; GHDL is free software; you can redistribute it and/or modify it under -; the terms of the GNU General Public License as published by the Free -; Software Foundation; either version 2, or (at your option) any later -; version. -; -; GHDL is distributed in the hope that it will be useful, but WITHOUT ANY -; WARRANTY; without even the implied warranty of MERCHANTABILITY or -; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -; for more details. -; -; You should have received a copy of the GNU General Public License -; along with GCC; see the file COPYING. If not, write to the Free -; Software Foundation, 59 Temple Place - Suite 330, Boston, MA -; 02111-1307, USA. - -Language -vhdl - --std= -vhdl Joined -Select the vhdl standard - --compile-standard -vhdl -Used during compiler build to compile the std.standard package - --bootstrap -vhdl -Used during compiler build to compile std packages - --work= -vhdl Joined -Set the name of the work library - --workdir= -vhdl Joined -Set the directory of the work library - -P -vhdl Joined --P<dir> Add <dir> to the end of the vhdl library path - --elab -vhdl Separate ---elab <name> Used internally during elaboration of <name> - --anaelab -vhdl Separate ---anaelab <name> Used internally during elaboration of <name> - -c -vhdl Separate --c <filename> Analyze <filename> for --anaelab - -v -vhdl -Verbose - --warn- -vhdl Joined ---warn-<name> Warn about <name> - --ghdl -vhdl Joined ---ghdl-<option> Pass <option> to vhdl front-end - --expect-failure -vhdl -Expect a compiler error (used for testsuite) - --no-vital-checks -vhdl -Disable VITAL checks - --vital-checks -vhdl -Enable VITAL checks - -fexplicit -vhdl -Explicit functions override implicit functions - -l -vhdl Joined Separate --l<filename> Put list of files for link in <filename> diff --git a/ortho/gcc34/ortho_gcc-main.adb b/ortho/gcc34/ortho_gcc-main.adb deleted file mode 100644 index 5ee7a76..0000000 --- a/ortho/gcc34/ortho_gcc-main.adb +++ /dev/null @@ -1,44 +0,0 @@ --- Ortho implementation for GCC. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; -with Ortho_Gcc_Front; -with Agcc.Toplev; -with Ada.Command_Line; use Ada.Command_Line; - -procedure Ortho_Gcc.Main -is - gnat_argc : Integer; - gnat_argv : System.Address; - gnat_envp : System.Address; - - pragma Import (C, gnat_argc); - pragma Import (C, gnat_argv); - pragma Import (C, gnat_envp); - - Status : Exit_Status; -begin - Ortho_Gcc_Front.Init; - - -- Note: GCC set signal handlers... - Status := Exit_Status (Agcc.Toplev.Toplev_Main (gnat_argc, gnat_argv)); - Set_Exit_Status (Status); -exception - when others => - Set_Exit_Status (2); - return; -end Ortho_Gcc.Main; diff --git a/ortho/gcc34/ortho_gcc-main.ads b/ortho/gcc34/ortho_gcc-main.ads deleted file mode 100644 index fd79cf4..0000000 --- a/ortho/gcc34/ortho_gcc-main.ads +++ /dev/null @@ -1,18 +0,0 @@ --- Ortho implementation for GCC. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -procedure Ortho_Gcc.Main; diff --git a/ortho/gcc34/ortho_gcc.adb b/ortho/gcc34/ortho_gcc.adb deleted file mode 100644 index 66a3f1a..0000000 --- a/ortho/gcc34/ortho_gcc.adb +++ /dev/null @@ -1,1362 +0,0 @@ --- Ortho implementation for GCC. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. ---with Ada.Unchecked_Conversion; -with Agcc; use Agcc; -with Agcc.Hwint; use Agcc.Hwint; -with Agcc.Toplev; use Agcc.Toplev; -with Agcc.Tm; use Agcc.Tm; -with Agcc.Stor_Layout; use Agcc.Stor_Layout; -with Agcc.Machmode; -with System; -with Agcc.Autils; use Agcc.Autils; -with Agcc.Real; use Agcc.Real; -with Agcc.Fe; use Agcc.Fe; -with Agcc.Rtl; use Agcc.Rtl; -with Agcc.Input; use Agcc.Input; -with Agcc.Machmode; - -package body Ortho_Gcc is - type ON_Op_To_Tree_Code_Type is array (ON_Op_Kind) of Tree_Code; - ON_Op_To_Tree_Code : constant ON_Op_To_Tree_Code_Type := - ( - -- Dyadic operations. - ON_Add_Ov => PLUS_EXPR, - ON_Sub_Ov => MINUS_EXPR, - ON_Mul_Ov => MULT_EXPR, - ON_Div_Ov => ERROR_MARK, - ON_Rem_Ov => TRUNC_MOD_EXPR, - ON_Mod_Ov => FLOOR_MOD_EXPR, - - -- Binary operations. - ON_And => TRUTH_AND_EXPR, - ON_Or => TRUTH_OR_EXPR, - ON_Xor => TRUTH_XOR_EXPR, - ON_And_Then => TRUTH_ANDIF_EXPR, - ON_Or_Else => TRUTH_ORIF_EXPR, - - -- Monadic operations. - ON_Not => TRUTH_NOT_EXPR, - ON_Neg_Ov => NEGATE_EXPR, - ON_Abs_Ov => ABS_EXPR, - - -- Comparaisons - ON_Eq => EQ_EXPR, - ON_Neq => NE_EXPR, - ON_Le => LE_EXPR, - ON_Lt => LT_EXPR, - ON_Ge => GE_EXPR, - ON_Gt => GT_EXPR, - - ON_Nil => ERROR_MARK - ); - - -- Constants used for FP rounding. - Fp_Const_P5 : REAL_VALUE_TYPE; -- 0.5 - Fp_Const_M_P5 : REAL_VALUE_TYPE; -- -0.5 - Fp_Const_Zero : REAL_VALUE_TYPE; -- 0.0 - - procedure Init - is - use Agcc.Machmode; - - L, H : HOST_WIDE_INT; - V : REAL_VALUE_TYPE; - begin - To_Host_Wide_Int (Integer_64'(1), L, H); - REAL_VALUE_FROM_INT (V'Address, L, H, DFmode); - Fp_Const_P5 := REAL_VALUE_LDEXP (V, -1); - - To_Host_Wide_Int (Integer_64'(-1), L, H); - REAL_VALUE_FROM_INT (V'Address, L, H, DFmode); - Fp_Const_M_P5 := REAL_VALUE_LDEXP (V, -1); - - To_Host_Wide_Int (Integer_64'(0), L, H); - REAL_VALUE_FROM_INT (Fp_Const_Zero'Address, L, H, DFmode); - end Init; - - procedure Chain_Init (Constr : out Chain_Constr_Type) is - begin - Constr.First := NULL_TREE; - Constr.Last := NULL_TREE; - end Chain_Init; - - procedure Chain_Append (Constr : in out Chain_Constr_Type; El : Tree) - is - begin - if Constr.First = NULL_TREE then - if Constr.Last /= NULL_TREE then - raise Program_Error; - end if; - Constr.First := El; - else - Set_TREE_CHAIN (Constr.Last, El); - end if; - Constr.Last := El; - end Chain_Append; - - - procedure List_Init (Constr : out List_Constr_Type) is - begin - Constr := (First => NULL_TREE, Last => NULL_TREE); - end List_Init; - - procedure List_Append (Constr : in out List_Constr_Type; El : Tree) - is - Res : Tree; - begin - Res := Tree_Cons (NULL_TREE, El, NULL_TREE); - if Constr.First = NULL_TREE then - Constr.First := Res; - else - Set_TREE_CHAIN (Constr.Last, Res); - end if; - Constr.Last := Res; - end List_Append; - - - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode - is - Left_Type : Tree; - Code : Tree_Code; - begin - Left_Type := Get_TREE_TYPE (Tree (Left)); - if Left_Type /= Get_TREE_TYPE (Tree (Right)) then - raise Type_Error; - end if; - case Kind is - when ON_Div_Ov => - if Get_TREE_CODE (Left_Type) = REAL_TYPE then - Code := RDIV_EXPR; - else - Code := TRUNC_DIV_EXPR; - end if; - when others => - Code := ON_Op_To_Tree_Code (Kind); - end case; - return O_Enode (Build (Code, Left_Type, Tree (Left), Tree (Right))); - end New_Dyadic_Op; - - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode - is - begin - return Build1 (ON_Op_To_Tree_Code (Kind), - Get_TREE_TYPE (Operand), Operand); - end New_Monadic_Op; - - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) - return O_Enode - is - begin - if Get_TREE_CODE (Ntype) /= BOOLEAN_TYPE then - raise Type_Error; - end if; - if Get_TREE_TYPE (Left) /= Get_TREE_TYPE (Right) then - raise Type_Error; - end if; - return O_Enode (Build (ON_Op_To_Tree_Code (Kind), - Tree (Ntype), Tree (Left), Tree (Right))); - end New_Compare_Op; - --- function Unchecked_Conversion is new --- Ada.Unchecked_Conversion (Source => Unsigned_32, Target => HOST_WIDE_INT); - --- function High_Part (V : Unsigned_64) return HOST_WIDE_INT --- is --- begin --- return Unchecked_Conversion (Unsigned_32 (Shift_Left (V, 32))); --- end High_Part; - --- function Low_Part (V : Unsigned_64) return HOST_WIDE_INT --- is --- begin --- return Unchecked_Conversion --- (Unsigned_32 (V and (Unsigned_32'Modulus - 1))); --- end Low_Part; - - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode - is - L, H : HOST_WIDE_INT; - Res : Tree; - begin - To_Host_Wide_Int (Value, L, H); - Res := Build_Int_2 (L, H); - Set_TREE_TYPE (Res, Tree (Ltype)); - return O_Cnode (Res); - end New_Signed_Literal; - - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode - is - Res : Tree; - L, H : HOST_WIDE_INT; - begin - To_Host_Wide_Int (Value, L, H); - Res := Build_Int_2 (L, H); - Set_TREE_TYPE (Res, Tree (Ltype)); - return O_Cnode (Res); - end New_Unsigned_Literal; - - function New_Null_Access (Ltype : O_Tnode) return O_Cnode - is - Res : Tree; - begin - Res := Build_Int_2 (0, 0); - Set_TREE_TYPE (Res, Tree (Ltype)); - return O_Cnode (Res); - end New_Null_Access; - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode - is - Res : REAL_VALUE_TYPE; - begin - Res := To_Real_Value_Type (Value); - return O_Cnode (Build_Real (Tree (Ltype), Res)); - end New_Float_Literal; - - procedure Check_Constrained_Type (Atype : O_Tnode) - is - pragma Unreferenced (Atype); - begin - null; - end Check_Constrained_Type; - - procedure Finish_Type_Def (Atype : O_Tnode) is - begin - Layout_Type (Atype); - --Rest_Of_Type_Compilation (Tree (Atype), True); - end Finish_Type_Def; - - procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is - begin - Res := Make_Node (RECORD_TYPE); - end New_Uncomplete_Record_Type; - - procedure Start_Record_Type (Elements : out O_Element_List) is - begin - Elements.Res := Make_Node (RECORD_TYPE); - Chain_Init (Elements.Chain); - end Start_Record_Type; - - procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List) is - begin - Elements.Res := Tree (Res); - Chain_Init (Elements.Chain); - end Start_Uncomplete_Record_Type; - - procedure New_Record_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode) - is - Res : Tree; - begin - Check_Constrained_Type (Etype); - Res := Build_Decl (FIELD_DECL, Ident, Tree (Etype)); - Set_DECL_CONTEXT (Res, Elements.Res); - Chain_Append (Elements.Chain, Res); - El := O_Fnode (Res); - end New_Record_Union_Field; - - procedure New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode) - renames New_Record_Union_Field; - - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode) is - begin - Set_TYPE_FIELDS (Elements.Res, Elements.Chain.First); - Finish_Type_Def (O_Tnode (Elements.Res)); - Res := O_Tnode (Elements.Res); - if Get_TYPE_NAME (Elements.Res) /= NULL_TREE then - -- The type was completed. - Rest_Of_Type_Compilation (Elements.Res, C_True); - end if; - end Finish_Record_Type; - - procedure Start_Union_Type (Elements : out O_Element_List) is - begin - Elements.Res := Make_Node (UNION_TYPE); - Chain_Init (Elements.Chain); - end Start_Union_Type; - - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode) - renames New_Record_Union_Field; - - procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode) is - begin - Set_TYPE_FIELDS (Elements.Res, Elements.Chain.First); - Finish_Type_Def (O_Tnode (Elements.Res)); - Res := O_Tnode (Elements.Res); - end Finish_Union_Type; - - function New_Access_Type (Dtype : O_Tnode) return O_Tnode - is - Res : Tree; - begin - if Dtype = O_Tnode_Null then - Res := Make_Node (POINTER_TYPE); - Set_TREE_TYPE (Res, NULL_TREE); - Set_TYPE_MODE (Res, Machmode.Ptr_Mode); - Layout_Type (Res); - return O_Tnode (Res); - else - return Build_Pointer_Type (Dtype); - end if; - end New_Access_Type; - - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is - begin - if Get_TREE_CODE (Atype) /= POINTER_TYPE - or else Get_TREE_TYPE (Atype) /= O_Tnode_Null - then - raise Syntax_Error; - end if; - Set_TREE_TYPE (Atype, Dtype); - end Finish_Access_Type; - - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode - is - begin - Check_Constrained_Type (El_Type); - return Build_Array_Type (El_Type, Index_Type); - end New_Array_Type; - - function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) - return O_Tnode - is - Range_Type : Tree; - Index_Type : Tree; - Len : Tree; - One : Tree; - begin - --if Atype.Kind /= ON_Array_Type then - -- raise Type_Error; - --end if; - Index_Type := Get_TYPE_DOMAIN (Tree (Atype)); - if +Integer_Zerop (Tree (Length)) then - -- Handle null array, by creating a one-length array... - Len := Size_Zero_Node; - else - One := Build_Int_2 (1, 0); - Set_TREE_TYPE (One, Index_Type); - Len := Build (MINUS_EXPR, Index_Type, Tree (Length), One); - Len := Fold (Len); - end if; - Range_Type := Build_Range_Type (Index_Type, Size_Zero_Node, Len); - return O_Tnode (Build_Array_Type (Get_TREE_TYPE (Tree (Atype)), - Range_Type)); - end New_Constrained_Array_Type; - - function New_Unsigned_Type (Size : Natural) return O_Tnode - is - begin - return Make_Unsigned_Type (Size); - end New_Unsigned_Type; - - function New_Signed_Type (Size : Natural) return O_Tnode - is - begin - return Make_Signed_Type (Size); - end New_Signed_Type; - - function New_Float_Type return O_Tnode is - Res : O_Tnode; - begin - Res := Make_Node (REAL_TYPE); - Set_TYPE_PRECISION (Res, DOUBLE_TYPE_SIZE); - Layout_Type (Res); - return Res; - end New_Float_Type; - - procedure New_Boolean_Type (Res : out O_Tnode; - False_Id : O_Ident; - False_E : out O_Cnode; - True_Id : O_Ident; - True_E : out O_Cnode) - is - pragma Unreferenced (False_Id); - pragma Unreferenced (True_Id); - begin - -- see java/decl.c - Res := O_Tnode'(Make_Node (BOOLEAN_TYPE)); - Set_TYPE_PRECISION (Tree (Res), 1); - Fixup_Unsigned_Type (Tree (Res)); - False_E := O_Cnode (Get_TYPE_MIN_VALUE (Tree (Res))); - True_E := O_Cnode (Get_TYPE_MAX_VALUE (Tree (Res))); - end New_Boolean_Type; - - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) - is - begin - List.Res := Make_Node (ENUMERAL_TYPE); - Chain_Init (List.Chain); - List.Num := 0; - List.Size := Size; - end Start_Enum_Type; - - procedure New_Enum_Literal - (List : in out O_Enum_List; Ident : O_Ident; Res : out O_Cnode) - is - begin - Res := Build_Int_2 (HOST_WIDE_INT (List.Num), 0); - Set_TREE_TYPE (Tree (Res), List.Res); - Chain_Append (List.Chain, Tree_Cons (Ident, Tree (Res), NULL_TREE)); - List.Num := List.Num + 1; - end New_Enum_Literal; - - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is - begin - Res := O_Tnode (List.Res); - Set_TYPE_VALUES (List.Res, List.Chain.First); - Set_TYPE_MIN_VALUE (List.Res, Get_TREE_VALUE (List.Chain.First)); - Set_TYPE_MAX_VALUE (List.Res, Get_TREE_VALUE (List.Chain.Last)); - Set_TREE_UNSIGNED (List.Res, C_True); - Set_TYPE_PRECISION (List.Res, Integer (List.Size)); - Finish_Type_Def (Res); - end Finish_Enum_Type; - - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; Atype : O_Tnode) - is - begin - List.Atype := Tree (Atype); - Chain_Init (List.Chain); - end Start_Record_Aggr; - - procedure New_Record_Aggr_El - (List : in out O_Record_Aggr_List; Value : O_Cnode) - is - begin - -- FIXME: should check type of value. - Chain_Append (List.Chain, - Build_Tree_List (NULL_TREE, Tree (Value))); - end New_Record_Aggr_El; - - procedure Finish_Record_Aggr - (List : in out O_Record_Aggr_List; Res : out O_Cnode) - is - begin - Res := O_Cnode (Build_Constructor (List.Atype, List.Chain.First)); - end Finish_Record_Aggr; - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) - is - begin - List.Atype := Tree (Atype); - Chain_Init (List.Chain); - end Start_Array_Aggr; - - procedure New_Array_Aggr_El - (List : in out O_Array_Aggr_List; Value : O_Cnode) - is - begin - -- FIXME: should check type of value. - Chain_Append (List.Chain, - Build_Tree_List (NULL_TREE, Tree (Value))); - end New_Array_Aggr_El; - - procedure Finish_Array_Aggr - (List : in out O_Array_Aggr_List; Res : out O_Cnode) - is - begin - Res := O_Cnode (Build_Constructor (List.Atype, List.Chain.First)); - end Finish_Array_Aggr; - - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode - is - El : Tree; - Res : Tree; - begin - El := Build_Tree_List (Tree (Field), Tree (Value)); - Res := Build_Constructor (Tree (Atype), El); - Set_TREE_CONSTANT (Res, C_True); - return O_Cnode (Res); - end New_Union_Aggr; - - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode - is - Res : Tree; - V : C_Bool; - begin - V := Mark_Addressable (Tree (Arr)); - Res := Build (ARRAY_REF, Get_TREE_TYPE (Get_TREE_TYPE (Tree (Arr))), - Tree (Arr), Tree (Index)); - return O_Lnode (Res); - end New_Indexed_Element; - - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode - is - Res : Tree; - Ptr_Type : Tree; - V : C_Bool; - begin - -- *((RES_TYPE *)(&ARR[INDEX])) - -- convert ARR to a pointer, add index, and reconvert to array ? - if Get_TREE_CODE (Res_Type) /= ARRAY_TYPE then - raise Type_Error; - end if; - V := Mark_Addressable (Tree (Arr)); - Ptr_Type := Build_Pointer_Type (Tree (Res_Type)); - Res := Build (ARRAY_REF, Get_TREE_TYPE (Get_TREE_TYPE (Tree (Arr))), - Tree (Arr), Tree (Index)); - Res := Build1 (ADDR_EXPR, Ptr_Type, Res); - Res := Build1 (INDIRECT_REF, Tree (Res_Type), Res); - return O_Lnode (Res); - end New_Slice; - - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode - is - begin - if Get_TREE_CODE (Get_TREE_TYPE (Rec)) /= RECORD_TYPE then - raise Type_Error; - end if; - return O_Lnode (Build (COMPONENT_REF, Get_TREE_TYPE (Tree (El)), - Tree (Rec), Tree (El))); - end New_Selected_Element; - - function New_Access_Element (Acc : O_Enode) return O_Lnode - is - Acc_Type : Tree; - begin - Acc_Type := Get_TREE_TYPE (Tree (Acc)); - if Get_TREE_CODE (Acc_Type) /= POINTER_TYPE then - raise Type_Error; - end if; - return O_Lnode (Build1 (INDIRECT_REF, Get_TREE_TYPE (Acc_Type), - Tree (Acc))); - end New_Access_Element; - - function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode - is - Val_Type : Tree; - Val_Code : Tree_Code; - Rtype_Code : Tree_Code; - Code : Tree_Code; - begin - Val_Type := Get_TREE_TYPE (Tree (Val)); - if Val_Type = Tree (Rtype) then - return Val; - end if; - -- FIXME: check conversions. - Val_Code := Get_TREE_CODE (Val_Type); - Rtype_Code := Get_TREE_CODE (Rtype); - if Val_Code = POINTER_TYPE and then Rtype_Code = POINTER_TYPE then - Code := NOP_EXPR; - elsif Val_Code = INTEGER_TYPE and then Rtype_Code = INTEGER_TYPE then - Code := CONVERT_EXPR; - elsif Val_Code = REAL_TYPE and then Rtype_Code = INTEGER_TYPE then - -- REAL to INTEGER - -- Gcc only handles FIX_TRUNC_EXPR, but we need rounding. - declare - M_P5 : Tree; - P5 : Tree; - Zero : Tree; - Saved : Tree; - Comp : Tree; - Adj : Tree; - Res : Tree; - begin - M_P5 := Build_Real (Val_Type, Fp_Const_M_P5); - P5 := Build_Real (Val_Type, Fp_Const_P5); - Zero := Build_Real (Val_Type, Fp_Const_Zero); - Saved := Build_Save_Expr (Tree (Val)); - Comp := Build (GE_EXPR, Integer_Type_Node, Saved, Zero); - -- FIXME: instead of res = res + (comp ? .5 : -.5) - -- do: res = res (comp ? + : -) .5 - Adj := Build (COND_EXPR, Val_Type, Comp, P5, M_P5); - Res := Build (PLUS_EXPR, Val_Type, Saved, Adj); - Res := Build1 (FIX_TRUNC_EXPR, Tree (Rtype), Res); - return O_Enode (Res); - end; - elsif Val_Code = INTEGER_TYPE and then Rtype_Code = ENUMERAL_TYPE then - Code := CONVERT_EXPR; - elsif Val_Code = ENUMERAL_TYPE and then Rtype_Code = INTEGER_TYPE then - Code := CONVERT_EXPR; - elsif Val_Code = INTEGER_TYPE and then Rtype_Code = REAL_TYPE then - Code := FLOAT_EXPR; - elsif Val_Code = BOOLEAN_TYPE and then Rtype_Code = BOOLEAN_TYPE then - Code := NOP_EXPR; - elsif Val_Code = BOOLEAN_TYPE and then Rtype_Code = INTEGER_TYPE then - Code := CONVERT_EXPR; - elsif Val_Code = INTEGER_TYPE and then Rtype_Code = BOOLEAN_TYPE then - -- From integer to boolean. - Code := NOP_EXPR; - elsif Val_Code = REAL_TYPE and then Rtype_Code = REAL_TYPE then - Code := CONVERT_EXPR; - else - raise Program_Error; - end if; - return O_Enode (Build1 (Code, Tree (Rtype), Tree (Val))); - end New_Convert_Ov; - - function Build_Addr (Operand : Tree; Atype : Tree) return Tree - is - use Agcc.Machmode; - Result : Tree; - begin - case Get_TREE_CODE (Operand) is - when INDIRECT_REF => - -- This may be an unchecked conversion. - Result := Get_TREE_OPERAND (Operand, 0); - if Get_TREE_CODE (Get_TREE_TYPE (Result)) /= POINTER_TYPE then - raise Program_Error; - end if; - return Result; - - when ARRAY_REF - | COMPONENT_REF => - -- Find the address of the prefix and add the offset. - declare - Op_Type : Tree; - Bitsize, Bitpos : HOST_WIDE_INT; - Inner, Offset : Tree; - Mode : Machine_Mode; - Unsignedp, Volatilep : Integer; - begin - Op_Type := Get_TREE_TYPE (Get_TREE_OPERAND (Operand, 0)); - Inner := Get_Inner_Reference - (Operand, Bitsize'Address, Bitpos'Address, Offset'Address, - Mode'Address, Unsignedp'Address, Volatilep'Address); - - -- Compute the offset as a byte offset from INNER. */ - if Offset = NULL_TREE then - Offset := Size_Zero_Node; - end if; - - Offset := Size_Binop - (PLUS_EXPR, Offset, - Size_Int (Bitpos / HOST_WIDE_INT (BITS_PER_UNIT))); - - -- Take the address of INNER, convert the offset to void *, and - -- add then. It will later be converted to the desired result - -- type, if any. - Inner := Build_Addr (Inner, Ptr_Type_Node); - Inner := Convert (Ptr_Type_Node, Inner); - Offset := Convert (Ptr_Type_Node, Offset); - Result := Fold - (Build (PLUS_EXPR, Ptr_Type_Node, Inner, Offset)); - return Result; - end; - - when VAR_DECL => - -- This is like Mark_Addressable. - Put_Var_Into_Stack (Operand, C_True); - Set_TREE_ADDRESSABLE (Operand, C_True); - return Build1 (ADDR_EXPR, Atype, Operand); - - when others => - raise Program_Error; - end case; - end Build_Addr; - - function New_Addr (Lvalue : Tree; Atype : O_Tnode) - return Tree - is - Result : Tree; - begin - Result := Build_Addr (Lvalue, Tree (Atype)); - if Get_TREE_TYPE (Result) /= Tree (Atype) then - if Get_TREE_CODE (Get_TREE_TYPE (Result)) /= POINTER_TYPE then - raise Program_Error; - end if; - Result := Build1 (NOP_EXPR, Tree (Atype), Result); - end if; - return Result; - --return O_Enode (Build1 (ADDR_EXPR, Tree (Atype), Tree (Lvalue))); - end New_Addr; - - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode - is - begin - return O_Enode (New_Addr (Tree (Lvalue), Atype)); - end New_Unchecked_Address; - - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode - is - begin - --if Get_TREE_TYPE (Lvalue) /= Get_TREE_TYPE (Atype) then - -- raise Type_Error; - --end if; - return O_Enode (New_Addr (Tree (Lvalue), Atype)); - end New_Address; - - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - is - begin - return O_Cnode (New_Addr (Tree (Decl), Atype)); - end New_Global_Unchecked_Address; - - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode - is - begin - --if Get_TREE_TYPE (Lvalue) /= Get_TREE_TYPE (Atype) then - -- raise Type_Error; - --end if; - return O_Cnode (New_Addr (Tree (Decl), Atype)); - end New_Global_Address; - - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode - is - begin - return O_Cnode (Build1 (ADDR_EXPR, Tree (Atype), Tree (Subprg))); - end New_Subprogram_Address; - - function New_Value (Lvalue : O_Lnode) return O_Enode is - begin - return O_Enode (Lvalue); - end New_Value; - - function New_Obj_Value (Obj : O_Dnode) return O_Enode is - begin - return O_Enode (Obj); - end New_Obj_Value; - - function New_Obj (Obj : O_Dnode) return O_Lnode is - begin - return O_Lnode (Obj); - end New_Obj; - - function New_Lit (Lit : O_Cnode) return O_Enode is - begin - return O_Enode (Lit); - end New_Lit; - - function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Cnode - is - Off : Tree; - Bit_Off : Tree; - Pos : HOST_WIDE_INT; - Res : Tree; - begin - Off := Get_DECL_FIELD_OFFSET (Tree (Field)); - if Host_Integerp (Off, 1) = 0 then - -- The offset must be a constant. - raise Program_Error; - end if; - Bit_Off := Get_DECL_FIELD_BIT_OFFSET (Tree (Field)); - if Host_Integerp (Bit_Off, 1) = 0 then - -- The offset must be a constant. - raise Program_Error; - end if; - Pos := Get_TREE_INT_CST_LOW (Off) - + (Get_TREE_INT_CST_LOW (Bit_Off) / HOST_WIDE_INT (BITS_PER_UNIT)); - Res := Build_Int_2 (Pos, 0); - Set_TREE_TYPE (Res, Tree (Rtype)); - return O_Cnode (Res); - end New_Offsetof; - - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode - is - Size : Tree; - begin - Size := Get_TYPE_SIZE_UNIT (Tree (Atype)); - --Size := Size_Binop (CEIL_DIV_EXPR, Size, - -- Size_Int (HOST_WIDE_INT (BITS_PER_UNIT))); - - return O_Cnode (Fold (Build1 (NOP_EXPR, Tree (Rtype), Size))); - end New_Sizeof; - - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode - is - Var : Tree; - Var_Type : Tree; - Res : Tree; - begin - -- Create a dummy variable of the correct size. - -- This way, the storage will be deallocated at the end of the scope. - Var_Type := Build_Array_Type (Char_Type_Node, - Build_Index_Type (Tree (Size))); - Var := Build_Decl (VAR_DECL, NULL_TREE, Var_Type); - Set_TREE_STATIC (Var, C_False); - Set_DECL_EXTERNAL (Var, C_False); - Set_TREE_PUBLIC (Var, C_False); - Pushdecl (Var); - Expand_Decl (Var); - Res := Build1 (ADDR_EXPR, Tree (Rtype), Var); - return O_Enode (Res); - - -- Old code that use alloca. This is not space efficient, since the - -- storage will be freed only at the exit of the function. - --Arg := Build1 (CONVERT_EXPR, Sizetype, Tree (Size)); - --Res := Build (CALL_EXPR, Ptr_Type_Node, Alloca_Function_Ptr, - -- Tree_Cons (NULL_TREE, Arg, NULL_TREE)); - --return O_Enode (Build1 (NOP_EXPR, Tree (Rtype), Res)); - end New_Alloca; - - --------------------- - -- Declarations. -- - --------------------- - - type String_Acc is access String; - Current_Filename : String_Acc := null; - - procedure New_Debug_Filename_Decl (Filename : String) - is - Len : Natural; - begin - Len := Filename'Length; - if Current_Filename = null - or else Current_Filename.all'Length /= Len + 1 - or else Current_Filename (1 .. Len) /= Filename - then - Current_Filename := new String (1 .. Len + 1); - Current_Filename (1 .. Len) := Filename; - Current_Filename (Len + 1) := Nul; - Input_Location.File := Current_Filename (1)'Address; - end if; - end New_Debug_Filename_Decl; - - procedure New_Debug_Line_Decl (Line : Natural) - is - begin - Input_Location.Line := Line; - end New_Debug_Line_Decl; - - procedure New_Debug_Comment_Decl (Comment : String) - is - pragma Unreferenced (Comment); - begin - null; - end New_Debug_Comment_Decl; - - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) - is - Decl : Tree; - Ttype : Tree := Tree (Atype); - begin --- if Atype.Decl /= null then --- raise Type_Error; --- end if; - Set_TYPE_NAME (Ttype, Ident); - Decl := Build_Decl (TYPE_DECL, Ident, Ttype); - Set_TYPE_STUB_DECL (Ttype, Decl); - Pushdecl (Decl); - if Get_TYPE_SIZE (Ttype) /= NULL_TREE then - -- Do not generate debug info for uncompleted types. - Rest_Of_Type_Compilation (Ttype, C_True); - end if; - end New_Type_Decl; - - procedure Set_Storage (Node : Tree; Storage : O_Storage) - is - begin - case Storage is - when O_Storage_External => - Set_DECL_EXTERNAL (Node, C_True); - Set_TREE_PUBLIC (Node, C_True); - Set_TREE_STATIC (Node, C_False); - when O_Storage_Public => - Set_DECL_EXTERNAL (Node, C_False); - Set_TREE_PUBLIC (Node, C_True); - Set_TREE_STATIC (Node, C_True); - when O_Storage_Private => - Set_DECL_EXTERNAL (Node, C_False); - Set_TREE_PUBLIC (Node, C_False); - Set_TREE_STATIC (Node, C_True); - when O_Storage_Local => - Set_DECL_EXTERNAL (Node, C_False); - Set_TREE_PUBLIC (Node, C_False); - Set_TREE_STATIC (Node, C_False); - end case; - end Set_Storage; - - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode) - is - Cst : Tree; - begin - Cst := Build_Decl (VAR_DECL, Ident, Tree (Atype)); - Set_Storage (Cst, Storage); - Set_TREE_READONLY (Cst, C_True); - Pushdecl (Cst); - case Storage is - when O_Storage_Local => - raise Syntax_Error; - when O_Storage_External => - -- We are at top level if Current_Function_Decl is null. - Rest_Of_Decl_Compilation - (Cst, NULL_Chars, - Boolean'Pos (Current_Function_Decl = NULL_TREE), C_False); - when O_Storage_Public - | O_Storage_Private => - null; - end case; - Res := O_Dnode (Cst); - end New_Const_Decl; - - procedure Start_Const_Value (Const : in out O_Dnode) - is - pragma Unreferenced (Const); - begin - null; - end Start_Const_Value; - - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) - is - begin - Set_DECL_INITIAL (Tree (Const), Tree (Val)); - Set_TREE_CONSTANT (Val, C_True); - Rest_Of_Decl_Compilation - (Tree (Const), NULL_Chars, - Boolean'Pos (Current_Function_Decl = NULL_TREE), C_False); - end Finish_Const_Value; - - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode) - is - Var : Tree; - begin - Var := Build_Decl (VAR_DECL, Ident, Tree (Atype)); - if Current_Function_Decl /= NULL_TREE then - -- Local variable. - Set_TREE_STATIC (Var, C_False); - Set_DECL_EXTERNAL (Var, C_False); - Set_TREE_PUBLIC (Var, C_False); - else - Set_Storage (Var, Storage); - end if; - Pushdecl (Var); - if Current_Function_Decl /= NULL_TREE then - Expand_Decl (Var); - else - Rest_Of_Decl_Compilation (Var, NULL_Chars, C_True, C_False); - end if; - Res := O_Dnode (Var); - end New_Var_Decl; - - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode) - is - begin - Interfaces.Ident := Ident; - Interfaces.Storage := Storage; - Interfaces.Rtype := Rtype; - Chain_Init (Interfaces.Param_Chain); - List_Init (Interfaces.Param_List); - end Start_Function_Decl; - - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; Ident : O_Ident; Storage : O_Storage) is - begin - Start_Function_Decl (Interfaces, Ident, Storage, - O_Tnode (Void_Type_Node)); - end Start_Procedure_Decl; - - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode) - is - R : Tree; - begin - R := Build_Decl (PARM_DECL, Ident, Tree (Atype)); - --Set_DECL_CONTEXT (Res, Xxx); - - -- Do type conversion: convert boolean and enums to int - if +PROMOTE_PROTOTYPES then - case Get_TREE_CODE (Tree (Atype)) is - when ENUMERAL_TYPE - | BOOLEAN_TYPE => - Set_DECL_ARG_TYPE (R, Integer_Type_Node); - when others => - Set_DECL_ARG_TYPE (R, Tree (Atype)); - end case; - else - Set_DECL_ARG_TYPE (R, Tree (Atype)); - end if; - - Chain_Append (Interfaces.Param_Chain, R); - List_Append (Interfaces.Param_List, Tree (Atype)); - Res := O_Dnode (R); - end New_Interface_Decl; - - -- Current function nest level, or the number of parents. - Function_Nest_Level : Natural := 0; - - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; Res : out O_Dnode) - is - Decl : Tree; - Result : Tree; - Parm : Tree; - Is_Global : Boolean; - begin - Decl := Build_Decl (FUNCTION_DECL, Interfaces.Ident, - Build_Function_Type (Tree (Interfaces.Rtype), - Interfaces.Param_List.First)); - Is_Global := Function_Nest_Level = 0 - or Interfaces.Storage = O_Storage_External; - if Is_Global then - Set_Storage (Decl, Interfaces.Storage); - else - -- A nested subprogram. - Set_DECL_EXTERNAL (Decl, C_False); - Set_TREE_PUBLIC (Decl, C_False); - end if; - -- The function exist in static storage. - Set_TREE_STATIC (Decl, C_True); - Set_DECL_INITIAL (Decl, Error_Mark_Node); - Set_TREE_ADDRESSABLE (Decl, C_True); - - -- Declare the result. - -- FIXME: should be moved in start_function_body. - Result := Build_Decl (RESULT_DECL, NULL_TREE, Tree (Interfaces.Rtype)); - Set_DECL_RESULT (Decl, Result); - Set_DECL_CONTEXT (Result, Decl); - - Set_DECL_ARGUMENTS (Decl, Interfaces.Param_Chain.First); - -- Set DECL_CONTEXT of parameters. - Parm := Interfaces.Param_Chain.First; - while Parm /= NULL_TREE loop - Set_DECL_CONTEXT (Parm, Decl); - Parm := Get_TREE_CHAIN (Parm); - end loop; - - Pushdecl (Decl); - - if Is_Global then - Rest_Of_Decl_Compilation (Decl, NULL_Chars, C_True, C_False); - else - Expand_Decl (Decl); - end if; - - --Make_Function_Rtl (Decl); - - Res := O_Dnode (Decl); - end Finish_Subprogram_Decl; - - procedure Start_Subprogram_Body (Func : O_Dnode) - is - begin - if Function_Nest_Level /= 0 then - -- For a nested subprogram: - Push_Function_Context; - --start_function (c-decl.c) - -- announce_function - -- current_function_decl = pushdecl (x) - -- ?? - --XXX - --finish_function(1) (c-decl.c) - -- poplevel - --pop_function_context - --add_decl_stmt - end if; - Function_Nest_Level := Function_Nest_Level + 1; - - Current_Function_Decl := Tree (Func); - Announce_Function (Tree (Func)); - - -- Create a binding for the parameters. - Pushlevel (C_False); - -- FIXME: should push parameters. - --Make_Function_Rtl (Current_Function_Decl); - Init_Function_Start (Func, NULL_Chars, 0); - Expand_Function_Start (Func, C_False); - -- Create a binding for the function. - -- This is necessary for compatibility. - Pushlevel (C_False); - Expand_Start_Bindings (0); - end Start_Subprogram_Body; - - procedure Finish_Subprogram_Body - is - begin - Expand_End_Bindings (Getdecls, C_True, C_False); - Poplevel (C_True, C_False, C_False); - Expand_Function_End (NULL_Chars, 0, C_False); - Poplevel (C_True, C_False, C_True); - -- The subprogram is not external anymore (extern inline is not - -- supported). As a result, code will be generated. - Set_DECL_EXTERNAL (Current_Function_Decl, C_False); - - -- FIXME: protect against ggc. See c-decl.c:c_expand_body - Rest_Of_Compilation (Current_Function_Decl); - Function_Nest_Level := Function_Nest_Level - 1; - if Function_Nest_Level > 0 then - Pop_Function_Context; - else - Current_Function_Decl := NULL_TREE; - end if; - end Finish_Subprogram_Body; - - ------------------- - -- Statements. -- - ------------------- - - procedure New_Debug_Line_Stmt (Line : Natural) is - begin - Input_Location.Line := Line; - Emit_Line_Note (Input_Location); - end New_Debug_Line_Stmt; - - procedure New_Debug_Comment_Stmt (Comment : String) - is - pragma Unreferenced (Comment); - begin - null; - end New_Debug_Comment_Stmt; - - procedure Start_Declare_Stmt - is - begin - Pushlevel (C_False); - Expand_Start_Bindings (0); - end Start_Declare_Stmt; - - procedure Finish_Declare_Stmt - is - begin - Expand_End_Bindings (Getdecls, C_True, C_True); - Poplevel (C_True, C_False, C_False); - end Finish_Declare_Stmt; - - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) - is - begin - Assocs.Subprg := Tree (Subprg); - List_Init (Assocs.List); - end Start_Association; - --- function Get_Base_Type (Atype : O_Tnode) return O_Tnode --- is --- begin --- case Atype.Kind is --- when ON_Array_Sub_Type => --- return Atype.Base_Type; --- when others => --- return Atype; --- end case; --- end Get_Base_Type; - - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) - is - begin - List_Append (Assocs.List, Tree (Val)); - end New_Association; - - -- Return a pointer to function FUNC. - function Build_Function_Ptr (Func : Tree) return Tree is - begin - return Build1 (ADDR_EXPR, - Build_Pointer_Type (Get_TREE_TYPE (Func)), Func); - end Build_Function_Ptr; - - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode - is - begin - return O_Enode (Build (CALL_EXPR, - Get_TREE_TYPE (Get_TREE_TYPE (Assocs.Subprg)), - Build_Function_Ptr (Assocs.Subprg), - Assocs.List.First, NULL_TREE)); - end New_Function_Call; - - procedure New_Procedure_Call (Assocs : in out O_Assoc_List) - is - Res : Tree; - begin - Res := Build (CALL_EXPR, - Get_TREE_TYPE (Get_TREE_TYPE (Assocs.Subprg)), - Build_Function_Ptr (Assocs.Subprg), - Assocs.List.First, NULL_TREE); - Set_TREE_SIDE_EFFECTS (Res, C_True); - Expand_Expr_Stmt (Res); - end New_Procedure_Call; - - - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) - is - N : Tree; - begin - N := Build (MODIFY_EXPR, Get_TREE_TYPE (Tree (Target)), - Tree (Target), Tree (Value)); - Set_TREE_SIDE_EFFECTS (N, C_True); - Expand_Expr_Stmt (N); - end New_Assign_Stmt; - - procedure New_Return_Stmt (Value : O_Enode) - is - Assign : Tree; - begin - Assign := Build (MODIFY_EXPR, Get_TREE_TYPE (Tree (Value)), - Get_DECL_RESULT (Current_Function_Decl), - Tree (Value)); - Set_TREE_SIDE_EFFECTS (Assign, C_True); - --Set_TREE_USED (Assign, True); - Expand_Expr_Stmt (Assign); - Expand_Return (Value); - end New_Return_Stmt; - - procedure New_Return_Stmt - is - begin - Expand_Null_Return; - end New_Return_Stmt; - - procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) - is - pragma Unreferenced (Block); - begin - Expand_Start_Cond (Cond, C_False); - end Start_If_Stmt; - - procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode) - is - pragma Unreferenced (Block); - begin - Expand_Start_Elseif (Cond); - end New_Elsif_Stmt; - - procedure New_Else_Stmt (Block : in out O_If_Block) - is - pragma Unreferenced (Block); - begin - Expand_Start_Else; - end New_Else_Stmt; - - procedure Finish_If_Stmt (Block : in out O_If_Block) - is - pragma Unreferenced (Block); - begin - Expand_End_Cond; - end Finish_If_Stmt; - - procedure Start_Loop_Stmt (Label : out O_Snode) - is - begin - Label := Expand_Start_Loop (C_True); - -- This is required to avoid crash with goto fixup. - Expand_Start_Bindings (0); - end Start_Loop_Stmt; - - procedure Finish_Loop_Stmt (Label : in out O_Snode) - is - pragma Unreferenced (Label); - begin - Expand_End_Bindings (NULL_TREE, C_False, C_False); - Expand_End_Loop; - end Finish_Loop_Stmt; - - procedure New_Exit_Stmt (L : O_Snode) is - begin - Expand_Exit_Loop (L); - end New_Exit_Stmt; - - procedure New_Next_Stmt (L : O_Snode) is - begin - Expand_Continue_Loop (L); - end New_Next_Stmt; - - procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) - is - begin - Expand_Start_Case (C_True, Value, Get_TREE_TYPE (Value), NULL_Chars); - Block := O_Case_Block'(Expr => Tree (Value), - First => True, Label => NULL_TREE); - end Start_Case_Stmt; - - procedure Start_Choice (Block : in out O_Case_Block) - is - begin - if Block.First then - Block.First := False; - else - -- Add a "break" statement. - if Expand_Exit_Something = 0 then - raise Type_Error; - end if; - end if; - if Block.Label /= NULL_TREE then - raise Syntax_Error; - end if; - Block.Label := Build_Decl (LABEL_DECL, NULL_TREE, NULL_TREE); - --Pushdecl (Choices.Label); - end Start_Choice; - - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) - is - Duplicate : Tree; - begin - if Pushcase (Tree (Expr), Agcc.Trees.Convert'Address, - Block.Label, Duplicate'Address) /= 0 then - raise Syntax_Error; - end if; - end New_Expr_Choice; - - procedure New_Range_Choice (Block : in out O_Case_Block; - Low, High : O_Cnode) - is - Duplicate : Tree; - begin - if Pushcase_Range (Tree (Low), Tree (High), Agcc.Trees.Convert'Address, - Tree (Block.Label), Duplicate'Address) /= 0 - then - raise Syntax_Error; - end if; - end New_Range_Choice; - - procedure New_Default_Choice (Block : in out O_Case_Block) - is - Duplicate : Tree; - begin - if Pushcase (NULL_TREE, System.Null_Address, - Block.Label, Duplicate'Address) /= 0 - then - raise Syntax_Error; - end if; - end New_Default_Choice; - - procedure Finish_Choice (Block : in out O_Case_Block) - is - begin - Block.Label := NULL_TREE; - end Finish_Choice; - - procedure Finish_Case_Stmt (Block: in out O_Case_Block) is - begin - Expand_End_Case_Type (Block.Expr, NULL_TREE); - end Finish_Case_Stmt; -end Ortho_Gcc; diff --git a/ortho/gcc34/ortho_gcc.ads b/ortho/gcc34/ortho_gcc.ads deleted file mode 100644 index e7c3679..0000000 --- a/ortho/gcc34/ortho_gcc.ads +++ /dev/null @@ -1,557 +0,0 @@ --- Ortho implementation for GCC. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces; use Interfaces; -with Ortho_Ident; -use Ortho_Ident; -with Agcc.Trees; use Agcc.Trees; - - --- Interface to create nodes. -package Ortho_Gcc is - --- PUBLIC DECLARATIONS - -- PUBLIC PART is defined in ortho_nodes.common.ads - type O_Cnode is private; - type O_Dnode is private; - type O_Enode is private; - type O_Fnode is private; - type O_Lnode is private; - type O_Tnode is private; - type O_Snode is private; - - -- Alloca builtin, to be set during initialization. - Alloca_Function_Ptr : Tree; - - -- Must be called during initialization, before use of any subprograms. - procedure Init; - - O_Cnode_Null : constant O_Cnode; - O_Dnode_Null : constant O_Dnode; - O_Enode_Null : constant O_Enode; - O_Fnode_Null : constant O_Fnode; - O_Lnode_Null : constant O_Lnode; - O_Snode_Null : constant O_Snode; - O_Tnode_Null : constant O_Tnode; - - - ------------------------ - -- Type definitions -- - ------------------------ - - type Bitsize_Type is range 0 .. 1024; - - -- Standard types metrics. 0 means unknown. - Metric_Char : Bitsize_Type := 0; - Metric_Short : Bitsize_Type := 0; - Metric_Int : Bitsize_Type := 0; - Metric_Long : Bitsize_Type := 0; - Metric_Long_Long : Bitsize_Type := 0; - Metric_Enum : Bitsize_Type := 0; - Metric_Float : Bitsize_Type := 0; - Metric_Double : Bitsize_Type := 0; - Metric_Long_Double : Bitsize_Type := 0; - - type O_Element_List is limited private; - - -- Build a record type. - procedure Start_Record_Type (Elements : out O_Element_List); - -- Add a field in the record; not constrained array are prohibited, since - -- its size is unlimited. - procedure New_Record_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode); - -- Finish the record type. - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an uncomplete record type: - -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type. - -- This type can be declared or used to define access types on it. - -- Then, complete (if necessary) the record type, by calling - -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE. - procedure New_Uncomplete_Record_Type (Res : out O_Tnode); - procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List); - - -- Build an union type. - procedure Start_Union_Type (Elements : out O_Element_List); - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; - Etype : O_Tnode); - procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode); - - -- Build an access type. - -- DTYPE may be O_tnode_null in order to build an incomplete access type. - -- It is completed with finish_access_type. - function New_Access_Type (Dtype : O_Tnode) return O_Tnode; - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode); - - -- Build an array type. - -- The array is not constrained and unidimensional. - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode; - - -- Build a constrained array type. - function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) - return O_Tnode; - - -- Build a scalar type; size may be 8, 16, 32 or 64. - function New_Unsigned_Type (Size : Natural) return O_Tnode; - function New_Signed_Type (Size : Natural) return O_Tnode; - - -- Build a float type. - function New_Float_Type return O_Tnode; - - -- Build a boolean type. - procedure New_Boolean_Type (Res : out O_Tnode; - False_Id : O_Ident; - False_E : out O_Cnode; - True_Id : O_Ident; - True_E : out O_Cnode); - - -- Create an enumeration - type O_Enum_List is limited private; - - -- Elements are declared in order, the first is ordered from 0. - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural); - procedure New_Enum_Literal (List : in out O_Enum_List; - Ident : O_Ident; Res : out O_Cnode); - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode); - - ---------------- - -- Literals -- - ---------------- - - -- Create a literal from an integer. - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode; - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode; - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode; - - -- Create a null access literal. - function New_Null_Access (Ltype : O_Tnode) return O_Cnode; - - -- Build a record/array aggregate. - -- The aggregate is constant, and therefore can be only used to initialize - -- constant declaration. - -- ATYPE must be either a record type or an array subtype. - -- Elements must be added in the order, and must be literals or aggregates. - type O_Record_Aggr_List is limited private; - type O_Array_Aggr_List is limited private; - - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; - Atype : O_Tnode); - procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; - Value : O_Cnode); - procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; - Res : out O_Cnode); - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode); - procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; - Value : O_Cnode); - procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; - Res : out O_Cnode); - - -- Build an union aggregate. - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode; - - -- Returns the size in bytes of ATYPE. The result is a literal of - -- unsigned type RTYPE - -- ATYPE cannot be an unconstrained array type. - function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; - - -- Returns the offset of FIELD in its record. The result is a literal - -- of unsigned type RTYPE. - function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Cnode; - - -- Get the address of a subprogram. - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - -- Get the address of LVALUE. - -- ATYPE must be a type access whose designated type is the type of LVALUE. - -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; - - ------------------- - -- Expressions -- - ------------------- - - type ON_Op_Kind is - ( - -- Not an operation; invalid. - ON_Nil, - - -- Dyadic operations. - ON_Add_Ov, -- ON_Dyadic_Op_Kind - ON_Sub_Ov, -- ON_Dyadic_Op_Kind - ON_Mul_Ov, -- ON_Dyadic_Op_Kind - ON_Div_Ov, -- ON_Dyadic_Op_Kind - ON_Rem_Ov, -- ON_Dyadic_Op_Kind - ON_Mod_Ov, -- ON_Dyadic_Op_Kind - - -- Binary operations. - ON_And, -- ON_Dyadic_Op_Kind - ON_Or, -- ON_Dyadic_Op_Kind - ON_Xor, -- ON_Dyadic_Op_Kind - ON_And_Then, -- ON_Dyadic_Op_Kind - ON_Or_Else, -- ON_Dyadic_Op_Kind - - -- Monadic operations. - ON_Not, -- ON_Monadic_Op_Kind - ON_Neg_Ov, -- ON_Monadic_Op_Kind - ON_Abs_Ov, -- ON_Monadic_Op_Kind - - -- Comparaisons - ON_Eq, -- ON_Compare_Op_Kind - ON_Neq, -- ON_Compare_Op_Kind - ON_Le, -- ON_Compare_Op_Kind - ON_Lt, -- ON_Compare_Op_Kind - ON_Ge, -- ON_Compare_Op_Kind - ON_Gt -- ON_Compare_Op_Kind - ); - - subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Or_Else; - subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov; - subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt; - - type O_Storage is (O_Storage_External, - O_Storage_Public, - O_Storage_Private, - O_Storage_Local); - -- Specifies the storage kind of a declaration. - -- O_STORAGE_EXTERNAL: - -- The declaration do not either reserve memory nor generate code, and - -- is imported either from an other file or from a later place in the - -- current file. - -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE: - -- The declaration reserves memory or generates code. - -- With O_STORAGE_PUBLIC, the declaration is exported outside of the - -- file while with O_STORAGE_PRIVATE, the declaration is local to the - -- file. - - Type_Error : exception; - Syntax_Error : exception; - - -- Create a value from a literal. - function New_Lit (Lit : O_Cnode) return O_Enode; - - -- Create a dyadic operation. - -- Left and right nodes must have the same type. - -- Binary operation is allowed only on boolean types. - -- The result is of the type of the operands. - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode; - - -- Create a monadic operation. - -- Result is of the type of operand. - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode; - - -- Create a comparaison operator. - -- NTYPE is the type of the result and must be a boolean type. - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) - return O_Enode; - - - type O_Inter_List is limited private; - type O_Assoc_List is limited private; - type O_If_Block is limited private; - type O_Case_Block is limited private; - - - -- Get an element of an array. - -- INDEX must be of the type of the array index. - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode; - - -- Get a slice of an array; this is equivalent to a conversion between - -- an array or an array subtype and an array subtype. - -- RES_TYPE must be an array_sub_type whose base type is the same as the - -- base type of ARR. - -- INDEX must be of the type of the array index. - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode; - - -- Get an element of a record. - -- Type of REC must be a record type. - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; - - -- Reference an access. - -- Type of ACC must be an access type. - function New_Access_Element (Acc : O_Enode) return O_Lnode; - - -- Do a conversion. - -- Allowed conversions are: - -- FIXME: to write. - function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode; - - -- Get the address of LVALUE. - -- ATYPE must be a type access whose designated type is the type of LVALUE. - -- FIXME: what about arrays. - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode; - - -- Same as New_Address but without any restriction. - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode; - - -- Get the value of an Lvalue. - function New_Value (Lvalue : O_Lnode) return O_Enode; - function New_Obj_Value (Obj : O_Dnode) return O_Enode; - - -- Get an lvalue from a declaration. - function New_Obj (Obj : O_Dnode) return O_Lnode; - - -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; - - -- Declare a type. - -- This simply gives a name to a type. - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode); - - --------------------- - -- Declarations. -- - --------------------- - - -- Filename of the next declaration. - procedure New_Debug_Filename_Decl (Filename : String); - - -- Line number of the next declaration. - procedure New_Debug_Line_Decl (Line : Natural); - - -- Add a comment in the declarative region. - procedure New_Debug_Comment_Decl (Comment : String); - - -- Declare a constant. - -- This simply gives a name to a constant value or aggregate. - -- A constant cannot be modified and its storage cannot be local. - -- ATYPE must be constrained. - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Set the value of a non-external constant. - procedure Start_Const_Value (Const : in out O_Dnode); - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode); - - -- Create a variable declaration. - -- A variable can be local only inside a function. - -- ATYPE must be constrained. - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); - - -- Start a subprogram declaration. - -- Note: nested subprograms are allowed, ie o_storage_local subprograms can - -- be declared inside a subprograms. It is not allowed to declare - -- o_storage_external subprograms inside a subprograms. - -- Return type and interfaces cannot be a composite type. - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode); - -- For a subprogram without return value. - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage); - - -- Add an interface declaration to INTERFACES. - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode); - -- Finish the function declaration, get the node and a statement list. - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; Res : out O_Dnode); - -- Start a subprogram body. - -- Note: the declaration may have an external storage, in this case it - -- becomes public. - procedure Start_Subprogram_Body (Func : O_Dnode); - -- Finish a subprogram body. - procedure Finish_Subprogram_Body; - - - ------------------- - -- Statements. -- - ------------------- - - -- Add a line number as a statement. - procedure New_Debug_Line_Stmt (Line : Natural); - - -- Add a comment as a statement. - procedure New_Debug_Comment_Stmt (Comment : String); - - -- Start a declarative region. - procedure Start_Declare_Stmt; - procedure Finish_Declare_Stmt; - - -- Create a function call or a procedure call. - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode); - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode); - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode; - procedure New_Procedure_Call (Assocs : in out O_Assoc_List); - - -- Assign VALUE to TARGET, type must be the same or compatible. - -- FIXME: what about slice assignment? - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode); - - -- Exit from the subprogram and return VALUE. - procedure New_Return_Stmt (Value : O_Enode); - -- Exit from the subprogram, which doesn't return value. - procedure New_Return_Stmt; - - -- Build an IF statement. - procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode); - -- COND is NULL for the final else statement. - procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode); - procedure New_Else_Stmt (Block : in out O_If_Block); - procedure Finish_If_Stmt (Block : in out O_If_Block); - - -- Create a infinite loop statement. - procedure Start_Loop_Stmt (Label : out O_Snode); - procedure Finish_Loop_Stmt (Label : in out O_Snode); - - -- Exit from a loop stmt or from a for stmt. - procedure New_Exit_Stmt (L : O_Snode); - -- Go to the start of a loop stmt or of a for stmt. - -- Loops/Fors between L and the current points are exited. - procedure New_Next_Stmt (L : O_Snode); - - -- Case statement. - -- VALUE is the selector and must be a discrete type. - procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode); - -- A choice branch is composed of expr, range or default choices. - -- A choice branch is enclosed between a Start_Choice and a Finish_Choice. - -- The statements are after the finish_choice. - procedure Start_Choice (Block : in out O_Case_Block); - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode); - procedure New_Range_Choice (Block : in out O_Case_Block; - Low, High : O_Cnode); - procedure New_Default_Choice (Block : in out O_Case_Block); - procedure Finish_Choice (Block : in out O_Case_Block); - procedure Finish_Case_Stmt (Block : in out O_Case_Block); - -private - type O_Cnode is new Tree; - type O_Dnode is new Tree; - type O_Enode is new Tree; - type O_Fnode is new Tree; - type O_Lnode is new Tree; - type O_Tnode is new Tree; - type O_Snode is new Nesting; - - O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE); - O_Dnode_Null : constant O_Dnode := O_Dnode (NULL_TREE); - O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE); - O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE); - O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE); - O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE); - O_Snode_Null : constant O_Snode := O_Snode (Nesting_Null); - - - -- Efficiently append element EL to a chain. - -- FIRST is the first element of the chain (must NULL_TREE if the chain - -- is empty), - -- LAST is the last element of the chain (idem). - type Chain_Constr_Type is record - First : Tree; - Last : Tree; - end record; - procedure Chain_Init (Constr : out Chain_Constr_Type); - procedure Chain_Append (Constr : in out Chain_Constr_Type; El : Tree); - - -- Efficiently append element EL to a list. - type List_Constr_Type is record - First : Tree; - Last : Tree; - end record; - procedure List_Init (Constr : out List_Constr_Type); - procedure List_Append (Constr : in out List_Constr_Type; El : Tree); - - type O_Inter_List is record - Ident : O_Ident; - Storage : O_Storage; - -- Return type. - Rtype : O_Tnode; - -- List of parameter types. - Param_List : List_Constr_Type; - -- Chain of parameters declarations. - Param_Chain : Chain_Constr_Type; - end record; - - type O_Element_List is record - Res : Tree; - Chain : Chain_Constr_Type; - end record; - - type O_Case_Block is record - Expr : Tree; - First : Boolean; - Label : Tree; - end record; - - type O_If_Block is record - null; - end record; - - type O_Aggr_List is record - Atype : Tree; - Chain : Chain_Constr_Type; - end record; - - type O_Record_Aggr_List is new O_Aggr_List; - type O_Array_Aggr_List is new O_Aggr_List; - - type O_Assoc_List is record - Subprg : Tree; - List : List_Constr_Type; - end record; - - type O_Enum_List is record - -- The enumeral_type node. - Res : Tree; - -- Chain of literals. - Chain : Chain_Constr_Type; - -- Numeral value (from 0 to nbr - 1) of the next literal to be declared. - Num : Natural; - -- Size of the enumeration type. - Size : Natural; - end record; - -end Ortho_Gcc; diff --git a/ortho/gcc34/ortho_gcc.private.ads b/ortho/gcc34/ortho_gcc.private.ads deleted file mode 100644 index c4a0135..0000000 --- a/ortho/gcc34/ortho_gcc.private.ads +++ /dev/null @@ -1,122 +0,0 @@ --- Ortho implementation for GCC. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Agcc.Trees; use Agcc.Trees; - -package Ortho_Nodes is - -- PUBLIC PART is defined in ortho_nodes.common.ads - type O_Cnode is private; - type O_Dnode is private; - type O_Enode is private; - type O_Fnode is private; - type O_Lnode is private; - type O_Tnode is private; - type O_Snode is private; - - -- Alloca builtin, to be set during initialization. - Alloca_Function_Ptr : Tree; - - -- Must be called during initialization, before use of any subprograms. - procedure Init; -private - type O_Cnode is new Tree; - type O_Dnode is new Tree; - type O_Enode is new Tree; - type O_Fnode is new Tree; - type O_Lnode is new Tree; - type O_Tnode is new Tree; - type O_Snode is new Nesting; - - O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE); - O_Dnode_Null : constant O_Dnode := O_Dnode (NULL_TREE); - O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE); - O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE); - O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE); - O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE); - O_Snode_Null : constant O_Snode := O_Snode (Nesting_Null); - - - -- Efficiently append element EL to a chain. - -- FIRST is the first element of the chain (must NULL_TREE if the chain - -- is empty), - -- LAST is the last element of the chain (idem). - type Chain_Constr_Type is record - First : Tree; - Last : Tree; - end record; - procedure Chain_Init (Constr : out Chain_Constr_Type); - procedure Chain_Append (Constr : in out Chain_Constr_Type; El : Tree); - - -- Efficiently append element EL to a list. - type List_Constr_Type is record - First : Tree; - Last : Tree; - end record; - procedure List_Init (Constr : out List_Constr_Type); - procedure List_Append (Constr : in out List_Constr_Type; El : Tree); - - type O_Inter_List is record - Ident : O_Ident; - Storage : O_Storage; - -- Return type. - Rtype : O_Tnode; - -- List of parameter types. - Param_List : List_Constr_Type; - -- Chain of parameters declarations. - Param_Chain : Chain_Constr_Type; - end record; - - type O_Element_List is record - Res : Tree; - Chain : Chain_Constr_Type; - end record; - - type O_Case_Block is record - Expr : Tree; - First : Boolean; - Label : Tree; - end record; - - type O_If_Block is record - null; - end record; - - type O_Aggr_List is record - Atype : Tree; - Chain : Chain_Constr_Type; - end record; - - type O_Record_Aggr_List is new O_Aggr_List; - type O_Array_Aggr_List is new O_Aggr_List; - - type O_Assoc_List is record - Subprg : Tree; - List : List_Constr_Type; - end record; - - type O_Enum_List is record - -- The enumeral_type node. - Res : Tree; - -- Chain of literals. - Chain : Chain_Constr_Type; - -- Numeral value (from 0 to nbr - 1) of the next literal to be declared. - Num : Natural; - -- Size of the enumeration type. - Size : Natural; - end record; - -end Ortho_Nodes; diff --git a/ortho/gcc34/ortho_gcc_front.ads b/ortho/gcc34/ortho_gcc_front.ads deleted file mode 100644 index 0b98f45..0000000 --- a/ortho/gcc34/ortho_gcc_front.ads +++ /dev/null @@ -1,19 +0,0 @@ --- Ortho implementation for GCC. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ortho_Front; -package Ortho_Gcc_Front renames Ortho_Front; diff --git a/ortho/gcc34/ortho_ident.adb b/ortho/gcc34/ortho_ident.adb deleted file mode 100644 index a3779f3..0000000 --- a/ortho/gcc34/ortho_ident.adb +++ /dev/null @@ -1,52 +0,0 @@ --- Ortho implementation for GCC. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Agcc; use Agcc; -with Agcc.Trees; -with C; use C; - -package body Ortho_Ident is - function Get_Identifier (Str : String) return O_Ident - is - Str_Nul : String := Str & Nul; - begin - return Get_Identifier (Str_Nul'Address); - end Get_Identifier; - - function Get_String (Id : O_Ident) return String - is - use Agcc.Trees; - Str : C_Str_Len; - begin - Str.Len := Get_IDENTIFIER_LENGTH (Id); - Str.Str := To_C_String (Get_IDENTIFIER_POINTER (Id)); - return Image (Str); - end Get_String; - - function Is_Equal (Id : O_Ident; Str : String) return Boolean - is - S : C_String; - begin - if Get_IDENTIFIER_LENGTH (Id) /= Str'Length then - return False; - end if; - S := To_C_String (Get_IDENTIFIER_POINTER (Id)); - return S.all (1 .. Str'Length) = Str; - end Is_Equal; - -end Ortho_Ident; - diff --git a/ortho/gcc34/ortho_ident.ads b/ortho/gcc34/ortho_ident.ads deleted file mode 100644 index 84a330e..0000000 --- a/ortho/gcc34/ortho_ident.ads +++ /dev/null @@ -1,30 +0,0 @@ --- Ortho implementation for GCC. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Agcc.Trees; use Agcc.Trees; - -package Ortho_Ident is - subtype O_Ident is Tree; - function Get_Identifier (Str : String) return O_Ident; - function Get_String (Id : O_Ident) return String; - function Is_Equal (L, R : O_Ident) return Boolean renames - Agcc.Trees."="; - function Is_Equal (Id : O_Ident; Str : String) return Boolean; - O_Ident_Nul : constant O_Ident; -private - O_Ident_Nul : constant O_Ident := NULL_TREE; -end Ortho_Ident; diff --git a/ortho/gcc34/ortho_nodes.ads b/ortho/gcc34/ortho_nodes.ads deleted file mode 100644 index 04d9018..0000000 --- a/ortho/gcc34/ortho_nodes.ads +++ /dev/null @@ -1,20 +0,0 @@ --- Ortho implementation for GCC. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ortho_Gcc; - -package Ortho_Nodes renames Ortho_Gcc; |