summaryrefslogtreecommitdiff
path: root/ortho
diff options
context:
space:
mode:
authorTristan Gingold2014-03-12 03:44:18 +0100
committerTristan Gingold2014-03-12 03:44:18 +0100
commit8fc7559a26a3c634b7c87ada03744f5f31637b32 (patch)
tree125b7264888d5f87f72865f20bda953a120846e8 /ortho
parent0594d17c40ce054f61d2a5679e377467ebc7c796 (diff)
downloadghdl-8fc7559a26a3c634b7c87ada03744f5f31637b32.tar.gz
ghdl-8fc7559a26a3c634b7c87ada03744f5f31637b32.tar.bz2
ghdl-8fc7559a26a3c634b7c87ada03744f5f31637b32.zip
Remove old and unused agcc and gcc34 subdirs.
Diffstat (limited to 'ortho')
-rw-r--r--ortho/agcc/Makefile.inc112
-rw-r--r--ortho/agcc/agcc-autils.adb93
-rw-r--r--ortho/agcc/agcc-autils.ads28
-rw-r--r--ortho/agcc/agcc-bindings.c738
-rw-r--r--ortho/agcc/agcc-convert.ads26
-rw-r--r--ortho/agcc/agcc-diagnostic.ads24
-rw-r--r--ortho/agcc/agcc-fe.ads238
-rw-r--r--ortho/agcc/agcc-ggc.ads33
-rw-r--r--ortho/agcc/agcc-ghdl.c658
-rw-r--r--ortho/agcc/agcc-hconfig.ads.in21
-rw-r--r--ortho/agcc/agcc-hwint.ads.in23
-rw-r--r--ortho/agcc/agcc-input.ads29
-rw-r--r--ortho/agcc/agcc-libiberty.ads21
-rw-r--r--ortho/agcc/agcc-machmode.ads.in35
-rw-r--r--ortho/agcc/agcc-options.ads.in31
-rw-r--r--ortho/agcc/agcc-output.ads24
-rw-r--r--ortho/agcc/agcc-real.ads.in42
-rw-r--r--ortho/agcc/agcc-rtl.ads31
-rw-r--r--ortho/agcc/agcc-stor_layout.ads24
-rw-r--r--ortho/agcc/agcc-tm.ads.in37
-rw-r--r--ortho/agcc/agcc-toplev.ads51
-rw-r--r--ortho/agcc/agcc-trees.adb33
-rw-r--r--ortho/agcc/agcc-trees.ads.in514
-rw-r--r--ortho/agcc/agcc.adb23
-rw-r--r--ortho/agcc/agcc.ads45
-rw-r--r--ortho/agcc/agcc.sed23
-rw-r--r--ortho/agcc/c.adb55
-rw-r--r--ortho/agcc/c.ads64
-rw-r--r--ortho/agcc/gen_tree.c575
-rw-r--r--ortho/gcc34/Makefile50
-rw-r--r--ortho/gcc34/agcc-fe.adb776
-rw-r--r--ortho/gcc34/lang.opt88
-rw-r--r--ortho/gcc34/ortho_gcc-main.adb44
-rw-r--r--ortho/gcc34/ortho_gcc-main.ads18
-rw-r--r--ortho/gcc34/ortho_gcc.adb1362
-rw-r--r--ortho/gcc34/ortho_gcc.ads557
-rw-r--r--ortho/gcc34/ortho_gcc.private.ads122
-rw-r--r--ortho/gcc34/ortho_gcc_front.ads19
-rw-r--r--ortho/gcc34/ortho_ident.adb52
-rw-r--r--ortho/gcc34/ortho_ident.ads30
-rw-r--r--ortho/gcc34/ortho_nodes.ads20
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;