summaryrefslogtreecommitdiff
path: root/translate
diff options
context:
space:
mode:
authorgingold2010-01-12 03:15:20 +0000
committergingold2010-01-12 03:15:20 +0000
commitfb5957a16dea47ae4021c5d4c57b980cea02ee59 (patch)
treeabdfbed5924f5be4418f74a0afe50b248e41c330 /translate
parent8cca0b24e2c19eedecffdeec89a8a2898da1e362 (diff)
downloadghdl-fb5957a16dea47ae4021c5d4c57b980cea02ee59.tar.gz
ghdl-fb5957a16dea47ae4021c5d4c57b980cea02ee59.tar.bz2
ghdl-fb5957a16dea47ae4021c5d4c57b980cea02ee59.zip
ghdl 0.29 release.
Diffstat (limited to 'translate')
-rw-r--r--translate/Makefile2
-rw-r--r--translate/gcc/INSTALL2
-rw-r--r--translate/gcc/README10
-rw-r--r--translate/gcc/dist-common.sh44
-rwxr-xr-xtranslate/gcc/dist.sh36
-rw-r--r--translate/ghdldrv/Makefile8
-rw-r--r--translate/ghdldrv/ghdl_simul.adb1
-rw-r--r--translate/ghdldrv/ghdlcomp.adb9
-rw-r--r--translate/ghdldrv/ghdllocal.adb82
-rw-r--r--translate/ghdldrv/ghdlmain.adb4
-rw-r--r--translate/ghdldrv/ghdlprint.adb22
-rw-r--r--translate/ghdldrv/ghdlrun.adb7
-rw-r--r--translate/ghdldrv/ghdlsimul.adb3
-rw-r--r--translate/ghdldrv/ortho_code-x86-flags.ads2
-rw-r--r--translate/grt/ghwlib.c10
-rw-r--r--translate/grt/ghwlib.h6
-rw-r--r--translate/grt/grt-cbinding.c7
-rw-r--r--translate/grt/grt-disp_signals.adb230
-rw-r--r--translate/grt/grt-disp_signals.ads2
-rw-r--r--translate/grt/grt-lib.adb11
-rw-r--r--translate/grt/grt-lib.ads25
-rw-r--r--translate/grt/grt-main.adb3
-rw-r--r--translate/grt/grt-options.adb2
-rw-r--r--translate/grt/grt-options.ads1
-rw-r--r--translate/grt/grt-processes.adb40
-rw-r--r--translate/grt/grt-processes.ads5
-rw-r--r--translate/grt/grt-rtis.ads10
-rw-r--r--translate/grt/grt-rtis_utils.adb20
-rw-r--r--translate/grt/grt-rtis_utils.ads13
-rw-r--r--translate/grt/grt-sdf.adb24
-rw-r--r--translate/grt/grt-signals.adb6
-rw-r--r--translate/grt/grt-signals.ads4
-rw-r--r--translate/grt/grt-table.adb8
-rw-r--r--translate/grt/grt-vital_annotate.adb42
-rw-r--r--translate/grt/grt-waves.adb18
-rw-r--r--translate/ortho_front.adb6
-rw-r--r--translate/trans_analyzes.adb20
-rw-r--r--translate/trans_analyzes.ads18
-rw-r--r--translate/trans_decls.ads8
-rw-r--r--translate/translation.adb1335
40 files changed, 1733 insertions, 373 deletions
diff --git a/translate/Makefile b/translate/Makefile
index f33e6d5..3033b3a 100644
--- a/translate/Makefile
+++ b/translate/Makefile
@@ -18,7 +18,7 @@
BE=gcc
ortho_srcdir=../ortho
-GNAT_FLAGS=-aI.. -gnaty3befhkmr -gnata -gnatf -gnatwael
+GNAT_FLAGS=-aI.. -aI../psl -gnaty3befhkmr -gnata -gnatf -gnatwael
#GNAT_FLAGS+=-O -gnatn
LN=ln -s
diff --git a/translate/gcc/INSTALL b/translate/gcc/INSTALL
index 8b95cea..e710f91 100644
--- a/translate/gcc/INSTALL
+++ b/translate/gcc/INSTALL
@@ -1,6 +1,6 @@
Install file for the binary distribution of GHDL.
-GHDL is Copyright 2002 - 2009 Tristan Gingold.
+GHDL is Copyright 2002 - 2010 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 of the License, or
diff --git a/translate/gcc/README b/translate/gcc/README
index 63c3981..a2df5d9 100644
--- a/translate/gcc/README
+++ b/translate/gcc/README
@@ -4,7 +4,7 @@ To get the binary distribution or more information, go to http://ghdl.free.fr
Copyright:
**********
-GHDL is copyright (c) 2002 - 2009 Tristan Gingold.
+GHDL is copyright (c) 2002 - 2010 Tristan Gingold.
See the GHDL manual for more details.
This program is free software; you can redistribute it and/or modify
@@ -55,14 +55,18 @@ end Example;
the gcc distribution.
You should have a @GCCVERSION@/gcc/vhdl directory.
* configure gcc with the --enable-languages=vhdl option. You may of course
- add other languages.
+ add other languages. Also you'd better to disable bootstraping using
+ --disable-bootstrap.
Refer to the gcc installation documentation.
* compile gcc.
'make CFLAGS="-O"' is OK
* install gcc. This installs the ghdl driver too.
'make install' is OK.
-Send bugs and comments to ghdl@free.fr.
+There is a mailing list for any questions. You can subscribe via:
+ https://mail.gna.org/listinfo/ghdl-discuss/
+Please report bugs on https://gna.org/bugs/?group=ghdl
+
If you cannot compile, please report the gcc version, GNAT version and gcc
source version.
diff --git a/translate/gcc/dist-common.sh b/translate/gcc/dist-common.sh
index e3ccc91..8ee0c16 100644
--- a/translate/gcc/dist-common.sh
+++ b/translate/gcc/dist-common.sh
@@ -27,8 +27,12 @@ sem_types.ads
sem_types.adb
sem_assocs.ads
sem_assocs.adb
+sem_psl.ads
+sem_psl.adb
canon.adb
canon.ads
+canon_psl.ads
+canon_psl.adb
flags.adb
flags.ads
configuration.adb
@@ -37,6 +41,7 @@ nodes.ads
nodes.adb
options.ads
options.adb
+psl-errors.ads
lists.ads
lists.adb
iirs.adb
@@ -71,6 +76,8 @@ errorout.adb
errorout.ads
parse.adb
parse.ads
+parse_psl.ads
+parse_psl.adb
post_sems.ads
post_sems.adb
ieee.ads
@@ -260,5 +267,38 @@ times.c
clock.c
linux.c
pthread.c
-win32.c
-win32thr.c"
+win32.c"
+
+psl_files="
+psl.ads
+psl-build.adb
+psl-build.ads
+psl-cse.adb
+psl-cse.ads
+psl-disp_nfas.adb
+psl-disp_nfas.ads
+psl-dump_tree.adb
+psl-dump_tree.ads
+psl-hash.adb
+psl-hash.ads
+psl-nfas.adb
+psl-nfas.ads
+psl-nfas-utils.adb
+psl-nfas-utils.ads
+psl-nodes.adb
+psl-nodes.ads
+psl-optimize.adb
+psl-optimize.ads
+psl-prints.adb
+psl-prints.ads
+psl-priorities.ads
+psl-qm.adb
+psl-qm.ads
+psl-rewrites.adb
+psl-rewrites.ads
+psl-subsets.adb
+psl-subsets.ads
+psl-tprint.adb
+psl-tprint.ads
+sa_bools.adb
+sa_bools.ads"
diff --git a/translate/gcc/dist.sh b/translate/gcc/dist.sh
index e22b278..f79719b 100755
--- a/translate/gcc/dist.sh
+++ b/translate/gcc/dist.sh
@@ -27,7 +27,7 @@
# * Check lists of exported files in this file.
# * Create source tar and build binaries: ./dist.sh dist_phase1
# * su root
-# * Build binary tar: ./dist.sh dist_phase2
+# * Build binary tar: HOME=~user ./dist.sh dist_phase2
# * Run the testsuites: GHDL=ghdl ./testsuite.sh gcc
# * Update website/index.html (./dist.sh website helps)
# * upload (./dist upload)
@@ -131,6 +131,9 @@ for i in $grt_config_files; do
ln -sf $CWD/../grt/config/$i $VHDLDIR/grt/config/$i
done
+for i in $psl_files; do
+ ln -sf $CWD/../../psl/$i $VHDLDIR/$i
+done
}
# Create the tar of sources.
@@ -180,12 +183,39 @@ do_compile ()
mkdir $GCCDISTOBJ
cd $GCCDISTOBJ
export CFLAGS="-O -g"
- ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX --disable-bootstrap --with-bugurl="<URL:http://gna.org/projects/ghdl>" --build=i686-pc-linux-gnu --with-gmp=$PWD/../build --with-mpfr=$PWD/../build --disable-shared --disable-libmudflap --disable-libssp --disable-libgomp
+
+ case x86 in
+ x86)
+ BUILD=i686-pc-linux-gnu
+ CONFIG_LIBS="--with-gmp=$PWD/../build --with-mpfr=$PWD/../build"
+ ;;
+ x86-64)
+ BUILD=x86_64-pc-linux-gnu
+ CONFIG_LIBS=""
+ ;;
+ *)
+ exit 1
+ ;;
+ esac
+ ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX --disable-bootstrap --with-bugurl="<URL:http://gna.org/projects/ghdl>" --build=$BUILD $CONFIG_LIBS --disable-shared --disable-libmudflap --disable-libssp --disable-libgomp
+
make
make -C gcc vhdl.info
cd $CWD
}
+# Re-package sources, update gcc sources and recompile without reconfiguring.
+do_recompile ()
+{
+ set -x
+
+ do_sources
+ do_update_gcc_sources;
+ cd $GCCDISTOBJ
+ export CFLAGS="-O -g"
+ make
+}
+
check_root ()
{
if [ $UID -ne 0 ]; then
@@ -400,6 +430,8 @@ else
do_sources ;;
compile)
do_compile;;
+ recompile)
+ do_recompile;;
update_gcc)
do_update_gcc_sources;;
compile2)
diff --git a/translate/ghdldrv/Makefile b/translate/ghdldrv/Makefile
index d684ce7..56c0675 100644
--- a/translate/ghdldrv/Makefile
+++ b/translate/ghdldrv/Makefile
@@ -15,7 +15,7 @@
# 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.
-GNATFLAGS=-gnaty3befhkmr -gnata -gnatwae -aI../.. -aI.. -aI../grt -aO.. -g -gnatf
+GNATFLAGS=-gnaty3befhkmr -gnata -gnatwae -aI../.. -aI.. -aI../../psl -aI../grt -aO.. -g -gnatf
GRT_FLAGS=-g
LIB_CFLAGS=-g -O2
GNATMAKE=gnatmake
@@ -66,6 +66,9 @@ ghdl_llvm_jit: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME
ghdl_llvm_jit: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) bindings.o force
$(GNATMAKE) -o $@ -aI../../ortho/llvm -aI../../ortho/mcode -aI../../ortho $(GNATFLAGS) ghdl_mcode $(GNAT_BARGS) -largs -m64 bindings.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) --LINK=g++
+ghdl_simul: default_pathes.ads force
+ $(GNATMAKE) -aI../../simulate $(GNATFLAGS) ghdl_simul $(GNAT_BARGS) -largs $(GNAT_LARGS)
+
memsegs_c.o: ../../ortho/mcode/memsegs_c.c
$(CC) -c -g -o $@ $<
@@ -78,9 +81,6 @@ ghdl_gcc: default_pathes.ads force
ghdl_llvm: default_pathes.ads force
$(GNATMAKE) $(GNATFLAGS) ghdl_llvm $(GNAT_BARGS) -largs $(GNAT_LARGS)
-ghdl_simul: default_pathes.ads force
- gnatmake -aI../../simulate $(GNATFLAGS) ghdl_simul $(GNAT_BARGS) -largs $(GNAT_LARGS)
-
default_pathes.ads: default_pathes.ads.in Makefile
curdir=`cd ..; pwd`; \
sed -e "s%@COMPILER_GCC@%$$curdir/ghdl1-gcc%" \
diff --git a/translate/ghdldrv/ghdl_simul.adb b/translate/ghdldrv/ghdl_simul.adb
index 757feb2..d4d0abd 100644
--- a/translate/ghdldrv/ghdl_simul.adb
+++ b/translate/ghdldrv/ghdl_simul.adb
@@ -24,6 +24,7 @@ procedure Ghdl_Simul is
begin
-- Manual elaboration so that the order is known (because it is the order
-- used to display help).
+ Ghdlmain.Version_String := new String'("interpretation");
Ghdlsimul.Register_Commands;
Ghdllocal.Register_Commands;
Ghdlprint.Register_Commands;
diff --git a/translate/ghdldrv/ghdlcomp.adb b/translate/ghdldrv/ghdlcomp.adb
index 4dcd208..1a07fc0 100644
--- a/translate/ghdldrv/ghdlcomp.adb
+++ b/translate/ghdldrv/ghdlcomp.adb
@@ -482,7 +482,7 @@ package body Ghdlcomp is
end Perform_Action;
-- Command Make.
- type Command_Make is new Command_Lib with null record;
+ type Command_Make is new Command_Comp with null record;
function Decode_Command (Cmd : Command_Make; Name : String)
return Boolean;
function Get_Short_Help (Cmd : Command_Make) return String;
@@ -545,6 +545,13 @@ package body Ghdlcomp is
end loop;
Set_Date (Libraries.Work_Library, Date);
Libraries.Save_Work_Library;
+ exception
+ when Compilation_Error =>
+ if Flag_Expect_Failure then
+ return;
+ else
+ raise;
+ end if;
end Perform_Action;
-- Command Gen_Makefile.
diff --git a/translate/ghdldrv/ghdllocal.adb b/translate/ghdldrv/ghdllocal.adb
index 15eebe3..3b3ff2b 100644
--- a/translate/ghdldrv/ghdllocal.adb
+++ b/translate/ghdldrv/ghdllocal.adb
@@ -102,8 +102,7 @@ package body Ghdllocal is
is
pragma Unreferenced (Cmd);
begin
- Std_Names.Std_Names_Initialize;
- Libraries.Init_Pathes;
+ Options.Initialize;
Flag_Ieee := Lib_Standard;
Back_End.Finish_Compilation := Finish_Compilation'Access;
Flag_Verbose := False;
@@ -638,7 +637,7 @@ package body Ghdllocal is
Analyze_Files (Args, False);
end Perform_Action;
- -- Command --clean.
+ -- Command --clean: remove object files.
type Command_Clean is new Command_Lib with null record;
function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean;
function Get_Short_Help (Cmd : Command_Clean) return String;
@@ -736,6 +735,7 @@ package body Ghdllocal is
end loop;
end Perform_Action;
+ -- Command --remove: remove object file and library file.
type Command_Remove is new Command_Clean with null record;
function Decode_Command (Cmd : Command_Remove; Name : String)
return Boolean;
@@ -771,6 +771,81 @@ package body Ghdllocal is
& Nul);
end Perform_Action;
+ -- Command --copy: copy work library to current directory.
+ type Command_Copy is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean;
+ function Get_Short_Help (Cmd : Command_Copy) return String;
+ procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--copy";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Copy) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--copy Copy work library to current directory";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Name_Table;
+ use Libraries;
+
+ File : Iir_Design_File;
+ Dir : Name_Id;
+ begin
+ if Args'Length /= 0 then
+ Error ("command '--copy' does not accept any argument");
+ raise Option_Error;
+ end if;
+
+ Setup_Libraries (False);
+ Libraries.Load_Std_Library;
+ Dir := Work_Directory;
+ Work_Directory := Null_Identifier;
+ Libraries.Load_Work_Library;
+ Work_Directory := Dir;
+
+ Dir := Get_Library_Directory (Libraries.Work_Library);
+ if Dir = Name_Nil or else Dir = Files_Map.Get_Home_Directory then
+ Error ("cannot copy library on itself (use --remove first)");
+ raise Option_Error;
+ end if;
+
+ File := Get_Design_File_Chain (Libraries.Work_Library);
+ while File /= Null_Iir loop
+ -- Copy object files (if any).
+ declare
+ Basename : constant String :=
+ Get_Base_Name (Image (Get_Design_File_Filename (File)));
+ Src : String_Access;
+ Dst : String_Access;
+ Success : Boolean;
+ pragma Unreferenced (Success);
+ begin
+ Src := new String'(Image (Dir) & Basename & Get_Object_Suffix.all);
+ Dst := new String'(Basename & Get_Object_Suffix.all);
+ Copy_File (Src.all, Dst.all, Success, Overwrite, Full);
+ -- Be silent in case of error.
+ Free (Src);
+ Free (Dst);
+ end;
+ if Get_Design_File_Directory (File) = Name_Nil then
+ Set_Design_File_Directory (File, Dir);
+ end if;
+
+ File := Get_Chain (File);
+ end loop;
+ Libraries.Work_Directory := Name_Nil;
+ Libraries.Save_Work_Library;
+ end Perform_Action;
+
-- Command --disp-standard.
type Command_Disp_Standard is new Command_Lib with null record;
function Decode_Command (Cmd : Command_Disp_Standard; Name : String)
@@ -1090,6 +1165,7 @@ package body Ghdllocal is
Register_Command (new Command_Find);
Register_Command (new Command_Clean);
Register_Command (new Command_Remove);
+ Register_Command (new Command_Copy);
Register_Command (new Command_Disp_Standard);
end Register_Commands;
end Ghdllocal;
diff --git a/translate/ghdldrv/ghdlmain.adb b/translate/ghdldrv/ghdlmain.adb
index 6cc3476..b34c07f 100644
--- a/translate/ghdldrv/ghdlmain.adb
+++ b/translate/ghdldrv/ghdlmain.adb
@@ -1,5 +1,5 @@
-- GHDL driver - main part.
--- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Tristan Gingold
+-- Copyright (C) 2002 - 2010 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
@@ -225,7 +225,7 @@ package body Ghdlmain is
Put_Line ("Written by Tristan Gingold.");
New_Line;
-- Display copyright. Assume 80 cols terminal.
- Put_Line ("Copyright (C) 2003 - 2009 Tristan Gingold.");
+ Put_Line ("Copyright (C) 2003 - 2010 Tristan Gingold.");
Put_Line ("GHDL is free software, covered by the "
& "GNU General Public License. There is NO");
Put_Line ("warranty; not even for MERCHANTABILITY or"
diff --git a/translate/ghdldrv/ghdlprint.adb b/translate/ghdldrv/ghdlprint.adb
index 8947e64..9eaba5c 100644
--- a/translate/ghdldrv/ghdlprint.adb
+++ b/translate/ghdldrv/ghdlprint.adb
@@ -385,6 +385,28 @@ package body Ghdlprint is
else
Disp_Identifier;
end if;
+ when Tok_Psl_Default
+ | Tok_Psl_Clock
+ | Tok_Psl_Property
+ | Tok_Psl_Sequence
+ | Tok_Psl_Endpoint
+ | Tok_Psl_Assert
+ | Tok_Psl_Boolean
+ | Tok_Psl_Const
+ | Tok_Inf
+ | Tok_Within
+ | Tok_Abort
+ | Tok_Before
+ | Tok_Always
+ | Tok_Never
+ | Tok_Eventually
+ | Tok_Next_A
+ | Tok_Next_E
+ | Tok_Next_Event
+ | Tok_Next_Event_A
+ | Tok_Next_Event_E =>
+ Disp_Spaces;
+ Disp_Text;
when Tok_String
| Tok_Bit_String
| Tok_Character =>
diff --git a/translate/ghdldrv/ghdlrun.adb b/translate/ghdldrv/ghdlrun.adb
index 4e13a4f..5191813 100644
--- a/translate/ghdldrv/ghdlrun.adb
+++ b/translate/ghdldrv/ghdlrun.adb
@@ -264,11 +264,15 @@ package body Ghdlrun is
Grt.Lib.Ghdl_Malloc0'Address);
Def (Trans_Decls.Ghdl_Assert_Default_Report,
Grt.Lib.Ghdl_Assert_Default_Report'Address);
+ Def (Trans_Decls.Ghdl_Std_Ulogic_To_Boolean_Array,
+ Grt.Lib.Ghdl_Std_Ulogic_To_Boolean_Array'Address);
Def (Trans_Decls.Ghdl_Report,
Grt.Lib.Ghdl_Report'Address);
Def (Trans_Decls.Ghdl_Assert_Failed,
Grt.Lib.Ghdl_Assert_Failed'Address);
+ Def (Trans_Decls.Ghdl_Psl_Assert_Failed,
+ Grt.Lib.Ghdl_Psl_Assert_Failed'Address);
Def (Trans_Decls.Ghdl_Program_Error,
Grt.Lib.Ghdl_Program_Error'Address);
Def (Trans_Decls.Ghdl_Malloc,
@@ -288,6 +292,9 @@ package body Ghdlrun is
Grt.Processes.Ghdl_Postponed_Sensitized_Process_Register'Address);
Def (Trans_Decls.Ghdl_Postponed_Process_Register,
Grt.Processes.Ghdl_Postponed_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Finalize_Register,
+ Grt.Processes.Ghdl_Finalize_Register'Address);
+
Def (Trans_Decls.Ghdl_Stack2_Allocate,
Grt.Processes.Ghdl_Stack2_Allocate'Address);
Def (Trans_Decls.Ghdl_Stack2_Mark,
diff --git a/translate/ghdldrv/ghdlsimul.adb b/translate/ghdldrv/ghdlsimul.adb
index 506b2ed..abeb7bb 100644
--- a/translate/ghdldrv/ghdlsimul.adb
+++ b/translate/ghdldrv/ghdlsimul.adb
@@ -25,6 +25,7 @@ with Back_End;
with Name_Table;
with Errorout; use Errorout;
with Std_Package;
+with Libraries;
with Canon;
with Configuration;
with Annotations;
@@ -37,6 +38,7 @@ with Ghdlcomp;
package body Ghdlsimul is
Flag_Expect_Failure : Boolean := False;
+ pragma Unreferenced (Flag_Expect_Failure);
procedure Compile_Init (Analyze_Only : Boolean) is
begin
@@ -73,7 +75,6 @@ package body Ghdlsimul is
end Compile_Elab;
-- Set options.
- -- This is a little bit over-kill: from C to Ada and then again to C...
procedure Set_Run_Options (Args : Argument_List)
is
Arg : String_Access;
diff --git a/translate/ghdldrv/ortho_code-x86-flags.ads b/translate/ghdldrv/ortho_code-x86-flags.ads
new file mode 100644
index 0000000..40f0bd8
--- /dev/null
+++ b/translate/ghdldrv/ortho_code-x86-flags.ads
@@ -0,0 +1,2 @@
+with Ortho_Code.X86.Flags_Linux;
+package Ortho_Code.X86.Flags renames Ortho_Code.X86.Flags_Linux;
diff --git a/translate/grt/ghwlib.c b/translate/grt/ghwlib.c
index 4585688..2db63d9 100644
--- a/translate/grt/ghwlib.c
+++ b/translate/grt/ghwlib.c
@@ -296,7 +296,7 @@ ghw_read_range (struct ghw_handler *h)
int
ghw_read_str (struct ghw_handler *h)
{
- char hdr[12];
+ unsigned char hdr[12];
int i;
char *p;
int prev_len;
@@ -435,7 +435,7 @@ get_range_length (union ghw_range *rng)
int
ghw_read_type (struct ghw_handler *h)
{
- char hdr[8];
+ unsigned char hdr[8];
int i;
if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
@@ -777,7 +777,7 @@ ghw_read_value (struct ghw_handler *h,
int
ghw_read_hie (struct ghw_handler *h)
{
- char hdr[16];
+ unsigned char hdr[16];
int nbr_scopes;
int nbr_sigs;
int i;
@@ -1100,7 +1100,7 @@ ghw_read_signal_value (struct ghw_handler *h, struct ghw_sig *s)
int
ghw_read_snapshot (struct ghw_handler *h)
{
- char hdr[12];
+ unsigned char hdr[12];
int i;
struct ghw_sig *s;
@@ -1138,7 +1138,7 @@ void ghw_disp_values (struct ghw_handler *h);
int
ghw_read_cycle_start (struct ghw_handler *h)
{
- char hdr[8];
+ unsigned char hdr[8];
if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
return -1;
diff --git a/translate/grt/ghwlib.h b/translate/grt/ghwlib.h
index dbf20fe..0138267 100644
--- a/translate/grt/ghwlib.h
+++ b/translate/grt/ghwlib.h
@@ -150,7 +150,7 @@ struct ghw_type_enum
const char *name;
enum ghw_wkt_type wkt;
- int nbr;
+ unsigned int nbr;
const char **lits;
};
@@ -179,7 +179,7 @@ struct ghw_type_array
enum ghdl_rtik kind;
const char *name;
- int nbr_dim;
+ unsigned int nbr_dim;
union ghw_type *el;
union ghw_type **dims;
};
@@ -214,7 +214,7 @@ struct ghw_type_record
enum ghdl_rtik kind;
const char *name;
- int nbr_fields;
+ unsigned int nbr_fields;
int nbr_el; /* Number of scalar signals. */
struct ghw_record_element *el;
};
diff --git a/translate/grt/grt-cbinding.c b/translate/grt/grt-cbinding.c
index 1b75fcf..eb04a9c 100644
--- a/translate/grt/grt-cbinding.c
+++ b/translate/grt/grt-cbinding.c
@@ -37,6 +37,13 @@ __ghdl_get_stderr (void)
return stderr;
}
+int
+__ghdl_snprintf_g (char *buf, unsigned int len, double val)
+{
+ snprintf (buf, len, "%g", val);
+ return strlen (buf);
+}
+
void
__ghdl_fprintf_g (FILE *stream, double val)
{
diff --git a/translate/grt/grt-disp_signals.adb b/translate/grt/grt-disp_signals.adb
index 85acb93..6a2d0c1 100644
--- a/translate/grt/grt-disp_signals.adb
+++ b/translate/grt/grt-disp_signals.adb
@@ -27,9 +27,63 @@ with Grt.Errors; use Grt.Errors;
pragma Elaborate_All (Grt.Rtis_Utils);
with Grt.Vstrings; use Grt.Vstrings;
with Grt.Options;
+with Grt.Processes;
with Grt.Disp; use Grt.Disp;
package body Grt.Disp_Signals is
+ procedure Foreach_Scalar_Signal
+ (Process : access procedure (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Param : Rti_Object))
+ is
+ procedure Call_Process (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Param : Rti_Object) is
+ begin
+ Process.all (Val_Addr, Val_Name, Val_Type, Param);
+ end Call_Process;
+
+ pragma Inline (Call_Process);
+
+ procedure Foreach_Scalar_Signal_Signal is new
+ Foreach_Scalar (Param_Type => Rti_Object,
+ Process => Call_Process);
+
+ function Foreach_Scalar_Signal_Object
+ (Ctxt : Rti_Context; Obj : Ghdl_Rti_Access)
+ return Traverse_Result
+ is
+ Sig : Ghdl_Rtin_Object_Acc;
+ begin
+ case Obj.Kind is
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard
+ | Ghdl_Rtik_Attribute_Quiet
+ | Ghdl_Rtik_Attribute_Stable
+ | Ghdl_Rtik_Attribute_Transaction =>
+ Sig := To_Ghdl_Rtin_Object_Acc (Obj);
+ Foreach_Scalar_Signal_Signal
+ (Ctxt, Sig.Obj_Type,
+ Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True,
+ Rti_Object'(Obj, Ctxt));
+ when others =>
+ null;
+ end case;
+ return Traverse_Ok;
+ end Foreach_Scalar_Signal_Object;
+
+ function Foreach_Scalar_Signal_Traverse is
+ new Traverse_Blocks (Process => Foreach_Scalar_Signal_Object);
+
+ Res : Traverse_Result;
+ pragma Unreferenced (Res);
+ begin
+ Res := Foreach_Scalar_Signal_Traverse (Get_Top_Context);
+ end Foreach_Scalar_Signal;
+
procedure Disp_Context (Ctxt : Rti_Context)
is
Blk : Ghdl_Rtin_Block_Acc;
@@ -166,90 +220,106 @@ package body Grt.Disp_Signals is
New_Line;
end Disp_Simple_Signal;
- procedure Disp_Scalar_Signal (Val_Addr : Address;
- Val_Name : Vstring;
- Val_Type : Ghdl_Rti_Access)
- is
- begin
- Put (stdout, Val_Name);
- Disp_Simple_Signal (To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all),
- Val_Type, Options.Disp_Sources);
- end Disp_Scalar_Signal;
-
- procedure Foreach_Scalar_Signal is new
- Foreach_Scalar (Process => Disp_Scalar_Signal);
-
- procedure Disp_Signal_Name (Stream : FILEs; Sig : Ghdl_Rtin_Object_Acc) is
+ procedure Disp_Signal_Name (Stream : FILEs;
+ Ctxt : Rti_Context;
+ Sig : Ghdl_Rtin_Object_Acc) is
begin
case Sig.Common.Kind is
when Ghdl_Rtik_Signal
| Ghdl_Rtik_Port
| Ghdl_Rtik_Guard =>
+ Put (stdout, Ctxt);
+ Put (".");
Put (Stream, Sig.Name);
when Ghdl_Rtik_Attribute_Quiet =>
+ Put (stdout, Ctxt);
+ Put (".");
Put (Stream, " 'quiet");
when Ghdl_Rtik_Attribute_Stable =>
+ Put (stdout, Ctxt);
+ Put (".");
Put (Stream, " 'stable");
when Ghdl_Rtik_Attribute_Transaction =>
+ Put (stdout, Ctxt);
+ Put (".");
Put (Stream, " 'quiet");
when others =>
null;
end case;
end Disp_Signal_Name;
- function Disp_Signal (Ctxt : Rti_Context;
- Obj : Ghdl_Rti_Access)
- return Traverse_Result
+ procedure Disp_Scalar_Signal (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Parent : Rti_Object)
is
- Sig : Ghdl_Rtin_Object_Acc;
begin
- case Obj.Kind is
- when Ghdl_Rtik_Signal
- | Ghdl_Rtik_Port
- | Ghdl_Rtik_Guard
- | Ghdl_Rtik_Attribute_Quiet
- | Ghdl_Rtik_Attribute_Stable
- | Ghdl_Rtik_Attribute_Transaction =>
- Sig := To_Ghdl_Rtin_Object_Acc (Obj);
- Put (stdout, Ctxt);
- Put (".");
- Disp_Signal_Name (stdout, Sig);
- Foreach_Scalar_Signal
- (Ctxt, Sig.Obj_Type,
- Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True);
- when others =>
- null;
- end case;
- return Traverse_Ok;
- end Disp_Signal;
+ Disp_Signal_Name (stdout, Parent.Ctxt,
+ To_Ghdl_Rtin_Object_Acc (Parent.Obj));
+ Put (stdout, Val_Name);
+ Disp_Simple_Signal (To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all),
+ Val_Type, Options.Disp_Sources);
+ end Disp_Scalar_Signal;
+
- function Disp_All_Signals is new Traverse_Blocks (Process => Disp_Signal);
+ procedure Disp_All_Signals is
+ begin
+ Foreach_Scalar_Signal (Disp_Scalar_Signal'access);
+ end Disp_All_Signals;
+
+ -- Option disp-sensitivity
- procedure Disp_All_Signals
+ procedure Disp_Scalar_Sensitivity (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Parent : Rti_Object)
is
- Res : Traverse_Result;
- pragma Unreferenced (Res);
+ pragma Unreferenced (Val_Type);
+ Sig : Ghdl_Signal_Ptr;
+
+ Action : Action_List_Acc;
begin
- if Boolean'(False) then
- for I in Sig_Table.First .. Sig_Table.Last loop
- Disp_Simple_Signal
- (Sig_Table.Table (I), null, Options.Disp_Sources);
- end loop;
+ Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
+ if Sig.Flags.Seen then
+ return;
else
- Res := Disp_All_Signals (Get_Top_Context);
+ Sig.Flags.Seen := True;
end if;
- end Disp_All_Signals;
+ Disp_Signal_Name (stdout, Parent.Ctxt,
+ To_Ghdl_Rtin_Object_Acc (Parent.Obj));
+ Put (stdout, Val_Name);
+ New_Line (stdout);
+ Action := Sig.Event_List;
+ while Action /= null loop
+ Put (stdout, " wakeup ");
+ Grt.Processes.Disp_Process_Name (stdout, Action.Proc);
+ New_Line (stdout);
+ Action := Action.Next;
+ end loop;
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ for I in 1 .. Sig.S.Nbr_Drivers loop
+ Put (stdout, " driven ");
+ Grt.Processes.Disp_Process_Name
+ (stdout, Sig.S.Drivers (I - 1).Proc);
+ New_Line (stdout);
+ end loop;
+ end if;
+ end Disp_Scalar_Sensitivity;
- -- Option disp-signals-map
+ procedure Disp_All_Sensitivity is
+ begin
+ Foreach_Scalar_Signal (Disp_Scalar_Sensitivity'access);
+ end Disp_All_Sensitivity;
- Cur_Signals_Map_Ctxt : Rti_Context;
- Cur_Signals_Map_Obj : Ghdl_Rtin_Object_Acc;
+
+ -- Option disp-signals-map
procedure Disp_Signals_Map_Scalar (Val_Addr : Address;
Val_Name : Vstring;
- Val_Type : Ghdl_Rti_Access)
+ Val_Type : Ghdl_Rti_Access;
+ Parent : Rti_Object)
is
pragma Unreferenced (Val_Type);
@@ -258,9 +328,8 @@ package body Grt.Disp_Signals is
S : Ghdl_Signal_Ptr;
begin
- Put (stdout, Cur_Signals_Map_Ctxt);
- Put (".");
- Disp_Signal_Name (stdout, Cur_Signals_Map_Obj);
+ Disp_Signal_Name (stdout,
+ Parent.Ctxt, To_Ghdl_Rtin_Object_Acc (Parent.Obj));
Put (stdout, Val_Name);
Put (": ");
S := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
@@ -273,43 +342,9 @@ package body Grt.Disp_Signals is
New_Line;
end Disp_Signals_Map_Scalar;
- procedure Foreach_Disp_Signals_Map_Scalar is new
- Foreach_Scalar (Process => Disp_Signals_Map_Scalar);
-
- function Disp_Signals_Map_Signal (Ctxt : Rti_Context;
- Obj : Ghdl_Rti_Access)
- return Traverse_Result
- is
- Sig : Ghdl_Rtin_Object_Acc renames Cur_Signals_Map_Obj;
- begin
- case Obj.Kind is
- when Ghdl_Rtik_Signal
- | Ghdl_Rtik_Port
- | Ghdl_Rtik_Guard
- | Ghdl_Rtik_Attribute_Stable
- | Ghdl_Rtik_Attribute_Quiet
- | Ghdl_Rtik_Attribute_Transaction =>
- Cur_Signals_Map_Ctxt := Ctxt;
- Cur_Signals_Map_Obj := To_Ghdl_Rtin_Object_Acc (Obj);
- Foreach_Disp_Signals_Map_Scalar
- (Ctxt, Sig.Obj_Type,
- Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True);
- when others =>
- null;
- end case;
- return Traverse_Ok;
- end Disp_Signals_Map_Signal;
-
- function Disp_Signals_Map_Blocks is new Traverse_Blocks
- (Process => Disp_Signals_Map_Signal);
-
- procedure Disp_Signals_Map
- is
- Res : Traverse_Result;
- pragma Unreferenced (Res);
+ procedure Disp_Signals_Map is
begin
- Res := Disp_Signals_Map_Blocks (Get_Top_Context);
- Grt.Stdio.fflush (stdout);
+ Foreach_Scalar_Signal (Disp_Signals_Map_Scalar'access);
end Disp_Signals_Map;
-- Option --disp-signals-table
@@ -407,24 +442,24 @@ package body Grt.Disp_Signals is
procedure Process_Scalar (Val_Addr : Address;
Val_Name : Vstring;
- Val_Type : Ghdl_Rti_Access)
+ Val_Type : Ghdl_Rti_Access;
+ Param : Boolean)
is
pragma Unreferenced (Val_Type);
+ pragma Unreferenced (Param);
Sig1 : Ghdl_Signal_Ptr;
begin
-- Read the signal.
Sig1 := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
if Sig1 = Sig and not Found then
- Put (Stream, Cur_Ctxt);
- Put (Stream, ".");
- Disp_Signal_Name (Stream, Cur_Sig);
+ Disp_Signal_Name (Stream, Cur_Ctxt, Cur_Sig);
Put (Stream, Val_Name);
Found := True;
end if;
end Process_Scalar;
procedure Foreach_Scalar is new Grt.Rtis_Utils.Foreach_Scalar
- (Process_Scalar);
+ (Param_Type => Boolean, Process => Process_Scalar);
function Process_Block (Ctxt : Rti_Context;
Obj : Ghdl_Rti_Access)
@@ -442,7 +477,8 @@ package body Grt.Disp_Signals is
Cur_Sig := To_Ghdl_Rtin_Object_Acc (Obj);
Foreach_Scalar
(Ctxt, Cur_Sig.Obj_Type,
- Loc_To_Addr (Cur_Sig.Common.Depth, Cur_Sig.Loc, Ctxt), True);
+ Loc_To_Addr (Cur_Sig.Common.Depth, Cur_Sig.Loc, Ctxt),
+ True, True);
if Found then
return Traverse_Stop;
end if;
diff --git a/translate/grt/grt-disp_signals.ads b/translate/grt/grt-disp_signals.ads
index fd84fe0..398d4e5 100644
--- a/translate/grt/grt-disp_signals.ads
+++ b/translate/grt/grt-disp_signals.ads
@@ -26,6 +26,8 @@ package Grt.Disp_Signals is
procedure Disp_Signals_Table;
+ procedure Disp_All_Sensitivity;
+
procedure Disp_Mode_Signal (Mode : Mode_Signal_Type);
-- Disp informations on signal SIG.
diff --git a/translate/grt/grt-lib.adb b/translate/grt/grt-lib.adb
index dcddcf2..d35c73b 100644
--- a/translate/grt/grt-lib.adb
+++ b/translate/grt/grt-lib.adb
@@ -106,6 +106,16 @@ package body Grt.Lib is
Do_Report ("assertion", Str, Severity, Loc, Unit);
end Ghdl_Assert_Failed;
+ procedure Ghdl_Psl_Assert_Failed
+ (Str : Std_String_Ptr;
+ Severity : Integer;
+ Loc : Ghdl_Location_Ptr;
+ Unit : Ghdl_Rti_Access)
+ is
+ begin
+ Do_Report ("psl assertion", Str, Severity, Loc, Unit);
+ end Ghdl_Psl_Assert_Failed;
+
procedure Ghdl_Report
(Str : Std_String_Ptr;
Severity : Integer;
@@ -257,7 +267,6 @@ package body Grt.Lib is
return 1.0 / Res;
end if;
end Ghdl_Real_Exp;
-
end Grt.Lib;
diff --git a/translate/grt/grt-lib.ads b/translate/grt/grt-lib.ads
index 5bb2cd4..d58117b 100644
--- a/translate/grt/grt-lib.ads
+++ b/translate/grt/grt-lib.ads
@@ -30,6 +30,12 @@ package Grt.Lib is
Loc : Ghdl_Location_Ptr;
Unit : Ghdl_Rti_Access);
+ procedure Ghdl_Psl_Assert_Failed
+ (Str : Std_String_Ptr;
+ Severity : Integer;
+ Loc : Ghdl_Location_Ptr;
+ Unit : Ghdl_Rti_Access);
+
procedure Ghdl_Report
(Str : Std_String_Ptr;
Severity : Integer;
@@ -79,10 +85,26 @@ package Grt.Lib is
-- the export pragma.
pragma Export (C, Ghdl_Assert_Default_Report,
"__ghdl_assert_default_report");
+
+ type Ghdl_Std_Ulogic_Boolean_Array_Type is array (Ghdl_E8 range 0 .. 8)
+ of Ghdl_B2;
+
+ Ghdl_Std_Ulogic_To_Boolean_Array :
+ constant Ghdl_Std_Ulogic_Boolean_Array_Type := (False, -- U
+ False, -- X
+ False, -- 0
+ True, -- 1
+ False, -- Z
+ False, -- W
+ False, -- L
+ True, -- H
+ False -- -
+ );
private
pragma Export (C, Ghdl_Memcpy, "__ghdl_memcpy");
pragma Export (C, Ghdl_Assert_Failed, "__ghdl_assert_failed");
+ pragma Export (C, Ghdl_Psl_Assert_Failed, "__ghdl_psl_assert_failed");
pragma Export (C, Ghdl_Report, "__ghdl_report");
pragma Export (C, Ghdl_Bound_Check_Failed_L0,
@@ -97,6 +119,9 @@ private
pragma Export (C, Ghdl_Integer_Exp, "__ghdl_integer_exp");
pragma Export (C, Ghdl_Real_Exp, "__ghdl_real_exp");
+
+ pragma Export (C, Ghdl_Std_Ulogic_To_Boolean_Array,
+ "__ghdl_std_ulogic_to_boolean_array");
end Grt.Lib;
diff --git a/translate/grt/grt-main.adb b/translate/grt/grt-main.adb
index 43166fa..a196999 100644
--- a/translate/grt/grt-main.adb
+++ b/translate/grt/grt-main.adb
@@ -149,6 +149,9 @@ package body Grt.Main is
if Disp_Signals_Order then
Grt.Disp.Disp_Signals_Order;
end if;
+ if Disp_Sensitivity then
+ Grt.Disp_Signals.Disp_All_Sensitivity;
+ end if;
-- Do the simulation.
Status := Grt.Processes.Simulation;
diff --git a/translate/grt/grt-options.adb b/translate/grt/grt-options.adb
index a272246..6d73843 100644
--- a/translate/grt/grt-options.adb
+++ b/translate/grt/grt-options.adb
@@ -281,6 +281,8 @@ package body Grt.Options is
Disp_Signals_Map := True;
elsif Argument = "--disp-signals-table" then
Disp_Signals_Table := True;
+ elsif Argument = "--disp-sensitivity" then
+ Disp_Sensitivity := True;
elsif Argument = "--stats" then
Flag_Stats := True;
elsif Argument = "--no-run" then
diff --git a/translate/grt/grt-options.ads b/translate/grt/grt-options.ads
index 3057fc8..1d122ca 100644
--- a/translate/grt/grt-options.ads
+++ b/translate/grt/grt-options.ads
@@ -72,6 +72,7 @@ package Grt.Options is
Disp_Sources : Boolean := False;
Disp_Signals_Map : Boolean := False;
Disp_Signals_Table : Boolean := False;
+ Disp_Sensitivity : Boolean := False;
-- Set by --disp-order to diplay evaluation order of signals.
Disp_Signals_Order : Boolean := False;
diff --git a/translate/grt/grt-processes.adb b/translate/grt/grt-processes.adb
index 72d3f8e..0a57565 100644
--- a/translate/grt/grt-processes.adb
+++ b/translate/grt/grt-processes.adb
@@ -46,9 +46,20 @@ package body Grt.Processes is
Table_Low_Bound => 1,
Table_Initial => 16);
- -- List of non_sensitized processes.
- package Non_Sensitized_Process_Table is new Grt.Table
- (Table_Component_Type => Process_Acc,
+ function To_Proc_Acc is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Proc_Acc);
+
+ type Finalizer_Type is record
+ -- Subprogram containing process code.
+ Subprg : Proc_Acc;
+
+ -- Instance (THIS parameter) for the subprogram.
+ This : System.Address;
+ end record;
+
+ -- List of finalizer.
+ package Finalizer_Table is new Grt.Table
+ (Table_Component_Type => Finalizer_Type,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 2);
@@ -106,8 +117,6 @@ package body Grt.Processes is
State : Process_State;
Postponed : Boolean)
is
- function To_Proc_Acc is new Ada.Unchecked_Conversion
- (Source => System.Address, Target => Proc_Acc);
Stack : Stack_Type;
P : Process_Acc;
begin
@@ -133,9 +142,6 @@ package body Grt.Processes is
Process_Table.Append (P);
-- Used to create drivers.
Set_Current_Process (P);
- if State /= State_Sensitized then
- Non_Sensitized_Process_Table.Append (P);
- end if;
if Postponed then
Nbr_Postponed_Processes := Nbr_Postponed_Processes + 1;
else
@@ -228,6 +234,22 @@ package body Grt.Processes is
(Sig, Process_Table.Table (Process_Table.Last));
end Ghdl_Process_Add_Sensitivity;
+ procedure Ghdl_Finalize_Register (Instance : System.Address;
+ Proc : System.Address)
+ is
+ begin
+ Finalizer_Table.Append (Finalizer_Type'(To_Proc_Acc (Proc), Instance));
+ end Ghdl_Finalize_Register;
+
+ procedure Call_Finalizers is
+ El : Finalizer_Type;
+ begin
+ for I in Finalizer_Table.First .. Finalizer_Table.Last loop
+ El := Finalizer_Table.Table (I);
+ El.Subprg.all (El.This);
+ end loop;
+ end Call_Finalizers;
+
procedure Resume_Process (Proc : Process_Acc)
is
begin
@@ -983,6 +1005,8 @@ package body Grt.Processes is
Threads.Finish;
end if;
+ Call_Finalizers;
+
Grt.Hooks.Call_Finish_Hooks;
if Status = Run_Failure then
diff --git a/translate/grt/grt-processes.ads b/translate/grt/grt-processes.ads
index 1d5bb5f..b59a5b1 100644
--- a/translate/grt/grt-processes.ads
+++ b/translate/grt/grt-processes.ads
@@ -81,6 +81,9 @@ package Grt.Processes is
Ctxt : Ghdl_Rti_Access;
Addr : System.Address);
+ procedure Ghdl_Finalize_Register (Instance : System.Address;
+ Proc : System.Address);
+
procedure Ghdl_Initial_Register (Instance : System.Address;
Proc : System.Address);
procedure Ghdl_Always_Register (Instance : System.Address;
@@ -192,6 +195,8 @@ private
pragma Export (C, Ghdl_Postponed_Sensitized_Process_Register,
"__ghdl_postponed_sensitized_process_register");
+ pragma Export (C, Ghdl_Finalize_Register, "__ghdl_finalize_register");
+
pragma Export (C, Ghdl_Always_Register, "__ghdl_always_register");
pragma Export (C, Ghdl_Initial_Register, "__ghdl_initial_register");
diff --git a/translate/grt/grt-rtis.ads b/translate/grt/grt-rtis.ads
index 3059408..564b397 100644
--- a/translate/grt/grt-rtis.ads
+++ b/translate/grt/grt-rtis.ads
@@ -151,10 +151,10 @@ package Grt.Rtis is
Ghdl_Rti_Signal_Mode_Inout : constant Ghdl_Rti_U8 := 4;
Ghdl_Rti_Signal_Mode_In : constant Ghdl_Rti_U8 := 5;
- Ghdl_Rti_Signal_Kind_Mask : constant Ghdl_Rti_U8 := 48;
- Ghdl_Rti_Signal_Kind_No : constant Ghdl_Rti_U8 := 0;
- Ghdl_Rti_Signal_Kind_Register : constant Ghdl_Rti_U8 := 16;
- Ghdl_Rti_Signal_Kind_Bus : constant Ghdl_Rti_U8 := 32;
+ Ghdl_Rti_Signal_Kind_Mask : constant Ghdl_Rti_U8 := 3 * 16;
+ Ghdl_Rti_Signal_Kind_No : constant Ghdl_Rti_U8 := 0 * 16;
+ Ghdl_Rti_Signal_Kind_Register : constant Ghdl_Rti_U8 := 1 * 16;
+ Ghdl_Rti_Signal_Kind_Bus : constant Ghdl_Rti_U8 := 2 * 16;
Ghdl_Rti_Signal_Has_Active : constant Ghdl_Rti_U8 := 64;
@@ -198,7 +198,7 @@ package Grt.Rtis is
function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
(Source => Ghdl_Rtin_Subtype_Scalar_Acc, Target => Ghdl_Rti_Access);
- -- True if the type is complex.
+ -- True if the type is complex, set in Mode field.
Ghdl_Rti_Type_Complex_Mask : constant Ghdl_Rti_U8 := 1;
Ghdl_Rti_Type_Complex : constant Ghdl_Rti_U8 := 1;
diff --git a/translate/grt/grt-rtis_utils.adb b/translate/grt/grt-rtis_utils.adb
index d01cea9..dbc70c2 100644
--- a/translate/grt/grt-rtis_utils.adb
+++ b/translate/grt/grt-rtis_utils.adb
@@ -169,7 +169,8 @@ package body Grt.Rtis_Utils is
procedure Foreach_Scalar (Ctxt : Rti_Context;
Obj_Type : Ghdl_Rti_Access;
Obj_Addr : Address;
- Is_Sig : Boolean)
+ Is_Sig : Boolean;
+ Param : Param_Type)
is
-- Current address.
Addr : Address;
@@ -185,7 +186,7 @@ package body Grt.Rtis_Utils is
Addr := Addr + (S / Storage_Unit);
end Update;
begin
- Process (Addr, Name, Rti);
+ Process (Addr, Name, Rti, Param);
if Is_Sig then
Update (Address'Size);
@@ -448,18 +449,15 @@ package body Grt.Rtis_Utils is
declare
S : String (1 .. 32);
L : Integer;
- -- Warning: this assumes a C99 snprintf (ie, it returns the
- -- number of characters).
- function snprintf (Cstr : Address;
- Size : Natural;
- Template : Address;
- Arg : Ghdl_F64)
+
+ function Snprintf_G (Cstr : Address;
+ Size : Natural;
+ Arg : Ghdl_F64)
return Integer;
- pragma Import (C, snprintf);
+ pragma Import (C, Snprintf_G, "__ghdl_snprintf_g");
- Format : constant String := "%g" & Character'Val (0);
begin
- L := snprintf (S'Address, S'Length, Format'Address, Value.F64);
+ L := Snprintf_G (S'Address, S'Length, Value.F64);
if L < 0 then
-- FIXME.
Append (Str, "?");
diff --git a/translate/grt/grt-rtis_utils.ads b/translate/grt/grt-rtis_utils.ads
index 9b8fd33..232016d 100644
--- a/translate/grt/grt-rtis_utils.ads
+++ b/translate/grt/grt-rtis_utils.ads
@@ -29,6 +29,12 @@ package Grt.Rtis_Utils is
-- Traverse_Stop: end of walk.
type Traverse_Result is (Traverse_Ok, Traverse_Skip, Traverse_Stop);
+ -- An RTI object is a context and an RTI declaration.
+ type Rti_Object is record
+ Obj : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ end record;
+
-- Traverse all blocks (package, entities, architectures, block, generate,
-- processes).
generic
@@ -38,13 +44,16 @@ package Grt.Rtis_Utils is
function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result;
generic
+ type Param_Type is private;
with procedure Process (Val_Addr : Address;
Val_Name : Vstring;
- Val_Type : Ghdl_Rti_Access);
+ Val_Type : Ghdl_Rti_Access;
+ Param : Param_Type);
procedure Foreach_Scalar (Ctxt : Rti_Context;
Obj_Type : Ghdl_Rti_Access;
Obj_Addr : Address;
- Is_Sig : Boolean);
+ Is_Sig : Boolean;
+ Param : Param_Type);
procedure Get_Value (Str : in out Vstring;
Value : Value_Union;
diff --git a/translate/grt/grt-sdf.adb b/translate/grt/grt-sdf.adb
index fbf9f3e..16d7ee8 100644
--- a/translate/grt/grt-sdf.adb
+++ b/translate/grt/grt-sdf.adb
@@ -132,7 +132,7 @@ package body Grt.Sdf is
Read_Sdf;
end Read_Append;
- procedure Error_Sdf (Msg : String) is
+ procedure Error_Sdf_C is
begin
Error_C (Sdf_Filename.all);
Error_C (":");
@@ -140,6 +140,11 @@ package body Grt.Sdf is
Error_C (":");
Error_C (Pos - Line_Start);
Error_C (": ");
+ end Error_Sdf_C;
+
+ procedure Error_Sdf (Msg : String) is
+ begin
+ Error_Sdf_C;
Error_E (Msg);
end Error_Sdf;
@@ -525,6 +530,7 @@ package body Grt.Sdf is
-- Status of a parsing.
-- ERROR: parse error (syntax is not correct)
+ -- ALTERN: alternate construct parsed (ie simple RNUMBER for tc_rvalue).
-- OPTIONAL: the construct is absent.
-- FOUND: the construct is present.
-- SET: the construct is present and a value was extracted from.
@@ -737,6 +743,7 @@ package body Grt.Sdf is
Tok : Sdf_Token_Type;
Res : Parse_Status_Type;
begin
+ -- '('
if Get_Token /= Tok_Oparen then
Error_Sdf (Tok_Oparen);
return Status_Error;
@@ -748,12 +755,7 @@ package body Grt.Sdf is
Tok := Get_Token;
if Tok = Tok_Cparen then
-- This is a simple RNUMBER.
- if Get_Token = Tok_Cparen then
- return Status_Altern;
- else
- Error_Sdf (Tok_Cparen);
- return Status_Error;
- end if;
+ return Status_Altern;
end if;
if Sdf_Mtm = Minimum then
Res := Status_Set;
@@ -825,6 +827,10 @@ package body Grt.Sdf is
when Status_Error =>
return False;
when Status_Altern =>
+ Sdf_Context.Timing_Nbr := 1;
+ if Get_Token /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ end if;
return True;
when Status_Found
| Status_Optional =>
@@ -980,7 +986,9 @@ package body Grt.Sdf is
end if;
Vital_Annotate.Sdf_Generic (Sdf_Context.all, Name (1 .. Len), Ok);
if not Ok then
- Error_Sdf ("could not annotate generic");
+ Error_Sdf_C;
+ Error_C ("could not annotate generic ");
+ Error_E (Name (1 .. Len));
return False;
end if;
return True;
diff --git a/translate/grt/grt-signals.adb b/translate/grt/grt-signals.adb
index bbbc736..8704aab 100644
--- a/translate/grt/grt-signals.adb
+++ b/translate/grt/grt-signals.adb
@@ -145,7 +145,8 @@ package body Grt.Signals is
Mode => Mode,
Flags => (Propag => Propag_None,
Is_Dumped => False,
- Cyc_Event => False),
+ Cyc_Event => False,
+ Seen => False),
Net => No_Signal_Net,
Link => null,
@@ -3290,7 +3291,8 @@ package body Grt.Signals is
Flags => (Propag => Propag_None,
Is_Dumped => False,
- Cyc_Event => False),
+ Cyc_Event => False,
+ Seen => False),
Net => No_Signal_Net,
Link => null,
diff --git a/translate/grt/grt-signals.ads b/translate/grt/grt-signals.ads
index 2ada098..bab73ce 100644
--- a/translate/grt/grt-signals.ads
+++ b/translate/grt/grt-signals.ads
@@ -225,6 +225,10 @@ package Grt.Signals is
-- Set when an event occured.
-- Only reset by GHW file dumper.
Cyc_Event : Boolean;
+
+ -- Set if the signal has already been visited. When outside of the
+ -- algorithm that use it, it must be cleared.
+ Seen : Boolean;
end record;
pragma Pack (Ghdl_Signal_Flags);
diff --git a/translate/grt/grt-table.adb b/translate/grt/grt-table.adb
index f570b40..739322c 100644
--- a/translate/grt/grt-table.adb
+++ b/translate/grt/grt-table.adb
@@ -22,7 +22,7 @@ with Grt.C; use Grt.C;
package body Grt.Table is
-- Maximum index of table before resizing.
- Max : Table_Index_Type := Table_Low_Bound - 1;
+ Max : Table_Index_Type := Table_Index_Type'Pred (Table_Low_Bound);
-- Current value of Last
Last_Val : Table_Index_Type;
@@ -62,7 +62,7 @@ package body Grt.Table is
procedure Decrement_Last is
begin
- Last_Val := Last_Val - 1;
+ Last_Val := Table_Index_Type'Pred (Last_Val);
end Decrement_Last;
procedure Free is
@@ -73,7 +73,7 @@ package body Grt.Table is
procedure Increment_Last is
begin
- Last_Val := Last_Val + 1;
+ Last_Val := Table_Index_Type'Succ (Last_Val);
if Last_Val > Max then
Resize;
@@ -105,7 +105,7 @@ package body Grt.Table is
end Set_Last;
begin
- Last_Val := Table_Low_Bound - 1;
+ Last_Val := Table_Index_Type'Pred (Table_Low_Bound);
Max := Table_Low_Bound + Table_Index_Type (Table_Initial) - 1;
Table := Malloc (size_t (Table_Initial *
diff --git a/translate/grt/grt-vital_annotate.adb b/translate/grt/grt-vital_annotate.adb
index 2e7987c..b909f22 100644
--- a/translate/grt/grt-vital_annotate.adb
+++ b/translate/grt/grt-vital_annotate.adb
@@ -229,6 +229,8 @@ package body Grt.Vital_Annotate is
end Sdf_Instance_End;
VitalDelayType01 : VhpiHandleT;
+ VitalDelayType01Z : VhpiHandleT;
+ VitalDelayType01ZX : VhpiHandleT;
VitalDelayArrayType01 : VhpiHandleT;
VitalDelayType : VhpiHandleT;
VitalDelayArrayType : VhpiHandleT;
@@ -236,8 +238,8 @@ package body Grt.Vital_Annotate is
type Map_Type is array (1 .. 12) of Natural;
Map_1 : constant Map_Type := (1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0);
Map_2 : constant Map_Type := (1, 2, 1, 1, 2, 2, 0, 0, 0, 0, 0, 0);
- --Map_3 : constant Map_Type := (1, 2, 3, 1, 3, 2, 0, 0, 0, 0, 0, 0);
- --Map_6 : constant Map_Type := (1, 2, 3, 4, 5, 6, 0, 0, 0, 0, 0, 0);
+ Map_3 : constant Map_Type := (1, 2, 3, 1, 3, 2, 0, 0, 0, 0, 0, 0);
+ Map_6 : constant Map_Type := (1, 2, 3, 4, 5, 6, 0, 0, 0, 0, 0, 0);
--Map_12 : constant Map_Type := (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12);
function Write_Td_Delay_Generic (Context : Sdf_Context_Type;
@@ -296,6 +298,20 @@ package body Grt.Vital_Annotate is
Errors.Error
("timing generic type mismatch SDF timing specification");
end case;
+ elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01Z) then
+ case Context.Timing_Nbr is
+ when 1 =>
+ return Write_Td_Delay_Generic (Context, Gen, 6, Map_1);
+ when 2 =>
+ return Write_Td_Delay_Generic (Context, Gen, 6, Map_2);
+ when 3 =>
+ return Write_Td_Delay_Generic (Context, Gen, 6, Map_3);
+ when 6 =>
+ return Write_Td_Delay_Generic (Context, Gen, 6, Map_6);
+ when others =>
+ Errors.Error
+ ("timing generic type mismatch SDF timing specification");
+ end case;
elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType) then
if Vhpi_Put_Value (Gen, Context.Timing (1) * 1000) /= AvhpiErrorOk
then
@@ -406,7 +422,10 @@ package body Grt.Vital_Annotate is
Internal_Error ("vhpiBaseType");
return;
end if;
- if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01) then
+ if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01)
+ or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01Z)
+ or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01ZX)
+ then
Ok := Write_Td_Delay_Generic (Context, Gen);
elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType01)
or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType)
@@ -451,7 +470,8 @@ package body Grt.Vital_Annotate is
Ok := Write_Td_Delay_Generic (Context, Gen_El);
end;
else
- Errors.Error ("vital: unhandled generic type");
+ Errors.Error_C ("vital: unhandled generic type for generic ");
+ Errors.Error_E (Name);
end if;
end Sdf_Generic;
@@ -483,8 +503,8 @@ package body Grt.Vital_Annotate is
-- Instance element.
S := E;
while Arg (E) /= '=' and Arg (E) /= '.' and Arg (E) /= '/' loop
- exit L1 when E > Arg'Last;
E := E + 1;
+ exit L1 when E > Arg'Last;
end loop;
-- Path element.
@@ -545,6 +565,10 @@ package body Grt.Vital_Annotate is
if Status = AvhpiErrorOk then
if Name_Compare (Decl, "vitaldelaytype01") then
VitalDelayType01 := Basetype;
+ elsif Name_Compare (Decl, "vitaldelaytype01z") then
+ VitalDelayType01Z := Basetype;
+ elsif Name_Compare (Decl, "vitaldelaytype01zx") then
+ VitalDelayType01ZX := Basetype;
elsif Name_Compare (Decl, "vitaldelayarraytype01") then
VitalDelayArrayType01 := Basetype;
elsif Name_Compare (Decl, "vitaldelaytype") then
@@ -559,6 +583,14 @@ package body Grt.Vital_Annotate is
Error ("cannot find VitalDelayType01 in ieee.vital_timing");
return;
end if;
+ if Vhpi_Get_Kind (VitalDelayType01Z) = VhpiUndefined then
+ Error ("cannot find VitalDelayType01Z in ieee.vital_timing");
+ return;
+ end if;
+ if Vhpi_Get_Kind (VitalDelayType01ZX) = VhpiUndefined then
+ Error ("cannot find VitalDelayType01ZX in ieee.vital_timing");
+ return;
+ end if;
if Vhpi_Get_Kind (VitalDelayArrayType01) = VhpiUndefined then
Error ("cannot find VitalDelayArrayType01 in ieee.vital_timing");
return;
diff --git a/translate/grt/grt-waves.adb b/translate/grt/grt-waves.adb
index 62c1ae4..c4319c8 100644
--- a/translate/grt/grt-waves.adb
+++ b/translate/grt/grt-waves.adb
@@ -633,13 +633,16 @@ package body Grt.Waves is
| Ghdl_Rtik_Subtype_Array_Ptr =>
declare
Arr : Ghdl_Rtin_Subtype_Array_Acc;
+ B_Ctxt : Rti_Context;
begin
Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
Create_String_Id (Arr.Name);
- if Rti.Mode = 1 then
- N_Ctxt := Ctxt;
+ if Rti.Mode = Ghdl_Rti_Type_Complex then
+ B_Ctxt := Ctxt;
+ else
+ B_Ctxt := N_Ctxt;
end if;
- Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), N_Ctxt);
+ Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), B_Ctxt);
end;
when Ghdl_Rtik_Type_Array =>
declare
@@ -823,10 +826,12 @@ package body Grt.Waves is
procedure Write_Signal_Number (Val_Addr : Address;
Val_Name : Vstring;
- Val_Type : Ghdl_Rti_Access)
+ Val_Type : Ghdl_Rti_Access;
+ Param_Type : Natural)
is
pragma Unreferenced (Val_Name);
pragma Unreferenced (Val_Type);
+ pragma Unreferenced (Param_Type);
Num : Natural;
@@ -853,7 +858,8 @@ package body Grt.Waves is
end Write_Signal_Number;
procedure Foreach_Scalar_Signal_Number is new
- Grt.Rtis_Utils.Foreach_Scalar (Process => Write_Signal_Number);
+ Grt.Rtis_Utils.Foreach_Scalar (Param_Type => Natural,
+ Process => Write_Signal_Number);
procedure Write_Signal_Numbers (Decl : VhpiHandleT)
is
@@ -864,7 +870,7 @@ package body Grt.Waves is
Sig := To_Ghdl_Rtin_Object_Acc (Avhpi_Get_Rti (Decl));
Foreach_Scalar_Signal_Number
(Ctxt, Sig.Obj_Type,
- Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True);
+ Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True, 0);
end Write_Signal_Numbers;
procedure Write_Hierarchy_El (Decl : VhpiHandleT)
diff --git a/translate/ortho_front.adb b/translate/ortho_front.adb
index d69c9b1..e5d6626 100644
--- a/translate/ortho_front.adb
+++ b/translate/ortho_front.adb
@@ -16,7 +16,6 @@
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
with Types; use Types;
-with Std_Names;
with Name_Table;
with Std_Package;
with Back_End;
@@ -73,8 +72,9 @@ package body Ortho_Front is
begin
-- Initialize.
Trans_Be.Register_Translation_Back_End;
- Std_Names.Std_Names_Initialize;
- Libraries.Init_Pathes;
+
+ Options.Initialize;
+
Elab_Filelist := null;
Elab_Entity := null;
Elab_Architecture := null;
diff --git a/translate/trans_analyzes.adb b/translate/trans_analyzes.adb
index 43d7508..fd533e2 100644
--- a/translate/trans_analyzes.adb
+++ b/translate/trans_analyzes.adb
@@ -1,3 +1,21 @@
+-- Analysis for translation.
+-- Copyright (C) 2009 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 Iirs_Utils; use Iirs_Utils;
with Iirs_Walk; use Iirs_Walk;
with Disp_Vhdl;
@@ -107,7 +125,7 @@ package body Trans_Analyzes is
if Get_Kind (Decl) = Iir_Kind_Procedure_Body
or else (Get_Kind (Decl) = Iir_Kind_Function_Body
and then
- Get_Pure_Flag (Get_Subprogram_Specification (Decl)))
+ not Get_Pure_Flag (Get_Subprogram_Specification (Decl)))
then
Extract_Drivers_Declaration_Chain (Get_Declaration_Chain (Decl));
Extract_Drivers_Sequential_Stmt_Chain
diff --git a/translate/trans_analyzes.ads b/translate/trans_analyzes.ads
index 30b4f46..ecebb75 100644
--- a/translate/trans_analyzes.ads
+++ b/translate/trans_analyzes.ads
@@ -1,3 +1,21 @@
+-- Analysis for translation.
+-- Copyright (C) 2009 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 Iirs; use Iirs;
package Trans_Analyzes is
diff --git a/translate/trans_decls.ads b/translate/trans_decls.ads
index 027cbb5..8a93fcf 100644
--- a/translate/trans_decls.ads
+++ b/translate/trans_decls.ads
@@ -18,8 +18,9 @@
with Ortho_Nodes; use Ortho_Nodes;
package Trans_Decls is
- -- Procedure called in case of assert failed.
+ -- Procedures called in case of assert failed.
Ghdl_Assert_Failed : O_Dnode;
+ Ghdl_Psl_Assert_Failed : O_Dnode;
-- Procedure for report statement.
Ghdl_Report : O_Dnode;
-- Ortho node for default report message.
@@ -31,6 +32,8 @@ package Trans_Decls is
Ghdl_Postponed_Process_Register : O_Dnode;
Ghdl_Postponed_Sensitized_Process_Register : O_Dnode;
+ Ghdl_Finalize_Register : O_Dnode;
+
-- Wait subprograms.
-- Short forms.
Ghdl_Process_Wait_Timeout : O_Dnode;
@@ -222,5 +225,8 @@ package Trans_Decls is
Ghdl_Get_Path_Name : O_Dnode;
Ghdl_Get_Instance_Name : O_Dnode;
+ -- For PSL.
+ Ghdl_Std_Ulogic_To_Boolean_Array : O_Dnode;
+
Ghdl_Elaborate : O_Dnode;
end Trans_Decls;
diff --git a/translate/translation.adb b/translate/translation.adb
index 7a6f387..b2294bb 100644
--- a/translate/translation.adb
+++ b/translate/translation.adb
@@ -38,7 +38,12 @@ with Sem;
with Iir_Chains; use Iir_Chains;
with Nodes;
with GNAT.Table;
+with Ieee.Std_Logic_1164;
with Canon;
+with Canon_PSL;
+with PSL.Nodes;
+with PSL.NFAs;
+with PSL.NFAs.Utils;
with Trans_Decls; use Trans_Decls;
with Trans_Analyzes;
@@ -48,6 +53,10 @@ package body Translation is
Std_Boolean_Type_Node : O_Tnode;
Std_Boolean_True_Node : O_Cnode;
Std_Boolean_False_Node : O_Cnode;
+ -- Array of STD.BOOLEAN.
+ Std_Boolean_Array_Type : O_Tnode;
+ -- Std_ulogic indexed array of STD.Boolean.
+ Std_Ulogic_Boolean_Array_Type : O_Tnode;
-- Ortho type node for string template pointer.
Std_String_Ptr_Node : O_Tnode;
Std_String_Node : O_Tnode;
@@ -149,36 +158,29 @@ package body Translation is
type Object_Kind_Type is (Mode_Value, Mode_Signal);
-- Well known identifiers.
- type Wk_Ident_Type is
- (
- Wkie_This, Wkie_Size, Wkie_Res, Wkie_Dir_To, Wkie_Dir_Downto,
- Wkie_Left, Wkie_Right, Wkie_Dir, Wkie_Length, Wkie_Kind, Wkie_Dim,
- Wkie_I, Wkie_Instance, Wkie_Arch_Instance, Wkie_Name, Wkie_Sig,
- Wkie_Obj, Wkie_Rti, Wkie_Parent, Wkie_Filename, Wkie_Line
- );
- type Wk_Ident_Tree_Array is array (Wk_Ident_Type) of O_Ident;
- Wk_Idents : Wk_Ident_Tree_Array;
- Wki_This : O_Ident renames Wk_Idents (Wkie_This);
- Wki_Size : O_Ident renames Wk_Idents (Wkie_Size);
- Wki_Res : O_Ident renames Wk_Idents (Wkie_Res);
- Wki_Dir_To : O_Ident renames Wk_Idents (Wkie_Dir_To);
- Wki_Dir_Downto : O_Ident renames Wk_Idents (Wkie_Dir_Downto);
- Wki_Left : O_Ident renames Wk_Idents (Wkie_Left);
- Wki_Right : O_Ident renames Wk_Idents (Wkie_Right);
- Wki_Dir : O_Ident renames Wk_Idents (Wkie_Dir);
- Wki_Length : O_Ident renames Wk_Idents (Wkie_Length);
- Wki_Kind : O_Ident renames Wk_Idents (Wkie_Kind);
- Wki_Dim : O_Ident renames Wk_Idents (Wkie_Dim);
- Wki_I : O_Ident renames Wk_Idents (Wkie_I);
- Wki_Instance : O_Ident renames Wk_Idents (Wkie_Instance);
- Wki_Arch_Instance : O_Ident renames Wk_Idents (Wkie_Arch_Instance);
- Wki_Name : O_Ident renames Wk_Idents (Wkie_Name);
- Wki_Sig : O_Ident renames Wk_Idents (Wkie_Sig);
- Wki_Obj : O_Ident renames Wk_Idents (Wkie_Obj);
- Wki_Rti : O_Ident renames Wk_Idents (Wkie_Rti);
- Wki_Parent : O_Ident renames Wk_Idents (Wkie_Parent);
- Wki_Filename : O_Ident renames Wk_Idents (Wkie_Filename);
- Wki_Line : O_Ident renames Wk_Idents (Wkie_Line);
+ Wki_This : O_Ident;
+ Wki_Size : O_Ident;
+ Wki_Res : O_Ident;
+ Wki_Dir_To : O_Ident;
+ Wki_Dir_Downto : O_Ident;
+ Wki_Left : O_Ident;
+ Wki_Right : O_Ident;
+ Wki_Dir : O_Ident;
+ Wki_Length : O_Ident;
+ Wki_I : O_Ident;
+ Wki_Instance : O_Ident;
+ Wki_Arch_Instance : O_Ident;
+ Wki_Name : O_Ident;
+ Wki_Sig : O_Ident;
+ Wki_Obj : O_Ident;
+ Wki_Rti : O_Ident;
+ Wki_Parent : O_Ident;
+ Wki_Filename : O_Ident;
+ Wki_Line : O_Ident;
+ Wki_Lo : O_Ident;
+ Wki_Hi : O_Ident;
+ Wki_Mid : O_Ident;
+ Wki_Cmp : O_Ident;
-- ALLOCATION_KIND defines the type of memory storage.
-- ALLOC_STACK means the object is allocated on the local stack and
@@ -603,6 +605,8 @@ package body Translation is
Dir : Iir_Direction;
Val : Unsigned_64;
Itype : Iir);
+
+ procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir);
end Chap8;
package Chap9 is
@@ -670,6 +674,7 @@ package body Translation is
Ghdl_Rtik_Attribute_Transaction : O_Cnode;
Ghdl_Rtik_Attribute_Quiet : O_Cnode;
Ghdl_Rtik_Attribute_Stable : O_Cnode;
+ Ghdl_Rtik_Psl_Assert : O_Cnode;
Ghdl_Rtik_Error : O_Cnode;
-- RTI types.
@@ -757,6 +762,7 @@ package body Translation is
Kind_Interface,
Kind_Disconnect,
Kind_Process,
+ Kind_Psl_Assert,
Kind_Loop,
Kind_Block,
Kind_Component,
@@ -764,6 +770,7 @@ package body Translation is
Kind_Package,
Kind_Config,
Kind_Assoc,
+ Kind_Str_Choice,
Kind_Design_File,
Kind_Library
);
@@ -1166,6 +1173,29 @@ package body Translation is
-- RTI for the process.
Process_Rti_Const : O_Dnode := O_Dnode_Null;
+ when Kind_Psl_Assert =>
+ -- Type of assert declarations record.
+ Psl_Decls_Type : O_Tnode;
+
+ -- Field in the parent block for the declarations in the assert.
+ Psl_Parent_Field : O_Fnode;
+
+ -- Procedure for the state machine.
+ Psl_Proc_Subprg : O_Dnode;
+ -- Procedure for finalization. Handles EOS.
+ Psl_Proc_Final_Subprg : O_Dnode;
+
+ -- Length of the state vector.
+ Psl_Vect_Len : Natural;
+
+ -- Type of the state vector.
+ Psl_Vect_Type : O_Tnode;
+
+ -- State vector variable.
+ Psl_Vect_Var : Var_Acc;
+
+ -- RTI for the process.
+ Psl_Rti_Const : O_Dnode := O_Dnode_Null;
when Kind_Loop =>
-- Labels for the loop.
-- Used for exit/next from while-loop, and to exit from for-loop.
@@ -1245,6 +1275,15 @@ package body Translation is
-- Association informations.
Assoc_In : Assoc_Conv_Info;
Assoc_Out : Assoc_Conv_Info;
+ when Kind_Str_Choice =>
+ -- List of choices, used to sort them.
+ Choice_Chain : Ortho_Info_Acc;
+ -- Association index.
+ Choice_Assoc : Natural;
+ -- Corresponding choice simple expression.
+ Choice_Expr : Iir;
+ -- Corresponding choice.
+ Choice_Parent : Iir;
when Kind_Design_File =>
Design_Filename : O_Dnode;
when Kind_Library =>
@@ -1261,6 +1300,7 @@ package body Translation is
subtype Object_Info_Acc is Ortho_Info_Acc (Kind_Object);
subtype Alias_Info_Acc is Ortho_Info_Acc (Kind_Alias);
subtype Proc_Info_Acc is Ortho_Info_Acc (Kind_Process);
+ subtype Psl_Info_Acc is Ortho_Info_Acc (Kind_Psl_Assert);
subtype Loop_Info_Acc is Ortho_Info_Acc (Kind_Loop);
subtype Block_Info_Acc is Ortho_Info_Acc (Kind_Block);
subtype Comp_Info_Acc is Ortho_Info_Acc (Kind_Component);
@@ -2020,6 +2060,8 @@ package body Translation is
Prg_Err_Missing_Return : constant Natural := 1;
Prg_Err_Block_Configured : constant Natural := 2;
Prg_Err_Dummy_Config : constant Natural := 3;
+ Prg_Err_No_Choice : constant Natural := 4;
+ Prg_Err_Bad_Choice : constant Natural := 5;
procedure Gen_Program_Error (Loc : Iir; Code : Natural);
-- Generate code to emit a failure if COND is TRUE, indicating an
@@ -2276,6 +2318,8 @@ package body Translation is
procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode);
-- Create a uniq identifier.
+ subtype Uniq_Identifier_String is String (1 .. 11);
+ function Create_Uniq_Identifier return Uniq_Identifier_String;
function Create_Uniq_Identifier return O_Ident;
-- Create a region for temporary variables.
@@ -2317,6 +2361,9 @@ package body Translation is
-- Used only to free memory.
procedure Free_Old_Temp;
+ -- Return a ghdl_index_type literal for NUM.
+ function New_Index_Lit (Num : Unsigned_64) return O_Cnode;
+
-- Create a constant (of name ID) for string STR.
-- Append a NUL terminator (to make interfaces with C easier).
function Create_String (Str : String; Id : O_Ident) return O_Dnode;
@@ -2968,9 +3015,9 @@ package body Translation is
Ptr : String_Fat_Acc;
begin
Ptr := Get_String_Fat_Acc (Expr);
- Name_Length := Get_String_Length (Expr);
+ Name_Length := Natural (Get_String_Length (Expr));
for I in 1 .. Name_Length loop
- Name_Buffer (I) := Ptr (I);
+ Name_Buffer (I) := Ptr (Nat32 (I));
end loop;
end;
when Iir_Kind_Simple_Aggregate =>
@@ -3163,9 +3210,9 @@ package body Translation is
Uniq_Id : Natural := 0;
- function Create_Uniq_Identifier return O_Ident
+ function Create_Uniq_Identifier return Uniq_Identifier_String
is
- Str : String (1 .. 12);
+ Str : Uniq_Identifier_String;
Val : Natural;
begin
Str (1 .. 3) := "_UI";
@@ -3175,8 +3222,12 @@ package body Translation is
Str (I) := N2hex (Val mod 16);
Val := Val / 16;
end loop;
- --Str (12) := Nul;
- return Get_Identifier (Str (1 .. 11));
+ return Str;
+ end Create_Uniq_Identifier;
+
+ function Create_Uniq_Identifier return O_Ident is
+ begin
+ return Get_Identifier (Create_Uniq_Identifier);
end Create_Uniq_Identifier;
-- Create a temporary variable.
@@ -3407,6 +3458,12 @@ package body Translation is
return Create_Temp_Init (Temp_Type, New_Address (Name, Temp_Type));
end Create_Temp_Ptr;
+ -- Return a ghdl_index_type literal for NUM.
+ function New_Index_Lit (Num : Unsigned_64) return O_Cnode is
+ begin
+ return New_Unsigned_Literal (Ghdl_Index_Type, Num);
+ end New_Index_Lit;
+
-- Convert NAME into a STRING_CST.
-- Append a NUL terminator (to make interfaces with C easier).
function Create_String_Type (Str : String) return O_Tnode is
@@ -10853,6 +10910,7 @@ package body Translation is
then
case Get_Implicit_Definition (El) is
when Iir_Predefined_Array_Equality
+ | Iir_Predefined_Array_Greater
| Iir_Predefined_Record_Equality =>
-- Used implicitly in case statement or other
-- predefined equality.
@@ -13365,7 +13423,7 @@ package body Translation is
Literal_List : Iir_List;
Lit : Iir;
- Len : Natural;
+ Len : Nat32;
Ptr : String_Fat_Acc;
begin
Literal_List :=
@@ -13387,7 +13445,7 @@ package body Translation is
L_0 : O_Cnode;
L_1 : O_Cnode;
Ptr : String_Fat_Acc;
- Len : Natural;
+ Len : Nat32;
V : O_Cnode;
begin
L_0 := Get_Ortho_Expr (Get_Bit_String_0 (Lit));
@@ -13506,14 +13564,16 @@ package body Translation is
Lit_Type : Iir;
Element_Type : Iir;
+ Arr_Type : O_Tnode;
List : O_Array_Aggr_List;
Res : O_Cnode;
begin
Lit_Type := Get_Type (Str);
Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True);
+ Arr_Type := Get_Ortho_Type (Lit_Type, Mode_Value);
- Start_Array_Aggr (List, Get_Ortho_Type (Lit_Type, Mode_Value));
+ Start_Array_Aggr (List, Arr_Type);
Element_Type := Get_Element_Subtype (Lit_Type);
@@ -13526,8 +13586,8 @@ package body Translation is
-- Some strings literal have an unconstrained array type,
-- eg: 'image of constant. Its type is not constrained
-- because it is not so in VHDL!
- function Translate_Static_Unconstrained_String_Literal (Str : Iir)
- return O_Cnode
+ function Translate_Non_Static_String_Literal (Str : Iir)
+ return O_Enode
is
use Name_Table;
@@ -13545,9 +13605,10 @@ package body Translation is
Len : Int32;
Val : Var_Acc;
Bound : Var_Acc;
+ R : O_Enode;
begin
Lit_Type := Get_Type (Str);
- Type_Info := Get_Info (Get_Base_Type (Lit_Type));
+ Type_Info := Get_Info (Lit_Type);
-- Create the string value.
Len := Get_String_Length (Str);
@@ -13557,51 +13618,76 @@ package body Translation is
Start_Array_Aggr (Val_Aggr, Str_Type);
Element_Type := Get_Element_Subtype (Lit_Type);
- Translate_Static_String_Literal_Inner (Val_Aggr, Str, Element_Type);
+ case Get_Kind (Str) is
+ when Iir_Kind_String_Literal =>
+ Translate_Static_String_Literal_Inner
+ (Val_Aggr, Str, Element_Type);
+ when Iir_Kind_Bit_String_Literal =>
+ Translate_Static_Bit_String_Literal_Inner
+ (Val_Aggr, Str, Element_Type);
+ when others =>
+ raise Internal_Error;
+ end case;
Finish_Array_Aggr (Val_Aggr, Res);
Val := Create_Global_Const
(Create_Uniq_Identifier, Str_Type, O_Storage_Private, Res);
- -- Create the string bound.
- Index_Type := Get_First_Element (Get_Index_Subtype_List (Lit_Type));
- Index_Type_Info := Get_Info (Index_Type);
- Start_Record_Aggr (Bound_Aggr, Type_Info.T.Bounds_Type);
- Start_Record_Aggr (Index_Aggr, Index_Type_Info.T.Range_Type);
- New_Record_Aggr_El
- (Index_Aggr,
- New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value), 0));
- New_Record_Aggr_El
- (Index_Aggr,
- New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value),
+ if Type_Info.Type_Mode = Type_Mode_Fat_Array then
+ -- Create the string bound.
+ Index_Type :=
+ Get_First_Element (Get_Index_Subtype_List (Lit_Type));
+ Index_Type_Info := Get_Info (Index_Type);
+ Start_Record_Aggr (Bound_Aggr, Type_Info.T.Bounds_Type);
+ Start_Record_Aggr (Index_Aggr, Index_Type_Info.T.Range_Type);
+ New_Record_Aggr_El
+ (Index_Aggr,
+ New_Signed_Literal
+ (Index_Type_Info.Ortho_Type (Mode_Value), 0));
+ New_Record_Aggr_El
+ (Index_Aggr,
+ New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value),
Integer_64 (Len - 1)));
- New_Record_Aggr_El
- (Index_Aggr, Ghdl_Dir_To_Node);
- New_Record_Aggr_El
- (Index_Aggr,
- New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len)));
- Finish_Record_Aggr (Index_Aggr, Res);
- New_Record_Aggr_El (Bound_Aggr, Res);
- Finish_Record_Aggr (Bound_Aggr, Res);
- Bound := Create_Global_Const
- (Create_Uniq_Identifier, Type_Info.T.Bounds_Type,
- O_Storage_Private, Res);
-
- -- The descriptor.
- Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value));
- New_Record_Aggr_El
- (Res_Aggr,
- New_Global_Address (Get_Var_Label (Val),
- Type_Info.T.Base_Ptr_Type (Mode_Value)));
- New_Record_Aggr_El
- (Res_Aggr,
- New_Global_Address (Get_Var_Label (Bound),
- Type_Info.T.Bounds_Ptr_Type));
- Finish_Record_Aggr (Res_Aggr, Res);
+ New_Record_Aggr_El
+ (Index_Aggr, Ghdl_Dir_To_Node);
+ New_Record_Aggr_El
+ (Index_Aggr,
+ New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len)));
+ Finish_Record_Aggr (Index_Aggr, Res);
+ New_Record_Aggr_El (Bound_Aggr, Res);
+ Finish_Record_Aggr (Bound_Aggr, Res);
+ Bound := Create_Global_Const
+ (Create_Uniq_Identifier, Type_Info.T.Bounds_Type,
+ O_Storage_Private, Res);
+
+ -- The descriptor.
+ Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value));
+ New_Record_Aggr_El
+ (Res_Aggr,
+ New_Global_Address (Get_Var_Label (Val),
+ Type_Info.T.Base_Ptr_Type (Mode_Value)));
+ New_Record_Aggr_El
+ (Res_Aggr,
+ New_Global_Address (Get_Var_Label (Bound),
+ Type_Info.T.Bounds_Ptr_Type));
+ Finish_Record_Aggr (Res_Aggr, Res);
+ Free_Var (Val);
+ Free_Var (Bound);
+
+ Val := Create_Global_Const
+ (Create_Uniq_Identifier, Type_Info.Ortho_Type (Mode_Value),
+ O_Storage_Private, Res);
+ elsif Type_Info.Type_Mode = Type_Mode_Ptr_Array then
+ null;
+ else
+ raise Internal_Error;
+ end if;
+
+ R := New_Address (Get_Var (Val),
+ Type_Info.Ortho_Ptr_Type (Mode_Value));
Free_Var (Val);
- Free_Var (Bound);
- return Res;
- end Translate_Static_Unconstrained_String_Literal;
+ return R;
+ end Translate_Non_Static_String_Literal;
-- Only for Strings of STD.Character.
function Translate_Static_String (Str_Type : Iir; Str_Ident : Name_Id)
@@ -13655,33 +13741,36 @@ package body Translation is
Res : O_Cnode;
R : O_Enode;
begin
- case Get_Kind (Str) is
- when Iir_Kind_String_Literal =>
- if Get_Kind (Get_Type (Str))
- = Iir_Kind_Array_Subtype_Definition
- then
- Res := Translate_Static_String_Literal (Str);
- else
- Res := Translate_Static_Unconstrained_String_Literal (Str);
- end if;
- when Iir_Kind_Bit_String_Literal =>
- Res := Translate_Static_Bit_String_Literal (Str);
- when Iir_Kind_Simple_Aggregate =>
- Res := Translate_Static_Simple_Aggregate (Str);
- when Iir_Kind_Simple_Name_Attribute =>
- Res := Translate_Static_String
- (Get_Type (Str), Get_Simple_Name_Identifier (Str));
- when others =>
- raise Internal_Error;
- end case;
Str_Type := Get_Type (Str);
- Info := Get_Info (Str_Type);
- Var := Create_Global_Const
- (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value),
- O_Storage_Private, Res);
- R := New_Address (Get_Var (Var), Info.Ortho_Ptr_Type (Mode_Value));
- Free_Var (Var);
- return R;
+ if Get_Constraint_State (Str_Type) = Fully_Constrained
+ and then Get_Type_Staticness
+ (Get_First_Element (Get_Index_Subtype_List (Str_Type)))
+ = Locally
+ then
+ case Get_Kind (Str) is
+ when Iir_Kind_String_Literal =>
+ Res := Translate_Static_String_Literal (Str);
+ when Iir_Kind_Bit_String_Literal =>
+ Res := Translate_Static_Bit_String_Literal (Str);
+ when Iir_Kind_Simple_Aggregate =>
+ Res := Translate_Static_Simple_Aggregate (Str);
+ when Iir_Kind_Simple_Name_Attribute =>
+ Res := Translate_Static_String
+ (Get_Type (Str), Get_Simple_Name_Identifier (Str));
+ when others =>
+ raise Internal_Error;
+ end case;
+ Str_Type := Get_Type (Str);
+ Info := Get_Info (Str_Type);
+ Var := Create_Global_Const
+ (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value),
+ O_Storage_Private, Res);
+ R := New_Address (Get_Var (Var), Info.Ortho_Ptr_Type (Mode_Value));
+ Free_Var (Var);
+ return R;
+ else
+ return Translate_Non_Static_String_Literal (Str);
+ end if;
end Translate_String_Literal;
function Translate_Static_Implicit_Conv
@@ -15067,7 +15156,7 @@ package body Translation is
Lit : Iir;
Pos : O_Enode;
Ptr : String_Fat_Acc;
- Len : Natural;
+ Len : Nat32;
begin
Ptr := Get_String_Fat_Acc (Aggr);
Len := Get_String_Length (Aggr);
@@ -15083,7 +15172,7 @@ package body Translation is
(ON_Add_Ov,
New_Obj_Value (Var_Index),
New_Lit (New_Unsigned_Literal
- (Ghdl_Index_Type, Natural'Pos (I - 1))));
+ (Ghdl_Index_Type, Nat32'Pos (I - 1))));
end if;
New_Assign_Stmt
(M2Lv (Chap3.Index_Base (Base_Ptr, Aggr_Type, Pos)),
@@ -15095,7 +15184,7 @@ package body Translation is
(ON_Add_Ov,
New_Obj_Value (Var_Index),
New_Lit (New_Unsigned_Literal (Ghdl_Index_Type,
- Natural'Pos (Len)))));
+ Nat32'Pos (Len)))));
end;
return;
when Iir_Kind_Bit_String_Literal =>
@@ -15504,7 +15593,7 @@ package body Translation is
-- FIXME: creating aggregate subtype is expensive and rarely used.
-- (one of the current use - only ? - is check_array_match).
- Chap3.Translate_Type_Definition (Aggr_Type, False);
+ Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, False);
end Translate_Array_Aggregate;
procedure Translate_Aggregate
@@ -18879,9 +18968,10 @@ package body Translation is
Translate_Report (Stmt, Ghdl_Report, Severity_Level_Note);
end Translate_Report_Statement;
+ -- Helper to compare a string choice with the selector.
function Translate_Simple_String_Choice
(Expr : O_Dnode;
- Val : Iir;
+ Val : O_Enode;
Val_Node : O_Dnode;
Tinfo : Type_Info_Acc;
Func : Iir)
@@ -18893,7 +18983,7 @@ package body Translation is
New_Assign_Stmt
(New_Selected_Element (New_Obj (Val_Node),
Tinfo.T.Base_Field (Mode_Value)),
- Chap7.Translate_Expression (Val, Get_Type (Val)));
+ Val);
Func_Info := Get_Info (Func);
Start_Association (Assoc, Func_Info.Ortho_Func);
Chap2.Add_Subprg_Instance_Assoc (Assoc, Func_Info.Subprg_Instance);
@@ -18904,107 +18994,462 @@ package body Translation is
return New_Function_Call (Assoc);
end Translate_Simple_String_Choice;
- procedure Translate_String_Choice
- (Expr : O_Dnode;
- Val_Node : O_Dnode;
+ -- Helper to evaluate the selector and preparing a choice variable.
+ procedure Translate_String_Case_Statement_Common
+ (Stmt : Iir_Case_Statement;
+ Expr_Type : out Iir;
+ Tinfo : out Type_Info_Acc;
+ Expr_Node : out O_Dnode;
+ C_Node : out O_Dnode)
+ is
+ Expr : Iir;
+ Base_Type : Iir;
+ begin
+ -- Translate into if/elsif statements.
+ -- FIXME: if the number of literals ** length of the array < 256,
+ -- use a case statement.
+ Expr := Get_Expression (Stmt);
+ Expr_Type := Get_Type (Expr);
+ Base_Type := Get_Base_Type (Expr_Type);
+ Tinfo := Get_Info (Base_Type);
+
+ -- Translate selector.
+ Expr_Node := Create_Temp_Init
+ (Tinfo.Ortho_Ptr_Type (Mode_Value),
+ Chap7.Translate_Expression (Expr, Base_Type));
+
+ -- Copy the bounds for the choices.
+ C_Node := Create_Temp (Tinfo.Ortho_Type (Mode_Value));
+ New_Assign_Stmt
+ (New_Selected_Element (New_Obj (C_Node),
+ Tinfo.T.Bounds_Field (Mode_Value)),
+ New_Value_Selected_Acc_Value
+ (New_Obj (Expr_Node), Tinfo.T.Bounds_Field (Mode_Value)));
+ end Translate_String_Case_Statement_Common;
+
+ -- Translate a string case statement using a dichotomy.
+ procedure Translate_String_Case_Statement_Dichotomy
+ (Stmt : Iir_Case_Statement)
+ is
+ -- Selector.
+ Expr_Type : Iir;
Tinfo : Type_Info_Acc;
+ Expr_Node : O_Dnode;
+ C_Node : O_Dnode;
+
+ Choices_Chain : Iir;
+ Choice : Iir;
+ Has_Others : Boolean;
Func : Iir;
- Cond_Var : O_Dnode;
- Choice : Iir)
- is
- Cond : O_Enode;
- If_Blk : O_If_Block;
- Stmt_Chain : Iir;
- First : Boolean;
- Ch : Iir;
+
+ -- Number of non-others choices.
+ Nbr_Choices : Natural;
+ -- Number of associations.
+ Nbr_Assocs : Natural;
+
+ Info : Ortho_Info_Acc;
+ First, Last : Ortho_Info_Acc;
+ Sel_Length : Iir_Int64;
+
+ -- Dichotomy table (table of choices).
+ String_Type : O_Tnode;
+ Table_Base_Type : O_Tnode;
+ Table_Type : O_Tnode;
+ Table : O_Dnode;
+ List : O_Array_Aggr_List;
+ Table_Cst : O_Cnode;
+
+ -- Association table.
+ -- Indexed by the choice, returns an index to the associated
+ -- statement list.
+ -- Could be replaced by jump table.
+ Assoc_Table_Base_Type : O_Tnode;
+ Assoc_Table_Type : O_Tnode;
+ Assoc_Table : O_Dnode;
begin
- if Choice = Null_Iir then
- return;
- end if;
+ Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt);
- First := True;
- Stmt_Chain := Get_Associated (Choice);
- Ch := Choice;
- loop
- case Get_Kind (Ch) is
- when Iir_Kind_Choice_By_Expression =>
- Cond := Translate_Simple_String_Choice
- (Expr, Get_Expression (Ch), Val_Node, Tinfo, Func);
+ -- Count number of choices and number of associations.
+ Nbr_Choices := 0;
+ Nbr_Assocs := 0;
+ Choice := Choices_Chain;
+ First := null;
+ Last := null;
+ Has_Others := False;
+ while Choice /= Null_Iir loop
+ case Get_Kind (Choice) is
when Iir_Kind_Choice_By_Others =>
- Translate_Statements_Chain (Stmt_Chain);
- return;
+ Has_Others := True;
+ exit;
+ when Iir_Kind_Choice_By_Expression =>
+ null;
when others =>
- Error_Kind ("translate_string_choice", Ch);
+ raise Internal_Error;
end case;
- if not First then
- New_Assign_Stmt
- (New_Obj (Cond_Var),
- New_Dyadic_Op (ON_Or, New_Obj_Value (Cond_Var), Cond));
+ if not Get_Same_Alternative_Flag (Choice) then
+ Nbr_Assocs := Nbr_Assocs + 1;
end if;
- Ch := Get_Chain (Ch);
- exit when Ch = Null_Iir;
- exit when not Get_Same_Alternative_Flag (Ch);
- exit when Get_Associated (Ch) /= Null_Iir;
- if First then
- New_Assign_Stmt (New_Obj (Cond_Var), Cond);
- First := False;
+ Info := Add_Info (Choice, Kind_Str_Choice);
+ if First = null then
+ First := Info;
+ else
+ Last.Choice_Chain := Info;
end if;
+ Last := Info;
+ Info.Choice_Chain := null;
+ Info.Choice_Assoc := Nbr_Assocs - 1;
+ Info.Choice_Parent := Choice;
+ Info.Choice_Expr := Get_Expression (Choice);
+
+ Nbr_Choices := Nbr_Choices + 1;
+ Choice := Get_Chain (Choice);
end loop;
- if not First then
- Cond := New_Obj_Value (Cond_Var);
- end if;
- Start_If_Stmt (If_Blk, Cond);
- Translate_Statements_Chain (Stmt_Chain);
- New_Else_Stmt (If_Blk);
- Translate_String_Choice
- (Expr, Val_Node, Tinfo, Func, Cond_Var, Ch);
- Finish_If_Stmt (If_Blk);
- end Translate_String_Choice;
+
+ -- Sort choices.
+ declare
+ procedure Merge_Sort (Head : Ortho_Info_Acc;
+ Nbr : Natural;
+ Res : out Ortho_Info_Acc;
+ Next : out Ortho_Info_Acc)
+ is
+ L, R, L_End, R_End : Ortho_Info_Acc;
+ E, Last : Ortho_Info_Acc;
+ Half : constant Natural := Nbr / 2;
+ begin
+ -- Sorting less than 2 elements is easy!
+ if Nbr < 2 then
+ Res := Head;
+ if Nbr = 0 then
+ Next := Head;
+ else
+ Next := Head.Choice_Chain;
+ end if;
+ return;
+ end if;
+
+ Merge_Sort (Head, Half, L, L_End);
+ Merge_Sort (L_End, Nbr - Half, R, R_End);
+ Next := R_End;
+
+ -- Merge
+ Last := null;
+ loop
+ if L /= L_End
+ and then
+ (R = R_End
+ or else
+ Compare_String_Literals (L.Choice_Expr, R.Choice_Expr)
+ = Compare_Lt)
+ then
+ E := L;
+ L := L.Choice_Chain;
+ elsif R /= R_End then
+ E := R;
+ R := R.Choice_Chain;
+ else
+ exit;
+ end if;
+ if Last = null then
+ Res := E;
+ else
+ Last.Choice_Chain := E;
+ end if;
+ Last := E;
+ end loop;
+ Last.Choice_Chain := R_End;
+ end Merge_Sort;
+ Next : Ortho_Info_Acc;
+ begin
+ Merge_Sort (First, Nbr_Choices, First, Next);
+ if Next /= null then
+ raise Internal_Error;
+ end if;
+ end;
+
+ Translate_String_Case_Statement_Common
+ (Stmt, Expr_Type, Tinfo, Expr_Node, C_Node);
+
+ -- Generate choices table.
+ Sel_Length := Eval_Discrete_Type_Length
+ (Get_String_Type_Bound_Type (Expr_Type));
+ String_Type := New_Constrained_Array_Type
+ (Tinfo.T.Base_Type (Mode_Value),
+ New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Sel_Length)));
+ Table_Base_Type := New_Array_Type (String_Type, Ghdl_Index_Type);
+ New_Type_Decl (Create_Uniq_Identifier, Table_Base_Type);
+ Table_Type := New_Constrained_Array_Type
+ (Table_Base_Type,
+ New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices)));
+ New_Type_Decl (Create_Uniq_Identifier, Table_Type);
+ New_Const_Decl (Table, Create_Uniq_Identifier, O_Storage_Private,
+ Table_Type);
+ Start_Const_Value (Table);
+ Start_Array_Aggr (List, Table_Type);
+ Info := First;
+ while Info /= null loop
+ New_Array_Aggr_El (List, Chap7.Translate_Static_Expression
+ (Info.Choice_Expr, Expr_Type));
+ Info := Info.Choice_Chain;
+ end loop;
+ Finish_Array_Aggr (List, Table_Cst);
+ Finish_Const_Value (Table, Table_Cst);
+
+ -- Generate assoc table.
+ Assoc_Table_Base_Type :=
+ New_Array_Type (Ghdl_Index_Type, Ghdl_Index_Type);
+ New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Base_Type);
+ Assoc_Table_Type := New_Constrained_Array_Type
+ (Assoc_Table_Base_Type,
+ New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices)));
+ New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Type);
+ New_Const_Decl (Assoc_Table, Create_Uniq_Identifier,
+ O_Storage_Private, Assoc_Table_Type);
+ Start_Const_Value (Assoc_Table);
+ Start_Array_Aggr (List, Assoc_Table_Type);
+ Info := First;
+ while Info /= null loop
+ New_Array_Aggr_El
+ (List, New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Info.Choice_Assoc)));
+ Info := Info.Choice_Chain;
+ end loop;
+ Finish_Array_Aggr (List, Table_Cst);
+ Finish_Const_Value (Assoc_Table, Table_Cst);
+
+ -- Generate dichotomy code.
+ declare
+ Var_Lo, Var_Hi, Var_Mid : O_Dnode;
+ Var_Cmp : O_Dnode;
+ Var_Idx : O_Dnode;
+ Label : O_Snode;
+ Others_Lit : O_Cnode;
+ If_Blk1, If_Blk2 : O_If_Block;
+ Case_Blk : O_Case_Block;
+ begin
+ Var_Idx := Create_Temp (Ghdl_Index_Type);
+
+ Start_Declare_Stmt;
+
+ New_Var_Decl (Var_Lo, Wki_Lo, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_Hi, Wki_Hi, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_Mid, Wki_Mid, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_Cmp, Wki_Cmp,
+ O_Storage_Local, Ghdl_Compare_Type);
+
+ New_Assign_Stmt (New_Obj (Var_Lo), New_Lit (Ghdl_Index_0));
+ New_Assign_Stmt
+ (New_Obj (Var_Hi),
+ New_Lit (New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Nbr_Choices))));
+
+ Func := Chap7.Find_Predefined_Function
+ (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Greater);
+
+ if Has_Others then
+ Others_Lit := New_Unsigned_Literal
+ (Ghdl_Index_Type, Unsigned_64 (Nbr_Assocs));
+ end if;
+
+ Start_Loop_Stmt (Label);
+ New_Assign_Stmt
+ (New_Obj (Var_Mid),
+ New_Dyadic_Op (ON_Div_Ov,
+ New_Dyadic_Op (ON_Add_Ov,
+ New_Obj_Value (Var_Lo),
+ New_Obj_Value (Var_Hi)),
+ New_Lit (New_Unsigned_Literal
+ (Ghdl_Index_Type, 2))));
+ New_Assign_Stmt
+ (New_Obj (Var_Cmp),
+ Translate_Simple_String_Choice
+ (Expr_Node,
+ New_Address (New_Indexed_Element (New_Obj (Table),
+ New_Obj_Value (Var_Mid)),
+ Tinfo.T.Base_Ptr_Type (Mode_Value)),
+ C_Node, Tinfo, Func));
+ Start_If_Stmt
+ (If_Blk1,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_Cmp),
+ New_Lit (Ghdl_Compare_Eq),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt
+ (New_Obj (Var_Idx),
+ New_Value (New_Indexed_Element (New_Obj (Assoc_Table),
+ New_Obj_Value (Var_Mid))));
+ New_Exit_Stmt (Label);
+ Finish_If_Stmt (If_Blk1);
+
+ Start_If_Stmt
+ (If_Blk1,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_Cmp),
+ New_Lit (Ghdl_Compare_Lt),
+ Ghdl_Bool_Type));
+ Start_If_Stmt
+ (If_Blk2,
+ New_Compare_Op (ON_Le,
+ New_Obj_Value (Var_Mid),
+ New_Obj_Value (Var_Lo),
+ Ghdl_Bool_Type));
+ if not Has_Others then
+ Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_Bad_Choice);
+ else
+ New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit));
+ New_Exit_Stmt (Label);
+ end if;
+ New_Else_Stmt (If_Blk2);
+ New_Assign_Stmt (New_Obj (Var_Hi),
+ New_Dyadic_Op (ON_Sub_Ov,
+ New_Obj_Value (Var_Mid),
+ New_Lit (Ghdl_Index_1)));
+ Finish_If_Stmt (If_Blk2);
+
+ New_Else_Stmt (If_Blk1);
+
+ Start_If_Stmt
+ (If_Blk2,
+ New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_Mid),
+ New_Obj_Value (Var_Hi),
+ Ghdl_Bool_Type));
+ if not Has_Others then
+ Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice);
+ else
+ New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit));
+ New_Exit_Stmt (Label);
+ end if;
+ New_Else_Stmt (If_Blk2);
+ New_Assign_Stmt (New_Obj (Var_Lo),
+ New_Dyadic_Op (ON_Add_Ov,
+ New_Obj_Value (Var_Mid),
+ New_Lit (Ghdl_Index_1)));
+ Finish_If_Stmt (If_Blk2);
+
+ Finish_If_Stmt (If_Blk1);
+
+ Finish_Loop_Stmt (Label);
+
+ Finish_Declare_Stmt;
+
+ Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Idx));
+
+ Choice := Choices_Chain;
+ while Choice /= Null_Iir loop
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Others =>
+ Start_Choice (Case_Blk);
+ 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);
+ New_Expr_Choice
+ (Case_Blk,
+ New_Unsigned_Literal
+ (Ghdl_Index_Type,
+ Unsigned_64 (Get_Info (Choice).Choice_Assoc)));
+ Finish_Choice (Case_Blk);
+ Translate_Statements_Chain (Get_Associated (Choice));
+ end if;
+ Free_Info (Choice);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Choice := Get_Chain (Choice);
+ end loop;
+
+ Start_Choice (Case_Blk);
+ New_Default_Choice (Case_Blk);
+ Finish_Choice (Case_Blk);
+ Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice);
+
+ Finish_Case_Stmt (Case_Blk);
+ end;
+ end Translate_String_Case_Statement_Dichotomy;
-- Case statement whose expression is an unidim array.
- procedure Translate_String_Case_Statement (Stmt : Iir_Case_Statement)
+ -- Translate into if/elsif statements (linear search).
+ procedure Translate_String_Case_Statement_Linear
+ (Stmt : Iir_Case_Statement)
is
- Expr : Iir;
Expr_Type : Iir;
- Base_Type : Iir;
-- Node containing the address of the selector.
Expr_Node : O_Dnode;
-- Node containing the current choice.
- C_Node : O_Dnode;
+ Val_Node : O_Dnode;
Tinfo : Type_Info_Acc;
- Choices_Chain : Iir;
- Func : Iir;
Cond_Var : O_Dnode;
- begin
- -- Translate into if/elsif statements.
- -- FIXME: if the number of literals ** length of the array < 256,
- -- use a case statement.
- Expr := Get_Expression (Stmt);
- Expr_Type := Get_Type (Expr);
- Base_Type := Get_Base_Type (Expr_Type);
- Tinfo := Get_Info (Base_Type);
- Expr_Node := Create_Temp_Init
- (Tinfo.Ortho_Ptr_Type (Mode_Value),
- Chap7.Translate_Expression (Expr, Base_Type));
- C_Node := Create_Temp (Tinfo.Ortho_Type (Mode_Value));
- New_Assign_Stmt
- (New_Selected_Element (New_Obj (C_Node),
- Tinfo.T.Bounds_Field (Mode_Value)),
- New_Value_Selected_Acc_Value
- (New_Obj (Expr_Node), Tinfo.T.Bounds_Field (Mode_Value)));
+ Func : Iir;
- Cond_Var := Create_Temp (Std_Boolean_Type_Node);
+ procedure Translate_String_Choice (Choice : Iir)
+ is
+ Cond : O_Enode;
+ If_Blk : O_If_Block;
+ Stmt_Chain : Iir;
+ First : Boolean;
+ Ch : Iir;
+ Ch_Expr : Iir;
+ begin
+ if Choice = Null_Iir then
+ return;
+ end if;
+
+ First := True;
+ Stmt_Chain := Get_Associated (Choice);
+ Ch := Choice;
+ loop
+ case Get_Kind (Ch) is
+ when Iir_Kind_Choice_By_Expression =>
+ Ch_Expr := Get_Expression (Ch);
+ Cond := Translate_Simple_String_Choice
+ (Expr_Node,
+ Chap7.Translate_Expression (Ch_Expr,
+ Get_Type (Ch_Expr)),
+ Val_Node, Tinfo, Func);
+ when Iir_Kind_Choice_By_Others =>
+ Translate_Statements_Chain (Stmt_Chain);
+ return;
+ when others =>
+ Error_Kind ("translate_string_choice", Ch);
+ end case;
+ if not First then
+ New_Assign_Stmt
+ (New_Obj (Cond_Var),
+ New_Dyadic_Op (ON_Or, New_Obj_Value (Cond_Var), Cond));
+ end if;
+ Ch := Get_Chain (Ch);
+ exit when Ch = Null_Iir;
+ exit when not Get_Same_Alternative_Flag (Ch);
+ exit when Get_Associated (Ch) /= Null_Iir;
+ if First then
+ New_Assign_Stmt (New_Obj (Cond_Var), Cond);
+ First := False;
+ end if;
+ end loop;
+ if not First then
+ Cond := New_Obj_Value (Cond_Var);
+ end if;
+ Start_If_Stmt (If_Blk, Cond);
+ Translate_Statements_Chain (Stmt_Chain);
+ New_Else_Stmt (If_Blk);
+ Translate_String_Choice (Ch);
+ Finish_If_Stmt (If_Blk);
+ end Translate_String_Choice;
+ begin
+ Translate_String_Case_Statement_Common
+ (Stmt, Expr_Type, Tinfo, Expr_Node, Val_Node);
Func := Chap7.Find_Predefined_Function
- (Base_Type, Iir_Predefined_Array_Equality);
+ (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Equality);
- Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt);
- Translate_String_Choice
- (Expr_Node, C_Node,
- Tinfo, Func, Cond_Var, Choices_Chain);
- end Translate_String_Case_Statement;
+ Cond_Var := Create_Temp (Std_Boolean_Type_Node);
+
+ Translate_String_Choice (Get_Case_Statement_Alternative_Chain (Stmt));
+ end Translate_String_Case_Statement_Linear;
procedure Translate_Case_Choice
(Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block)
@@ -19045,7 +19490,30 @@ package body Translation is
Expr := Get_Expression (Stmt);
Expr_Type := Get_Type (Expr);
if Get_Kind (Expr_Type) = Iir_Kind_Array_Subtype_Definition then
- Translate_String_Case_Statement (Stmt);
+ declare
+ Nbr_Choices : Natural := 0;
+ Choice : Iir;
+ begin
+ Choice := Get_Case_Statement_Alternative_Chain (Stmt);
+ while Choice /= Null_Iir loop
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Others =>
+ exit;
+ when Iir_Kind_Choice_By_Expression =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Nbr_Choices := Nbr_Choices + 1;
+ Choice := Get_Chain (Choice);
+ end loop;
+
+ if Nbr_Choices < 3 then
+ Translate_String_Case_Statement_Linear (Stmt);
+ else
+ Translate_String_Case_Statement_Dichotomy (Stmt);
+ end if;
+ end;
return;
end if;
Start_Case_Stmt (Case_Blk, Chap7.Translate_Expression (Expr));
@@ -20950,6 +21418,313 @@ package body Translation is
Info.Process_Parent_Field := Field;
end Translate_Process_Declarations;
+ procedure Translate_Psl_Assert_Declarations (Stmt : Iir)
+ is
+ use PSL.Nodes;
+ use PSL.NFAs;
+
+ Mark : Id_Mark_Type;
+ Info : Ortho_Info_Acc;
+ Itype : O_Tnode;
+ Field : O_Fnode;
+
+ N : NFA;
+ begin
+ -- Create process record.
+ Push_Identifier_Prefix (Mark, Get_Identifier (Stmt));
+ Push_Instance_Factory (O_Tnode_Null);
+ Info := Add_Info (Stmt, Kind_Psl_Assert);
+
+ N := Get_PSL_NFA (Stmt);
+ Labelize_States (N, Info.Psl_Vect_Len);
+ Info.Psl_Vect_Type := New_Constrained_Array_Type
+ (Std_Boolean_Array_Type,
+ New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Info.Psl_Vect_Len)));
+ New_Type_Decl (Create_Identifier ("VECTTYPE"), Info.Psl_Vect_Type);
+ Info.Psl_Vect_Var :=
+ Create_Var (Create_Var_Identifier ("VECT"), Info.Psl_Vect_Type);
+
+ Pop_Instance_Factory (Itype);
+ New_Type_Decl (Create_Identifier ("INSTTYPE"), Itype);
+ Pop_Identifier_Prefix (Mark);
+
+ -- Create a field in the parent record.
+ Field := Add_Instance_Factory_Field
+ (Create_Identifier_Without_Prefix (Stmt), Itype);
+
+ -- Set info in child record.
+ Info.Psl_Decls_Type := Itype;
+ Info.Psl_Parent_Field := Field;
+ end Translate_Psl_Assert_Declarations;
+
+ function Translate_Psl_Expr (Expr : PSL_Node; Eos : Boolean)
+ return O_Enode
+ is
+ use PSL.Nodes;
+ begin
+ case Get_Kind (Expr) is
+ when N_HDL_Expr =>
+ declare
+ E : Iir;
+ Rtype : Iir;
+ Res : O_Enode;
+ begin
+ E := Get_HDL_Node (Expr);
+ Rtype := Get_Base_Type (Get_Type (E));
+ Res := Chap7.Translate_Expression (E);
+ if Rtype = Boolean_Type_Definition then
+ return Res;
+ elsif Rtype = Ieee.Std_Logic_1164.Std_Ulogic_Type then
+ return New_Value
+ (New_Indexed_Element
+ (New_Obj (Ghdl_Std_Ulogic_To_Boolean_Array),
+ New_Convert_Ov (Res, Ghdl_Index_Type)));
+ else
+ Error_Kind ("translate_psl_expr/hdl_expr", Expr);
+ end if;
+ end;
+ when N_True =>
+ return New_Lit (Std_Boolean_True_Node);
+ when N_EOS =>
+ if Eos then
+ return New_Lit (Std_Boolean_True_Node);
+ else
+ return New_Lit (Std_Boolean_False_Node);
+ end if;
+ when N_Not_Bool =>
+ return New_Monadic_Op
+ (ON_Not,
+ Translate_Psl_Expr (Get_Boolean (Expr), Eos));
+ when N_And_Bool =>
+ return New_Dyadic_Op
+ (ON_And,
+ Translate_Psl_Expr (Get_Left (Expr), Eos),
+ Translate_Psl_Expr (Get_Right (Expr), Eos));
+ when N_Or_Bool =>
+ return New_Dyadic_Op
+ (ON_Or,
+ Translate_Psl_Expr (Get_Left (Expr), Eos),
+ Translate_Psl_Expr (Get_Right (Expr), Eos));
+ when others =>
+ Error_Kind ("translate_psl_expr", Expr);
+ end case;
+ end Translate_Psl_Expr;
+
+ -- Return TRUE iff NFA has an edge with an EOS.
+ -- If so, we need to create a finalizer.
+ function Psl_Need_Finalizer (Nfa : PSL_NFA) return Boolean
+ is
+ use PSL.NFAs;
+ S : NFA_State;
+ E : NFA_Edge;
+ begin
+ S := Get_Final_State (Nfa);
+ E := Get_First_Dest_Edge (S);
+ while E /= No_Edge loop
+ if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then
+ return True;
+ end if;
+ E := Get_Next_Dest_Edge (E);
+ end loop;
+ return False;
+ end Psl_Need_Finalizer;
+
+ procedure Translate_Psl_Assert_Statement
+ (Stmt : Iir; Base : Block_Info_Acc)
+ is
+ use PSL.NFAs;
+ Inter_List : O_Inter_List;
+ Instance : O_Dnode;
+ Info : Psl_Info_Acc;
+ Var_I : O_Dnode;
+ Var_Nvec : O_Dnode;
+ Label : O_Snode;
+ Clk_Blk : O_If_Block;
+ S_Blk : O_If_Block;
+ E_Blk : O_If_Block;
+ S : NFA_State;
+ S_Num : Int32;
+ E : NFA_Edge;
+ Sd : NFA_State;
+ Cond : O_Enode;
+ NFA : PSL_NFA;
+ D_Lit : O_Cnode;
+ begin
+ Info := Get_Info (Stmt);
+ Start_Procedure_Decl (Inter_List, Create_Identifier ("PROC"),
+ O_Storage_Private);
+ New_Interface_Decl (Inter_List, Instance, Wki_Instance,
+ Base.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Subprg);
+
+ Start_Subprogram_Body (Info.Psl_Proc_Subprg);
+ Push_Local_Factory;
+ -- Push scope for architecture declarations.
+ Push_Scope (Base.Block_Decls_Type, Instance);
+
+ -- New state vector.
+ New_Var_Decl (Var_Nvec, Wki_Res, O_Storage_Local, Info.Psl_Vect_Type);
+
+ -- Initialize the new state vector.
+ Start_Declare_Stmt;
+ New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label,
+ New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I),
+ New_Lit (New_Unsigned_Literal
+ (Ghdl_Index_Type,
+ Unsigned_64 (Info.Psl_Vect_Len))),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt (New_Indexed_Element (New_Obj (Var_Nvec),
+ New_Obj_Value (Var_I)),
+ New_Lit (Std_Boolean_False_Node));
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Finish_Declare_Stmt;
+
+ -- Global if statement for the clock.
+ Open_Temp;
+ Start_If_Stmt (Clk_Blk,
+ Translate_Psl_Expr (Get_PSL_Clock (Stmt), False));
+
+ -- For each state: if set, evaluate all outgoing edges.
+ NFA := Get_PSL_NFA (Stmt);
+ S := Get_First_State (NFA);
+ while S /= No_State loop
+ S_Num := Get_State_Label (S);
+ Open_Temp;
+
+ Start_If_Stmt
+ (S_Blk,
+ New_Value
+ (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var),
+ New_Lit (New_Index_Lit
+ (Unsigned_64 (S_Num))))));
+
+ E := Get_First_Src_Edge (S);
+ while E /= No_Edge loop
+ Sd := Get_Edge_Dest (E);
+ Open_Temp;
+
+ D_Lit := New_Index_Lit (Unsigned_64 (Get_State_Label (Sd)));
+ Cond := New_Monadic_Op
+ (ON_Not,
+ New_Value (New_Indexed_Element (New_Obj (Var_Nvec),
+ New_Lit (D_Lit))));
+ Cond := New_Dyadic_Op
+ (ON_And, Cond, Translate_Psl_Expr (Get_Edge_Expr (E), False));
+ Start_If_Stmt (E_Blk, Cond);
+ New_Assign_Stmt
+ (New_Indexed_Element (New_Obj (Var_Nvec), New_Lit (D_Lit)),
+ New_Lit (Std_Boolean_True_Node));
+ Finish_If_Stmt (E_Blk);
+
+ Close_Temp;
+ E := Get_Next_Src_Edge (E);
+ end loop;
+
+ Finish_If_Stmt (S_Blk);
+ Close_Temp;
+ S := Get_Next_State (S);
+ end loop;
+
+ -- Check fail state.
+ S := Get_Final_State (NFA);
+ S_Num := Get_State_Label (S);
+ pragma Assert (Integer (S_Num) = Info.Psl_Vect_Len - 1);
+ Start_If_Stmt
+ (S_Blk,
+ New_Value
+ (New_Indexed_Element (New_Obj (Var_Nvec),
+ New_Lit (New_Index_Lit
+ (Unsigned_64 (S_Num))))));
+ Chap8.Translate_Report
+ (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error);
+ Finish_If_Stmt (S_Blk);
+
+ -- Assign state vector.
+ Start_Declare_Stmt;
+ New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label,
+ New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I),
+ New_Lit (New_Unsigned_Literal
+ (Ghdl_Index_Type,
+ Unsigned_64 (Info.Psl_Vect_Len))),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt
+ (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var),
+ New_Obj_Value (Var_I)),
+ New_Value (New_Indexed_Element (New_Obj (Var_Nvec),
+ New_Obj_Value (Var_I))));
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Finish_Declare_Stmt;
+
+ Close_Temp;
+ Finish_If_Stmt (Clk_Blk);
+
+ Pop_Scope (Base.Block_Decls_Type);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+
+ -- The finalizer.
+ if Psl_Need_Finalizer (NFA) then
+ Start_Procedure_Decl (Inter_List, Create_Identifier ("FINALPROC"),
+ O_Storage_Private);
+ New_Interface_Decl (Inter_List, Instance, Wki_Instance,
+ Base.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Final_Subprg);
+
+ Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg);
+ Push_Local_Factory;
+ -- Push scope for architecture declarations.
+ Push_Scope (Base.Block_Decls_Type, Instance);
+
+ S := Get_Final_State (NFA);
+ E := Get_First_Dest_Edge (S);
+ while E /= No_Edge loop
+ Sd := Get_Edge_Src (E);
+
+ if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then
+
+ S_Num := Get_State_Label (Sd);
+ Open_Temp;
+
+ Cond := New_Value
+ (New_Indexed_Element
+ (Get_Var (Info.Psl_Vect_Var),
+ New_Lit (New_Index_Lit (Unsigned_64 (S_Num)))));
+ Cond := New_Dyadic_Op
+ (ON_And, Cond,
+ Translate_Psl_Expr (Get_Edge_Expr (E), True));
+ Start_If_Stmt (E_Blk, Cond);
+ Chap8.Translate_Report
+ (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error);
+ New_Return_Stmt;
+ Finish_If_Stmt (E_Blk);
+
+ Close_Temp;
+ end if;
+
+ E := Get_Next_Dest_Edge (E);
+ end loop;
+
+ Pop_Scope (Base.Block_Decls_Type);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+ else
+ Info.Psl_Proc_Final_Subprg := O_Dnode_Null;
+ end if;
+ end Translate_Psl_Assert_Statement;
+
-- Create the instance for block BLOCK.
-- BLOCK can be either an entity, an architecture or a block statement.
procedure Translate_Block_Declarations (Block : Iir; Origin : Iir)
@@ -20964,6 +21739,12 @@ package body Translation is
when Iir_Kind_Process_Statement
| Iir_Kind_Sensitized_Process_Statement =>
Translate_Process_Declarations (El);
+ when Iir_Kind_Psl_Default_Clock =>
+ null;
+ when Iir_Kind_Psl_Declaration =>
+ null;
+ when Iir_Kind_Psl_Assert_Statement =>
+ Translate_Psl_Assert_Declarations (El);
when Iir_Kind_Component_Instantiation_Statement =>
Translate_Component_Instantiation_Statement (El);
when Iir_Kind_Block_Statement =>
@@ -21191,6 +21972,21 @@ package body Translation is
end if;
Pop_Scope (Info.Process_Decls_Type);
end;
+ when Iir_Kind_Psl_Default_Clock =>
+ null;
+ when Iir_Kind_Psl_Declaration =>
+ null;
+ when Iir_Kind_Psl_Assert_Statement =>
+ declare
+ Info : Psl_Info_Acc;
+ begin
+ Info := Get_Info (Stmt);
+ Push_Scope (Info.Psl_Decls_Type,
+ Info.Psl_Parent_Field,
+ Block_Info.Block_Decls_Type);
+ Translate_Psl_Assert_Statement (Stmt, Base_Info);
+ Pop_Scope (Info.Psl_Decls_Type);
+ end;
when Iir_Kind_Component_Instantiation_Statement =>
Chap4.Translate_Association_Subprograms
(Stmt, Block, Base_Block,
@@ -21511,6 +22307,89 @@ package body Translation is
Pop_Scope (Info.Process_Decls_Type);
end Elab_Process;
+ -- PROC: the process to be elaborated
+ -- BLOCK_INFO: info for the block containing the process
+ -- BASE_INFO: info for the global block
+ procedure Elab_Psl_Assert (Stmt : Iir;
+ Block_Info : Block_Info_Acc;
+ Base_Info : Block_Info_Acc)
+ is
+ Constr : O_Assoc_List;
+ Info : Psl_Info_Acc;
+ List : Iir_List;
+ Clk : PSL_Node;
+ Var_I : O_Dnode;
+ Label : O_Snode;
+ begin
+ New_Debug_Line_Stmt (Get_Line_Number (Stmt));
+
+ Info := Get_Info (Stmt);
+
+ -- Set instance name.
+ Push_Scope (Info.Psl_Decls_Type,
+ Info.Psl_Parent_Field,
+ Block_Info.Block_Decls_Type);
+
+ -- Register process.
+ Start_Association (Constr, Ghdl_Sensitized_Process_Register);
+ New_Association
+ (Constr, New_Unchecked_Address
+ (Get_Instance_Ref (Base_Info.Block_Decls_Type), Ghdl_Ptr_Type));
+ New_Association
+ (Constr,
+ New_Lit (New_Subprogram_Address (Info.Psl_Proc_Subprg,
+ Ghdl_Ptr_Type)));
+ Rtis.Associate_Rti_Context (Constr, Stmt);
+ New_Procedure_Call (Constr);
+
+ -- Register clock sensitivity.
+ Clk := Get_PSL_Clock (Stmt);
+ List := Create_Iir_List;
+ Canon_PSL.Canon_Extract_Sensitivity (Clk, List);
+ Destroy_Types_In_List (List);
+ Register_Signal_List (List, Ghdl_Process_Add_Sensitivity);
+ Destroy_Iir_List (List);
+
+ -- Register finalizer (if any).
+ if Info.Psl_Proc_Final_Subprg /= O_Dnode_Null then
+ Start_Association (Constr, Ghdl_Finalize_Register);
+ New_Association
+ (Constr, New_Unchecked_Address
+ (Get_Instance_Ref (Base_Info.Block_Decls_Type),
+ Ghdl_Ptr_Type));
+ New_Association
+ (Constr,
+ New_Lit (New_Subprogram_Address (Info.Psl_Proc_Final_Subprg,
+ Ghdl_Ptr_Type)));
+ New_Procedure_Call (Constr);
+ end if;
+
+ -- Initialize state vector.
+ Start_Declare_Stmt;
+ New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var),
+ New_Lit (Ghdl_Index_0)),
+ New_Lit (Std_Boolean_True_Node));
+ New_Assign_Stmt (New_Obj (Var_I), New_Lit (Ghdl_Index_1));
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label,
+ New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I),
+ New_Lit (New_Unsigned_Literal
+ (Ghdl_Index_Type,
+ Unsigned_64 (Info.Psl_Vect_Len))),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var),
+ New_Obj_Value (Var_I)),
+ New_Lit (Std_Boolean_False_Node));
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Finish_Declare_Stmt;
+
+ Pop_Scope (Info.Psl_Decls_Type);
+ end Elab_Psl_Assert;
+
procedure Elab_Implicit_Guard_Signal
(Block : Iir_Block_Statement; Block_Info : Block_Info_Acc)
is
@@ -22178,6 +23057,12 @@ package body Translation is
when Iir_Kind_Process_Statement
| Iir_Kind_Sensitized_Process_Statement =>
Elab_Process (Stmt, Block_Info, Base_Info);
+ when Iir_Kind_Psl_Default_Clock =>
+ null;
+ when Iir_Kind_Psl_Declaration =>
+ null;
+ when Iir_Kind_Psl_Assert_Statement =>
+ Elab_Psl_Assert (Stmt, Block_Info, Base_Info);
when Iir_Kind_Component_Instantiation_Statement =>
declare
Info : Block_Info_Acc;
@@ -24455,6 +25340,10 @@ package body Translation is
(Constr, Get_Identifier ("__ghdl_rtik_attribute_stable"),
Ghdl_Rtik_Attribute_Stable);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_psl_assert"),
+ Ghdl_Rtik_Psl_Assert);
+
New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_error"),
Ghdl_Rtik_Error);
Finish_Enum_Type (Constr, Ghdl_Rtik);
@@ -25205,6 +26094,8 @@ package body Translation is
case Info.Type_Mode is
when Type_Mode_I32 =>
Kind := Ghdl_Rtik_Type_I32;
+ when Type_Mode_I64 =>
+ Kind := Ghdl_Rtik_Type_I64;
when Type_Mode_F64 =>
Kind := Ghdl_Rtik_Type_F64;
when Type_Mode_P64 =>
@@ -26320,6 +27211,37 @@ package body Translation is
Push_Identifier_Prefix (Mark, Get_Identifier (Stmt));
Generate_Instance (Stmt, Parent_Rti);
Pop_Identifier_Prefix (Mark);
+ when Iir_Kind_Psl_Default_Clock =>
+ null;
+ when Iir_Kind_Psl_Declaration =>
+ null;
+ when Iir_Kind_Psl_Assert_Statement =>
+ declare
+ Name : O_Dnode;
+ List : O_Record_Aggr_List;
+
+ Rti : O_Dnode;
+ Res : O_Cnode;
+ Info : Psl_Info_Acc;
+ begin
+ Info := Get_Info (Stmt);
+ Push_Identifier_Prefix (Mark, Get_Identifier (Stmt));
+ Name := Generate_Name (Stmt);
+
+ New_Const_Decl (Rti, Create_Identifier ("RTI"),
+ O_Storage_Public, Ghdl_Rtin_Type_Scalar);
+
+ Start_Const_Value (Rti);
+ Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar);
+ New_Record_Aggr_El
+ (List, Generate_Common (Ghdl_Rtik_Psl_Assert));
+ New_Record_Aggr_El
+ (List, New_Global_Address (Name, Char_Ptr_Type));
+ Finish_Record_Aggr (List, Res);
+ Finish_Const_Value (Rti, Res);
+ Info.Psl_Rti_Const := Rti;
+ Pop_Identifier_Prefix (Mark);
+ end;
when others =>
Error_Kind ("rti.generate_concurrent_statement_chain", Stmt);
end case;
@@ -26710,6 +27632,8 @@ package body Translation is
when Iir_Kind_Process_Statement
| Iir_Kind_Sensitized_Process_Statement =>
Rti_Const := Node_Info.Process_Rti_Const;
+ when Iir_Kind_Psl_Assert_Statement =>
+ Rti_Const := Node_Info.Psl_Rti_Const;
when others =>
Error_Kind ("get_context_rti", Node);
end case;
@@ -26738,6 +27662,8 @@ package body Translation is
when Iir_Kind_Process_Statement
| Iir_Kind_Sensitized_Process_Statement =>
Block_Type := Node_Info.Process_Decls_Type;
+ when Iir_Kind_Psl_Assert_Statement =>
+ Block_Type := Node_Info.Psl_Decls_Type;
when others =>
Error_Kind ("get_context_addr", Node);
end case;
@@ -26935,8 +27861,6 @@ package body Translation is
Wki_Right := Get_Identifier ("right");
Wki_Dir := Get_Identifier ("dir");
Wki_Length := Get_Identifier ("length");
- Wki_Kind := Get_Identifier ("kind");
- Wki_Dim := Get_Identifier ("dim");
Wki_I := Get_Identifier ("I");
Wki_Instance := Get_Identifier ("INSTANCE");
Wki_Arch_Instance := Get_Identifier ("ARCH_INSTANCE");
@@ -26947,6 +27871,10 @@ package body Translation is
Wki_Parent := Get_Identifier ("parent");
Wki_Filename := Get_Identifier ("filename");
Wki_Line := Get_Identifier ("line");
+ Wki_Lo := Get_Identifier ("lo");
+ Wki_Hi := Get_Identifier ("hi");
+ Wki_Mid := Get_Identifier ("mid");
+ Wki_Cmp := Get_Identifier ("cmp");
Sizetype := New_Unsigned_Type (32);
New_Type_Decl (Get_Identifier ("__ghdl_size_type"), Sizetype);
@@ -27296,6 +28224,15 @@ package body Translation is
("__ghdl_postponed_sensitized_process_register",
Ghdl_Postponed_Sensitized_Process_Register);
end;
+
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_finalize_register"),
+ O_Storage_External);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_This, Ghdl_Ptr_Type);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("proc"), Ghdl_Ptr_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Finalize_Register);
end Initialize;
procedure Create_Signal_Subprograms
@@ -27486,6 +28423,8 @@ package body Translation is
end Create_Report_Subprg;
begin
Create_Report_Subprg ("__ghdl_assert_failed", Ghdl_Assert_Failed);
+ Create_Report_Subprg ("__ghdl_psl_assert_failed",
+ Ghdl_Psl_Assert_Failed);
Create_Report_Subprg ("__ghdl_report", Ghdl_Report);
end;
@@ -28260,6 +29199,10 @@ package body Translation is
Std_Boolean_True_Node := Get_Ortho_Expr (Boolean_True);
Std_Boolean_False_Node := Get_Ortho_Expr (Boolean_False);
+ Std_Boolean_Array_Type :=
+ New_Array_Type (Std_Boolean_Type_Node, Ghdl_Index_Type);
+ New_Type_Decl (Create_Identifier ("BOOLEAN_ARRAY"),
+ Std_Boolean_Array_Type);
Chap4.Translate_Bool_Type_Declaration (Bit_Type);
Chap4.Translate_Type_Declaration (Character_Type);
@@ -28337,6 +29280,16 @@ package body Translation is
:= Get_Info (Bit_Type_Definition).Type_Rti;
end if;
+ -- Std_Ulogic indexed array of STD.Boolean.
+ -- Used by PSL to convert Std_Ulogic to boolean.
+ Std_Ulogic_Boolean_Array_Type :=
+ New_Constrained_Array_Type (Std_Boolean_Array_Type, New_Index_Lit (9));
+ New_Type_Decl (Get_Identifier ("__ghdl_std_ulogic_boolean_array_type"),
+ Std_Ulogic_Boolean_Array_Type);
+ New_Const_Decl (Ghdl_Std_Ulogic_To_Boolean_Array,
+ Get_Identifier ("__ghdl_std_ulogic_to_boolean_array"),
+ O_Storage_External, Std_Ulogic_Boolean_Array_Type);
+
Pop_Identifier_Prefix (Unit_Mark);
Pop_Identifier_Prefix (Lib_Mark);
generated by cgit (git 2.34.1) at 2025-03-30 07:07:11 +0000