I have managed to get GHDL to build with gcc4.8.2 as both the compiler and the sources.
Instructions (README), build script and patch attached. Testing so far is approximately none, so I welcome any reports of success or otherwise. Good luck! - Brian
Instructions for building GHDL (version 0.31dev) with GCC4.8.2
0) Create a project directory and a "source" directory in it.
The build process will later add a "build" directory here.
You also need in this directory :
the patch file, svn_r150_to_gcc_482.patch
the build script, build_gcc.sh
1) Download gcc-4.8.2.tar.bz2 from ...
ftp://ftp.mirrorservice.org/sites/sourceware.org/pub/gcc/releases/gcc-4.8.2/
(or other mirror listed on http://gcc.gnu.org/mirrors.html) and untar it into
"source" - there should now be a
"source/gcc-4.8.2" folder.
2) Load the prerequisites for building GCC. GCC now provides a script to do
this:
cd source/gcc-4.8.2
./contrib/download_prerequisites
3) Download the GHDL source SVN commit R150 from gna.org.
This is currently the snapshot : http://svn.gna.org/daily/ghdl-snapshot.tar.gz
Untar that into "source" so there should be a "source/ghdl" folder.
4) Apply the patch (assuming it is in the project directory) :
cd source
patch -p0 < ../svn_r150_to_gcc_482.patch
It should apply cleanly with no fuzz
5) Following the instructions in source/ghdl/README
"Use the ./translate/gcc/dist.sh script to create sources to be included in GCC:
cd ghdl/translate/gcc
./dist.sh sources
This generates a ghdl-VERSION.tar.bz2 file."
6) Untar the latter (ghdl-0.31dev.tar.bz2) to the "source" folder, this should
create a "source/ghdl-0.31dev" folder containing a "whdl" folder.
7) Copy the "vhdl" folder from source/ghdl-0.31dev to source/gcc-4.8.2/gcc
8) Edit the build_gcc.sh script (in the project directory) so that:
ROOTDIR points to the project directory
PREFIX points where you want the compiler to be installed, e.g.
/usr/local
if you want the compiler in /usr/local/bin
"#export LIBRARY_PATH" is commented in if you have multilib problems on
Debian
(sometimes appear as "C compiler cannot create executables" error
messages)
9) From the project directory, execute the script
./build_gcc.sh
If you get a clean build:
10) Via sudo or as root,
cd build
make install
diff -u -r -u ../r150/ghdl/files_map.adb ghdl/files_map.adb
--- ../r150/ghdl/files_map.adb 2010-01-12 03:15:20.000000000 +0000
+++ ghdl/files_map.adb 2013-11-25 17:47:01.000000000 +0000
@@ -757,6 +757,9 @@
declare
Filename : String := Get_Pathname (Directory, Name, True);
begin
+ if not Is_Regular_File(Filename) then
+ return No_Source_File_Entry;
+ end if;
Fd := Open_Read (Filename'Address, Binary);
if Fd = Invalid_FD then
return No_Source_File_Entry;
diff -u -r -u ../r150/ghdl/ortho/gcc/lang.opt ghdl/ortho/gcc/lang.opt
--- ../r150/ghdl/ortho/gcc/lang.opt 2012-12-11 02:46:11.000000000 +0000
+++ ghdl/ortho/gcc/lang.opt 2013-11-25 17:48:43.000000000 +0000
@@ -22,8 +22,8 @@
Set the directory of the work library
P
-vhdl Joined
--P<dir> Add <dir> to the end of the vhdl library path
+vhdl JoinedOrMissing
+;-P<dir> Add <dir> to the end of the vhdl library path
-elab
vhdl Separate
diff -u -r -u ../r150/ghdl/ortho/gcc/Makefile.inc ghdl/ortho/gcc/Makefile.inc
--- ../r150/ghdl/ortho/gcc/Makefile.inc 2008-08-30 14:30:19.000000000 +0100
+++ ghdl/ortho/gcc/Makefile.inc 2013-11-25 18:54:50.567692381 +0000
@@ -32,6 +32,7 @@
AGCC_DEPS := $(AGCC_LOCAL_OBJS)
AGCC_OBJS := $(AGCC_LOCAL_OBJS) \
$(AGCC_GCCOBJ_DIR)gcc/toplev.o \
+ $(AGCC_GCCOBJ_DIR)gcc/vec.o \
$(AGCC_GCCOBJ_DIR)gcc/attribs.o \
$(AGCC_GCCOBJ_DIR)gcc/libbackend.a \
$(AGCC_GCCOBJ_DIR)libcpp/libcpp.a \
@@ -40,7 +41,7 @@
ortho-lang.o: $(agcc_srcdir)/ortho-lang.c \
$(AGCC_GCCOBJ_DIR)gcc/gtype-vhdl.h \
$(AGCC_GCCOBJ_DIR)gcc/gt-vhdl-ortho-lang.h
- $(CC) -c -o $@ $< $(AGCC_CFLAGS)
+ $(COMPILER) -c -o $@ $< $(AGCC_CFLAGS) $(INCLUDES)
agcc-clean: force
$(RM) -f $(agcc_objdir)/*.o
diff -u -r -u ../r150/ghdl/ortho/gcc/ortho_gcc.ads ghdl/ortho/gcc/ortho_gcc.ads
--- ../r150/ghdl/ortho/gcc/ortho_gcc.ads 2012-12-11 02:46:11.000000000 +0000
+++ ghdl/ortho/gcc/ortho_gcc.ads 2013-11-25 17:48:43.000000000 +0000
@@ -415,13 +415,15 @@
-- 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);
- procedure Start_Choice (Block : in out O_Case_Block);
+ -- procedure Start_Choice (Block : in out O_Case_Block);
+ procedure Start_Choice (Block : in out O_Case_Block; Value : O_Enode);
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);
+ procedure Debug_Tree_C(Expr : O_Cnode);
private
subtype Tree is System.Address;
@@ -657,4 +659,7 @@
pragma Import (C, New_Default_Choice);
pragma Import (C, Finish_Choice);
pragma Import (C, Finish_Case_Stmt);
+
+ pragma Import (C, Debug_Tree_C);
+
end Ortho_Gcc;
diff -u -r -u ../r150/ghdl/ortho/gcc/ortho_gcc-main.adb ghdl/ortho/gcc/ortho_gcc-main.adb
--- ../r150/ghdl/ortho/gcc/ortho_gcc-main.adb 2006-07-10 22:00:41.000000000 +0100
+++ ghdl/ortho/gcc/ortho_gcc-main.adb 2013-11-25 17:48:43.000000000 +0000
@@ -12,7 +12,7 @@
function Toplev_Main (Argc : Integer; Argv : System.Address)
return Integer;
- pragma Import (C, Toplev_Main);
+ pragma Import (C, Toplev_Main, "toplev_main_c");
Status : Exit_Status;
begin
diff -u -r -u ../r150/ghdl/ortho/gcc/ortho_ident.adb ghdl/ortho/gcc/ortho_ident.adb
--- ../r150/ghdl/ortho/gcc/ortho_ident.adb 2008-08-30 14:30:19.000000000 +0100
+++ ghdl/ortho/gcc/ortho_ident.adb 2013-11-25 17:48:43.000000000 +0000
@@ -1,7 +1,7 @@
package body Ortho_Ident is
function Get_Identifier_With_Length (Str : Address; Size : Integer)
return O_Ident;
- pragma Import (C, Get_Identifier_With_Length);
+ pragma Import (C, Get_Identifier_With_Length, "get_identifier_with_length_c");
function Compare_Identifier_String
(Id : O_Ident; Str : Address; Size : Integer)
diff -u -r -u ../r150/ghdl/ortho/gcc/ortho-lang.c ghdl/ortho/gcc/ortho-lang.c
--- ../r150/ghdl/ortho/gcc/ortho-lang.c 2012-12-11 02:46:11.000000000 +0000
+++ ghdl/ortho/gcc/ortho-lang.c 2013-11-25 17:48:43.000000000 +0000
@@ -64,6 +64,7 @@
/* Chain of statements currently generated. */
static GTY(()) tree cur_stmts = NULL_TREE;
+
static void
push_binding (void)
{
@@ -187,19 +188,26 @@
}
/* This is a stack of current statement_lists */
-static GTY(()) VEC_tree_gc * stmt_list_stack;
+//static GTY(()) VEC_tree_gc * stmt_list_stack;
+
+// naive conversion to new vec API following the wiki at
+// http://gcc.gnu.org/wiki/cxx-conversion/cxx-vec
+// see also push_stmts, pop_stmts
+static vec <tree> stmt_list_stack = vec<tree>();
static void
push_stmts (tree stmts)
{
- VEC_safe_push (tree, gc, stmt_list_stack, cur_stmts);
+// VEC_safe_push (tree, gc, stmt_list_stack, cur_stmts);
+ stmt_list_stack.safe_push(cur_stmts);
cur_stmts = stmts;
}
static void
pop_stmts (void)
{
- cur_stmts = VEC_pop (tree, stmt_list_stack);
+// cur_stmts = VEC_pop (tree, stmt_list_stack);
+cur_stmts = stmt_list_stack.pop();
}
static void
@@ -214,7 +222,7 @@
static GTY(()) tree top;
static GTY(()) tree stack_alloc_function_ptr;
-extern void ortho_fe_init (void);
+extern "C" void ortho_fe_init (void);
static bool
global_bindings_p (void)
@@ -232,7 +240,7 @@
builtin_function (const char *name,
tree type,
int function_code,
- enum built_in_class class,
+ enum built_in_class decl_class,
const char *library_name,
tree attrs ATTRIBUTE_UNUSED);
@@ -341,7 +349,7 @@
return false;
}
-extern bool lang_handle_option (const char *opt, const char *arg);
+extern "C" bool lang_handle_option (const char *opt, const char *arg);
static bool
ortho_handle_option (size_t code, const char *arg, int value, int kind,
@@ -370,7 +378,7 @@
len1 = strlen (opt);
len2 = strlen (arg);
- nopt = alloca (len1 + len2 + 1);
+ nopt = (char *) alloca (len1 + len2 + 1);
memcpy (nopt, opt, len1);
memcpy (nopt + len1, arg, len2);
nopt[len1 + len2] = 0;
@@ -380,7 +388,7 @@
}
}
-extern int lang_parse_file (const char *filename);
+extern "C" int lang_parse_file (const char *filename);
static void
ortho_parse_file (void)
@@ -584,7 +592,7 @@
builtin_function (const char *name,
tree type,
int function_code,
- enum built_in_class class,
+ enum built_in_class decl_class,
const char *library_name,
tree attrs ATTRIBUTE_UNUSED)
{
@@ -595,8 +603,8 @@
if (library_name)
SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
make_decl_rtl (decl);
- DECL_BUILT_IN_CLASS (decl) = class;
- DECL_FUNCTION_CODE (decl) = function_code;
+ DECL_BUILT_IN_CLASS (decl) = decl_class;
+ DECL_FUNCTION_CODE (decl) = (built_in_function) function_code;
DECL_SOURCE_LOCATION (decl) = input_location;
return decl;
}
@@ -629,7 +637,11 @@
if (precision <= MAX_BITS_PER_WORD)
signed_and_unsigned_types[precision][unsignedp] = t;
-
+ else
+ // Handle larger requests by returning a NULL tree and letting
+ // the back end default to another approach.
+ t = NULL_TREE;
+
return t;
}
@@ -705,6 +717,10 @@
char dummy;
};
+
+extern "C" {
+
+
struct GTY(()) chain_constr_type
{
tree first;
@@ -1198,6 +1214,8 @@
start_enum_type (struct o_enum_list *list, int size)
{
list->res = make_node (ENUMERAL_TYPE);
+ // as of gcc4.8, TYPE_PRECISION of 0 is rigorously enforced!
+ TYPE_PRECISION(list->res) = size;
chain_init (&list->chain);
list->num = 0;
list->size = size;
@@ -1205,8 +1223,14 @@
void
new_enum_literal (struct o_enum_list *list, tree ident, tree *res)
+
{
- *res = build_int_cstu (list->res, list->num);
+ /* tree temp;
+ warning(OPT_Wall,"Debug enum ident %d precision %d", list-> num, TYPE_PRECISION(list->res));
+ debug_tree(ident);
+ temp = build_int_cstu (list->res, HOST_WIDE_INT(list->num));
+ debug_tree(temp); */
+ *res = build_int_cstu (list->res, HOST_WIDE_INT(list->num));
chain_append (&list->chain, tree_cons (ident, *res, NULL_TREE));
list->num++;
}
@@ -1229,7 +1253,8 @@
/* Type of the next field to be added. */
tree field;
/* Vector of elements. */
- VEC(constructor_elt,gc) *elts;
+ // VEC(constructor_elt,gc) *elts;
+ vec<constructor_elt,va_gc> *elts;
};
void
@@ -1237,8 +1262,8 @@
{
list->atype = atype;
list->field = TYPE_FIELDS (atype);
- list->elts = VEC_alloc (constructor_elt, gc, fields_length (atype));
-
+ //list->elts = VEC_alloc (constructor_elt, gc, fields_length (atype));
+ vec_alloc(list->elts, fields_length (atype));
}
void
@@ -1259,7 +1284,8 @@
{
tree atype;
/* Vector of elements. */
- VEC(constructor_elt,gc) *elts;
+ //VEC(constructor_elt,gc) *elts;
+ vec<constructor_elt,va_gc> *elts;
};
void
@@ -1275,7 +1301,8 @@
gcc_assert (nelts != NULL_TREE && host_integerp (nelts, 1));
n = tree_low_cst (nelts, 1) + 1;
- list->elts = VEC_alloc (constructor_elt, gc, n);
+ //list->elts = VEC_alloc (constructor_elt, gc, n);
+ vec_alloc(list->elts, n);
}
void
@@ -1843,20 +1870,22 @@
struct GTY(()) o_assoc_list
{
tree subprg;
- VEC(tree,gc) *vec;
+// VEC(tree,gc) *vec;
+ vec<tree, va_gc> *vecptr;
};
void
start_association (struct o_assoc_list *assocs, tree subprg)
{
assocs->subprg = subprg;
- assocs->vec = NULL;
+ assocs->vecptr = NULL;
}
void
new_association (struct o_assoc_list *assocs, tree val)
{
- VEC_safe_push (tree, gc, assocs->vec, val);
+// VEC_safe_push (tree, gc, assocs->vec, val);
+ vec_safe_push(assocs->vecptr, val);
}
tree
@@ -1864,7 +1893,7 @@
{
return build_call_vec (TREE_TYPE (TREE_TYPE (assocs->subprg)),
build_function_ptr (assocs->subprg),
- assocs->vec);
+ assocs->vecptr);
}
void
@@ -1874,7 +1903,7 @@
res = build_call_vec (TREE_TYPE (TREE_TYPE (assocs->subprg)),
build_function_ptr (assocs->subprg),
- assocs->vec);
+ assocs->vecptr);
TREE_SIDE_EFFECTS (res) = 1;
append_stmt (res);
}
@@ -2044,23 +2073,32 @@
{
tree stmt;
tree stmts;
+// following https://bitbucket.org/goshawk/gdc/issue/344/compilation-with-latest-trunk-fails
+// gimplify_switch_expr now checks type of index expr is (some discrete type) but at least not void
+ tree t_condtype = TREE_TYPE(value);
block->end_label = build_label ();
block->add_break = 0;
stmts = alloc_stmt_list ();
- stmt = build3 (SWITCH_EXPR, void_type_node, value, stmts, NULL_TREE);
+ //stmt = build3 (SWITCH_EXPR, void_type_node, value, stmts, NULL_TREE);
+ stmt = build3 (SWITCH_EXPR, t_condtype, value, stmts, NULL_TREE);
append_stmt (stmt);
push_stmts (stmts);
}
void
-start_choice (struct o_case_block *block)
+//start_choice (struct o_case_block *block)
+start_choice (struct o_case_block *block, tree value)
{
tree stmt;
+// following https://bitbucket.org/goshawk/gdc/issue/344/compilation-with-latest-trunk-fails
+// gimplify_switch_expr now checks type of index expr is (some discrete type) but at least not void
+ tree t_condtype = TREE_TYPE(value);
if (block->add_break)
{
- stmt = build1 (GOTO_EXPR, void_type_node, block->end_label);
+// stmt = build1 (GOTO_EXPR, void_type_node, block->end_label);
+ stmt = build1 (GOTO_EXPR, t_condtype, block->end_label);
append_stmt (stmt);
block->add_break = 0;
@@ -2071,9 +2109,15 @@
new_expr_choice (struct o_case_block *block, tree expr)
{
tree stmt;
-
+// warning(OPT_Wall,"new_expr_choice : %ld ", TREE_INT_CST_LOW(expr));
+// debug_tree(expr);
+
stmt = build_case_label
(expr, NULL_TREE, create_artificial_label (input_location));
+
+// tree low = CASE_LOW (stmt);
+// warning(OPT_Wall,"built : low %ld ", TREE_INT_CST_LOW(low));
+
append_stmt (stmt);
}
@@ -2131,6 +2175,27 @@
*str = IDENTIFIER_POINTER (id);
}
+// C linkage wrappers for two (now C++) functions so that
+// Ada code can call them without name mangling
+tree get_identifier_with_length_c (const char *c, size_t s)
+{
+ return get_identifier_with_length(c, s);
+}
+
+int toplev_main_c (int argc, char **argv)
+{
+ return toplev_main(argc, argv);
+}
+
+void
+debug_tree_c ( tree expr)
+{
+ warning(OPT_Wall,"Debug tree");
+ debug_tree(expr);
+}
+
+} // end extern "C"
+
#include "debug.h"
#include "gt-vhdl-ortho-lang.h"
#include "gtype-vhdl.h"
diff -u -r -u ../r150/ghdl/sem_names.adb ghdl/sem_names.adb
--- ../r150/ghdl/sem_names.adb 2010-01-12 03:15:20.000000000 +0000
+++ ghdl/sem_names.adb 2013-11-25 17:47:01.000000000 +0000
@@ -1449,19 +1449,51 @@
is
Prot_Type : Iir;
Method : Iir;
+ Found : Boolean := False;
begin
Prot_Type := Get_Type (Sub_Name);
- Method := Find_Name_In_Chain
- (Get_Declaration_Chain (Prot_Type), Suffix);
- if Method = Null_Iir then
+
+-- bld 26 apr 2013 : the following returned the FIRST method matching name
+-- rather than the full overload list.
+-- Method := Find_Name_In_Chain
+-- (Get_Declaration_Chain (Prot_Type), Suffix);
+-- if Method = Null_Iir then
+-- Error_Msg_Sem
+-- ("no method " & Name_Table.Image (Suffix) & " in "
+-- & Disp_Node (Prot_Type), Name);
+-- return;
+-- else
+-- Add_Result (Res, Method);
+-- end if;
+
+ -- build overload list from all declarations in chain, matching name,
+ -- which are actually functions or procedures.
+ -- TODO: should we error here if there's a variable with matching name?
+ -- currently we warn...
+ -- rather than add a "Find_nth_name_in chain" to iirs_utils I have expanded the chain walk here.
+ Method := Get_Declaration_Chain (Prot_Type);
+ while Method /= Null_Iir loop
+ If Get_Identifier (Method) = Suffix then -- found the name
+ -- check it's a method!
+ case Get_Kind (Method) is
+ when Iir_Kind_Function_Declaration |
+ Iir_Kind_Procedure_Declaration =>
+ Found := True;
+ Add_Result (Res, Method);
+ when others =>
+ Warning_Msg_Sem ("sem_as_method_call", Method);
+ end case;
+ end if;
+ Method := Get_Chain (Method);
+ end loop;
+ if not Found then
Error_Msg_Sem
("no method " & Name_Table.Image (Suffix) & " in "
& Disp_Node (Prot_Type), Name);
return;
- else
- Add_Result (Res, Method);
end if;
+-- following is handled by later stages
-- case Get_Kind (Method) is
-- when Iir_Kind_Function_Declaration =>
-- Call := Create_Iir (Iir_Kind_Function_Call);
@@ -1958,8 +1990,8 @@
end;
if Res = Null_Iir then
Error_Msg_Sem
- ("prefix is neither a function name "
- & "nor can it be sliced or indexed", Name);
+ ("No overloaded subprogram found matching "
+ & disp_node(Prefix_Name), Name);
end if;
when Iir_Kinds_Function_Declaration =>
Add_Result (Res, Sem_As_Function_Call (Prefix_Name,
diff -u -r -u ../r150/ghdl/translate/gcc/Make-lang.in ghdl/translate/gcc/Make-lang.in
--- ../r150/ghdl/translate/gcc/Make-lang.in 2012-12-11 02:46:11.000000000 +0000
+++ ghdl/translate/gcc/Make-lang.in 2013-11-25 18:28:58.475650640 +0000
@@ -69,55 +69,6 @@
AGCC_GCCOBJ_DIR=../
####gcc Makefile.inc
-# -*- Makefile -*- for the gcc implemantation of ortho.
-# Copyright (C) 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 \
- -I$(AGCC_GCCSRC_DIR)/libcpp/include
-AGCC_CFLAGS=-g -Wall -DIN_GCC $(AGCC_INC_FLAGS)
-
-AGCC_LOCAL_OBJS=ortho-lang.o
-
-AGCC_DEPS := $(AGCC_LOCAL_OBJS)
-AGCC_OBJS := $(AGCC_LOCAL_OBJS) $(AGCC_GCCOBJ_DIR)gcc/attribs.o
-# $(AGCC_GCCOBJ_DIR)gcc/toplev.o
-
-ortho-lang.o: $(agcc_srcdir)/ortho-lang.c \
- $(AGCC_GCCOBJ_DIR)gcc/gtype-vhdl.h \
- $(AGCC_GCCOBJ_DIR)gcc/gt-vhdl-ortho-lang.h
- $(CC) -c -o $@ $< $(AGCC_CFLAGS)
-
-agcc-clean: force
- $(RM) -f $(agcc_objdir)/*.o
- $(RM) -f $(agcc_srcdir)/*~
-
-agcc-maintainer-clean: force
- $(RM) -f $(AGCC_DEPS)
-
-
-.PHONY: agcc-clean agcc-maintainer-clean
# The compiler proper.
# It is compiled into the vhdl/ subdirectory to avoid file name clashes but
@@ -129,7 +80,7 @@
$(GNATMAKE) -o $@ -aI$(srcdir)/vhdl -aOvhdl ortho_gcc-main \
-bargs -E -cargs $(CFLAGS) $(GHDL_ADAFLAGS) \
-largs $(AGCC_OBJS) $(filter-out main.o,$(BACKEND)) \
- $(LIBS) $(BACKENDLIBS)
+ $(LIBS) $(BACKENDLIBS) -lstdc++
# The driver for ghdl.
ghdl$(exeext): force
@@ -171,6 +122,8 @@
vhdl.install-normal:
+vhdl.install-plugin:
+
# Install the driver program as ghdl.
vhdl.install-common: ghdl$(exeext)
-mkdir $(DESTDIR)$(bindir)
diff -u -r -u ../r150/ghdl/translate/grt/grt-values.adb ghdl/translate/grt/grt-values.adb
--- ../r150/ghdl/translate/grt/grt-values.adb 2005-09-24 06:10:24.000000000 +0100
+++ ghdl/translate/grt/grt-values.adb 2013-11-25 17:47:01.000000000 +0000
@@ -22,6 +22,124 @@
NBSP : constant Character := Character'Val (160);
HT : constant Character := Character'Val (9);
+ procedure Remove_Whitespace(S : in Std_String_Basep;
+ Pos : in out Ghdl_Index_Type;
+ Len : in Ghdl_Index_Type;
+ Chars : out Ghdl_B2) is
+ begin
+ Chars := False;
+ -- GHDL: allow several leading whitespace.
+ while Pos < Len loop
+ case S (Pos) is
+ when ' '
+ | NBSP
+ | HT =>
+ Pos := Pos + 1;
+ when others =>
+ Chars := True;
+ exit;
+ end case;
+ end loop;
+ end Remove_Whitespace;
+
+ procedure Stub_Error(S : String) is
+ begin
+ Error_E ("'value: function Ghdl_Value_" & S & " is a stub!"
+ & "Please report as missing to http://gna.org/projects/ghdl";);
+ end Stub_Error;
+
+ function LC(C : in Character) return Character is
+ begin
+ if C >= 'A' and then C <= 'Z' then
+ return Character'val(Character'pos(C) + Character'pos('a') - Character'pos('A'));
+ else
+ return C;
+ end if;
+ end LC;
+
+ procedure Make_LC_String(S : Std_String_Basep;
+ Pos : in out Ghdl_Index_Type;
+ Len : Ghdl_Index_Type;
+ Str : out String) is
+ begin
+ for i in Str'range loop
+ Str(i) := LC(S(Pos)); -- LC it later
+ Pos := Pos + 1;
+ end loop;
+ end Make_LC_String;
+
+ function StringMatch(Str : String; EnumStr : Ghdl_C_String) return boolean is
+ EnumLen : Natural := strlen(EnumStr);
+ begin
+ for j in Str'range loop
+ if j > EnumLen or else Str(j) /= EnumStr(j) then
+ return false;
+ end if;
+ end loop;
+ if Str'last = EnumLen then
+ return true;
+ else
+ return false;
+ end if;
+ end StringMatch;
+
+ function Ghdl_Value_Enum (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) return Ghdl_Index_Type is
+ Val : Ghdl_Index_Type := 0;
+ S : constant Std_String_Basep := Str.Base;
+ Len : constant Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
+ Pos : Ghdl_Index_Type := 0;
+ Chars : Ghdl_B2;
+ Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
+
+ begin
+ Remove_Whitespace(S, Pos, Len, Chars);
+ if Pos = Len then
+ Error_E ("'value: empty string");
+ end if;
+
+ Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+
+ declare
+ Str : String(1..Natural(Len - Pos));
+ Found : Boolean := False;
+ begin
+ Make_LC_String(S, Pos, Len, Str);
+ for i in 0 .. Enum_Rti.Nbr - 1 loop
+ if StringMatch(Str, Enum_Rti.Names.all(i)) then
+ Found := True;
+ Val := i;
+ exit;
+ end if;
+ end loop;
+ if not Found then
+ Error_E ("'value: " & Str & " not in enumeration " & Enum_Rti.Name.all(1..strlen(Enum_Rti.Name)));
+ end if;
+ end;
+
+ Remove_Whitespace(S, Pos, Len, Chars);
+ if Chars then
+ Error_E ("'value: trailing characters after blank");
+ end if;
+ -- Stub_Error("E8");
+ return Val;
+ end Ghdl_Value_Enum;
+
+ function Ghdl_Value_B2 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) return Ghdl_B2 is
+ Val : Ghdl_B2 := False;
+ begin
+ return Ghdl_B2'Val(Ghdl_Value_Enum (Str , Rti ));
+ end Ghdl_Value_B2;
+
+ function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) return Ghdl_E8 is
+ begin
+ return Ghdl_E8'Val(Ghdl_Value_Enum (Str , Rti ));
+ end Ghdl_Value_E8;
+
+ function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) return Ghdl_E32 is
+ begin
+ return Ghdl_E32'Val(Ghdl_Value_Enum (Str , Rti ));
+ end Ghdl_Value_E32;
+
function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32
is
S : constant Std_String_Basep := Str.Base;
@@ -31,22 +149,13 @@
Sep : Character;
Val, D, Base : Ghdl_I32;
Exp : Integer;
+ Chars : Ghdl_B2;
begin
-- LRM 14.1
-- Leading [and trailing] whitespace is allowed and ignored.
--
-- GHDL: allow several leading whitespace.
- while Pos < Len loop
- case S (Pos) is
- when ' '
- | NBSP
- | HT =>
- Pos := Pos + 1;
- when others =>
- exit;
- end case;
- end loop;
-
+ Remove_Whitespace(S, Pos, Len, Chars);
if Pos = Len then
Error_E ("'value: empty string");
end if;
@@ -197,19 +306,34 @@
-- LRM 14.1
-- [Leading] and trailing whitespace is allowed and ignored.
--
- -- GHDL: allow several leading whitespace.
- while Pos < Len loop
- case S (Pos) is
- when ' '
- | NBSP
- | HT =>
- Pos := Pos + 1;
- when others =>
- Error_E ("'value: trailing characters after blank");
- end case;
- end loop;
+ -- GHDL: allow several trailing whitespace.
+ Remove_Whitespace(S, Pos, Len, Chars);
+ if Chars then
+ Error_E ("'value: trailing characters after blank");
+ end if;
return Val;
end Ghdl_Value_I32;
+ function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64 is
+ Val : Ghdl_F64 := 0.0;
+ begin
+ Stub_Error("F64");
+ return Val;
+ end Ghdl_Value_F64;
+
+ function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) return Ghdl_I64 is
+ Val : Ghdl_I64 := 0;
+ begin
+ Stub_Error("P64");
+ return Val;
+ end Ghdl_Value_P64;
+
+ function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) return Ghdl_I32 is
+ Val : Ghdl_I32 := 0;
+ begin
+ Stub_Error("P32");
+ return Val;
+ end Ghdl_Value_P32;
+
end Grt.Values;
diff -u -r -u ../r150/ghdl/translate/grt/grt-values.ads ghdl/translate/grt/grt-values.ads
--- ../r150/ghdl/translate/grt/grt-values.ads 2005-09-24 06:10:24.000000000 +0100
+++ ghdl/translate/grt/grt-values.ads 2013-11-25 17:47:01.000000000 +0000
@@ -16,10 +16,24 @@
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
with Grt.Types; use Grt.Types;
--- with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis; use Grt.Rtis;
package Grt.Values is
+ function Ghdl_Value_B2 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) return Ghdl_B2;
+ function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) return Ghdl_E8;
+ function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) return Ghdl_E32;
function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32;
+ function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64;
+ function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) return Ghdl_I64;
+ function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) return Ghdl_I32;
private
+ pragma Export (Ada, Ghdl_Value_B2, "__ghdl_value_b2");
+ pragma Export (C, Ghdl_Value_E8, "__ghdl_value_e8");
+ pragma Export (C, Ghdl_Value_E32, "__ghdl_value_e32");
pragma Export (C, Ghdl_Value_I32, "__ghdl_value_i32");
+ pragma Export (C, Ghdl_Value_F64, "__ghdl_value_f64");
+ pragma Export (C, Ghdl_Value_P64, "__ghdl_value_p64");
+ pragma Export (C, Ghdl_Value_P32, "__ghdl_value_p32");
end Grt.Values;
+
+
diff -u -r -u ../r150/ghdl/translate/translation.adb ghdl/translate/translation.adb
--- ../r150/ghdl/translate/translation.adb 2010-01-12 03:15:20.000000000 +0000
+++ ghdl/translate/translation.adb 2013-11-25 17:48:43.000000000 +0000
@@ -7277,6 +7277,16 @@
Def : Iir;
Mode : Type_Mode_Type) return Boolean
is
+
+ function Get_Value_I32 (Lit : Iir) return Iir_Int32 is
+ begin
+ return Iir_Int32(Get_Value(Lit));
+ exception
+ when Constraint_Error =>
+ Error_Msg_Sem ("Value exceeds range of 32-bit Integer" , Lit);
+ return Iir_Int32(0);
+ end Get_Value_I32;
+
begin
case Mode is
when Type_Mode_B2 =>
@@ -7309,7 +7319,7 @@
declare
V : Iir_Int32;
begin
- V := Iir_Int32 (Get_Value (Lit));
+ V := Get_Value_I32 (Lit);
if Is_Hi then
return V = Iir_Int32'Last;
else
@@ -13831,7 +13841,6 @@
when Iir_Kind_Enumeration_Literal =>
return Get_Ortho_Expr (Get_Enumeration_Decl (Expr));
-
when Iir_Kind_Floating_Point_Literal =>
return New_Float_Literal
(Res_Type, IEEE_Float_64 (Get_Fp_Value (Expr)));
@@ -13851,7 +13860,7 @@
* Iir_Fp64 (Get_Value (Get_Physical_Unit_Value
(Get_Unit_Name (Expr))))));
when others =>
- Error_Kind ("tranlate_numeric_literal", Expr);
+ Error_Kind ("translate_numeric_literal", Expr);
end case;
exception
when Constraint_Error =>
@@ -15314,7 +15323,8 @@
Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Pos));
El_Assoc := Null_Iir;
while El /= Null_Iir loop
- Start_Choice (Case_Blk);
+-- Start_Choice (Case_Blk);
+ Start_Choice (Case_Blk, New_Obj_Value (Var_Pos));
Chap8.Translate_Case_Choice (El, Range_Type, Case_Blk);
if Get_Associated (El) /= Null_Iir then
El_Assoc := Get_Associated (El);
@@ -19338,13 +19348,15 @@
while Choice /= Null_Iir loop
case Get_Kind (Choice) is
when Iir_Kind_Choice_By_Others =>
- Start_Choice (Case_Blk);
+ -- Start_Choice (Case_Blk);
+ Start_Choice (Case_Blk, New_Obj_Value (Var_Idx));
New_Expr_Choice (Case_Blk, Others_Lit);
Finish_Choice (Case_Blk);
Translate_Statements_Chain (Get_Associated (Choice));
when Iir_Kind_Choice_By_Expression =>
if not Get_Same_Alternative_Flag (Choice) then
- Start_Choice (Case_Blk);
+ -- Start_Choice (Case_Blk);
+ Start_Choice (Case_Blk, New_Obj_Value (Var_Idx));
New_Expr_Choice
(Case_Blk,
New_Unsigned_Literal
@@ -19360,7 +19372,8 @@
Choice := Get_Chain (Choice);
end loop;
- Start_Choice (Case_Blk);
+ -- Start_Choice (Case_Blk);
+ Start_Choice (Case_Blk, New_Obj_Value (Var_Idx));
New_Default_Choice (Case_Blk);
Finish_Choice (Case_Blk);
Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice);
@@ -19519,7 +19532,8 @@
Start_Case_Stmt (Case_Blk, Chap7.Translate_Expression (Expr));
Choice := Get_Case_Statement_Alternative_Chain (Stmt);
while Choice /= Null_Iir loop
- Start_Choice (Case_Blk);
+ -- Start_Choice (Case_Blk);
+ Start_Choice (Case_Blk, Chap7.Translate_Expression (Expr));
Stmt_Chain := Get_Associated (Choice);
loop
Translate_Case_Choice (Choice, Expr_Type, Case_Blk);
diff -u -r -u ../r150/ghdl/version.ads ghdl/version.ads
--- ../r150/ghdl/version.ads 2012-12-11 02:46:11.000000000 +0000
+++ ghdl/version.ads 2013-11-23 16:13:19.000000000 +0000
@@ -1,5 +1,5 @@
package Version is
Ghdl_Release : constant String :=
- "GHDL 0.30dev (20100112) [Sokcho edition]";
- Ghdl_Ver : constant String := "0.30dev";
+ "GHDL 0.31dev (20132311) [Dunoon edition]";
+ Ghdl_Ver : constant String := "0.31dev";
end Version;
build_gcc.sh
Description: application/shellscript
_______________________________________________ Ghdl-discuss mailing list [email protected] https://mail.gna.org/listinfo/ghdl-discuss
